home *** CD-ROM | disk | FTP | other *** search
/ Los Alamos National Laboratory / LANL_CD.ISO / software / slatec / source.txt < prev    next >
Encoding:
Text File  |  1992-10-16  |  7.6 MB  |  221,872 lines
Text Truncated. Only the first 1MB is shown below. Download the file for the complete contents.
  1. *DECK AAAAAA
  2.       SUBROUTINE AAAAAA (VER)
  3. C***BEGIN PROLOGUE  AAAAAA
  4. C***PURPOSE  SLATEC Common Mathematical Library disclaimer and version.
  5. C***LIBRARY   SLATEC
  6. C***CATEGORY  Z
  7. C***TYPE      ALL (AAAAAA-A)
  8. C***KEYWORDS  DISCLAIMER, DOCUMENTATION, VERSION
  9. C***AUTHOR  SLATEC Common Mathematical Library Committee
  10. C***DESCRIPTION
  11. C
  12. C   The SLATEC Common Mathematical Library is issued by the following
  13. C
  14. C           Air Force Weapons Laboratory, Albuquerque
  15. C           Lawrence Livermore National Laboratory, Livermore
  16. C           Los Alamos National Laboratory, Los Alamos
  17. C           National Institute of Standards and Technology, Washington
  18. C           National Energy Research Supercomputer Center, Livermore
  19. C           Oak Ridge National Laboratory, Oak Ridge
  20. C           Sandia National Laboratories, Albuquerque
  21. C           Sandia National Laboratories, Livermore
  22. C
  23. C   All questions concerning the distribution of the library should be
  24. C   directed to the NATIONAL ENERGY SOFTWARE CENTER, 9700 Cass Ave.,
  25. C   Argonne, Illinois  60439, and not to the authors of the subprograms.
  26. C
  27. C                    * * * * * Notice * * * * *
  28. C
  29. C   This material was prepared as an account of work sponsored by the
  30. C   United States Government.  Neither the United States, nor the
  31. C   Department of Energy, nor the Department of Defense, nor any of
  32. C   their employees, nor any of their contractors, subcontractors, or
  33. C   their employees, makes any warranty, expressed or implied, or
  34. C   assumes any legal liability or responsibility for the accuracy,
  35. C   completeness, or usefulness of any information, apparatus, product,
  36. C   or process disclosed, or represents that its use would not infringe
  37. C   upon privately owned rights.
  38. C
  39. C *Usage:
  40. C
  41. C        CHARACTER * 16 VER
  42. C
  43. C        CALL AAAAAA (VER)
  44. C
  45. C *Arguments:
  46. C
  47. C     VER:OUT   will contain the version number of the SLATEC CML.
  48. C
  49. C *Description:
  50. C
  51. C   This routine contains the SLATEC Common Mathematical Library
  52. C   disclaimer and can be used to return the library version number.
  53. C
  54. C***REFERENCES  Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro
  55. C                 and Lee Walton, Guide to the SLATEC Common Mathema-
  56. C                 tical Library, April 10, 1990.
  57. C***ROUTINES CALLED  (NONE)
  58. C***REVISION HISTORY  (YYMMDD)
  59. C   800424  DATE WRITTEN
  60. C   890414  REVISION DATE from Version 3.2
  61. C   890713  Routine modified to return version number.  (WRB)
  62. C   900330  Prologue converted to Version 4.0 format.  (BAB)
  63. C   920501  Reformatted the REFERENCES section.  (WRB)
  64. C***END PROLOGUE  AAAAAA
  65.       CHARACTER * (*) VER
  66. C***FIRST EXECUTABLE STATEMENT  AAAAAA
  67.       VER = ' 4.0-'
  68.       RETURN
  69.       END
  70. *DECK ACOSH
  71.       FUNCTION ACOSH (X)
  72. C***BEGIN PROLOGUE  ACOSH
  73. C***PURPOSE  Compute the arc hyperbolic cosine.
  74. C***LIBRARY   SLATEC (FNLIB)
  75. C***CATEGORY  C4C
  76. C***TYPE      SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C)
  77. C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
  78. C             INVERSE HYPERBOLIC COSINE
  79. C***AUTHOR  Fullerton, W., (LANL)
  80. C***DESCRIPTION
  81. C
  82. C ACOSH(X) computes the arc hyperbolic cosine of X.
  83. C
  84. C***REFERENCES  (NONE)
  85. C***ROUTINES CALLED  R1MACH, XERMSG
  86. C***REVISION HISTORY  (YYMMDD)
  87. C   770401  DATE WRITTEN
  88. C   890531  Changed all specific intrinsics to generic.  (WRB)
  89. C   890531  REVISION DATE from Version 3.2
  90. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  91. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  92. C   900326  Removed duplicate information from DESCRIPTION section.
  93. C           (WRB)
  94. C***END PROLOGUE  ACOSH
  95.       SAVE ALN2,XMAX
  96.       DATA ALN2 / 0.6931471805 5994530942E0/
  97.       DATA XMAX /0./
  98. C***FIRST EXECUTABLE STATEMENT  ACOSH
  99.       IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3))
  100. C
  101.       IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1',
  102.      +   1, 2)
  103. C
  104.       IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0))
  105.       IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X)
  106. C
  107.       RETURN
  108.       END
  109. *DECK AI
  110.       FUNCTION AI (X)
  111. C***BEGIN PROLOGUE  AI
  112. C***PURPOSE  Evaluate the Airy function.
  113. C***LIBRARY   SLATEC (FNLIB)
  114. C***CATEGORY  C10D
  115. C***TYPE      SINGLE PRECISION (AI-S, DAI-D)
  116. C***KEYWORDS  AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
  117. C***AUTHOR  Fullerton, W., (LANL)
  118. C***DESCRIPTION
  119. C
  120. C AI(X) computes the Airy function Ai(X)
  121. C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
  122. C                                        with weighted error   1.09E-19
  123. C                                         log weighted error  18.96
  124. C                               significant figures required  17.76
  125. C                                    decimal places required  19.44
  126. C
  127. C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
  128. C                                        with weighted error   1.51E-17
  129. C                                         log weighted error  16.82
  130. C                               significant figures required  15.19
  131. C                                    decimal places required  17.27
  132. C
  133. C***REFERENCES  (NONE)
  134. C***ROUTINES CALLED  AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
  135. C***REVISION HISTORY  (YYMMDD)
  136. C   770701  DATE WRITTEN
  137. C   890531  Changed all specific intrinsics to generic.  (WRB)
  138. C   890531  REVISION DATE from Version 3.2
  139. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  140. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  141. C   900326  Removed duplicate information from DESCRIPTION section.
  142. C           (WRB)
  143. C   920618  Removed space from variable names.  (RWC, WRB)
  144. C***END PROLOGUE  AI
  145.       DIMENSION AIFCS(9), AIGCS(8)
  146.       LOGICAL FIRST
  147.       SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST
  148.       DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
  149.       DATA AIFCS( 2) /    .0591918885 3726363857E0 /
  150.       DATA AIFCS( 3) /    .0009862928 0577279975E0 /
  151.       DATA AIFCS( 4) /    .0000068488 4381907656E0 /
  152.       DATA AIFCS( 5) /    .0000000259 4202596219E0 /
  153.       DATA AIFCS( 6) /    .0000000000 6176612774E0 /
  154.       DATA AIFCS( 7) /    .0000000000 0010092454E0 /
  155.       DATA AIFCS( 8) /    .0000000000 0000012014E0 /
  156.       DATA AIFCS( 9) /    .0000000000 0000000010E0 /
  157.       DATA AIGCS( 1) /    .0181523655 8116127E0 /
  158.       DATA AIGCS( 2) /    .0215725631 6601076E0 /
  159.       DATA AIGCS( 3) /    .0002567835 6987483E0 /
  160.       DATA AIGCS( 4) /    .0000014265 2141197E0 /
  161.       DATA AIGCS( 5) /    .0000000045 7211492E0 /
  162.       DATA AIGCS( 6) /    .0000000000 0952517E0 /
  163.       DATA AIGCS( 7) /    .0000000000 0001392E0 /
  164.       DATA AIGCS( 8) /    .0000000000 0000001E0 /
  165.       DATA FIRST /.TRUE./
  166. C***FIRST EXECUTABLE STATEMENT  AI
  167.       IF (FIRST) THEN
  168.          NAIF = INITS (AIFCS, 9, 0.1*R1MACH(3))
  169.          NAIG = INITS (AIGCS, 8, 0.1*R1MACH(3))
  170. C
  171.          X3SML = R1MACH(3)**0.3334
  172.          XMAXT = (-1.5*LOG(R1MACH(1)))**0.6667
  173.          XMAX = XMAXT - XMAXT*LOG(XMAXT)/
  174.      *                   (4.0*SQRT(XMAXT)+1.0) - 0.01
  175.       ENDIF
  176.       FIRST = .FALSE.
  177. C
  178.       IF (X.GE.(-1.0)) GO TO 20
  179.       CALL R9AIMP (X, XM, THETA)
  180.       AI = XM * COS(THETA)
  181.       RETURN
  182. C
  183.  20   IF (X.GT.1.0) GO TO 30
  184.       Z = 0.0
  185.       IF (ABS(X).GT.X3SML) Z = X**3
  186.       AI = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
  187.      1  CSEVL (Z, AIGCS, NAIG)) )
  188.       RETURN
  189. C
  190.  30   IF (X.GT.XMAX) GO TO 40
  191.       AI = AIE(X) * EXP(-2.0*X*SQRT(X)/3.0)
  192.       RETURN
  193. C
  194.  40   AI = 0.0
  195.       CALL XERMSG ('SLATEC', 'AI', 'X SO BIG AI UNDERFLOWS', 1, 1)
  196.       RETURN
  197. C
  198.       END
  199. *DECK AIE
  200.       FUNCTION AIE (X)
  201. C***BEGIN PROLOGUE  AIE
  202. C***PURPOSE  Calculate the Airy function for a negative argument and an
  203. C            exponentially scaled Airy function for a non-negative
  204. C            argument.
  205. C***LIBRARY   SLATEC (FNLIB)
  206. C***CATEGORY  C10D
  207. C***TYPE      SINGLE PRECISION (AIE-S, DAIE-D)
  208. C***KEYWORDS  EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB,
  209. C             SPECIAL FUNCTIONS
  210. C***AUTHOR  Fullerton, W., (LANL)
  211. C***DESCRIPTION
  212. C
  213. C AIE(X) computes the exponentially scaled Airy function for
  214. C non-negative X.  It evaluates AI(X) for X .LE. 0.0 and
  215. C EXP(ZETA)*AI(X) for X .GE. 0.0 where ZETA = (2.0/3.0)*(X**1.5).
  216. C
  217. C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
  218. C                                        with weighted error   1.09E-19
  219. C                                         log weighted error  18.96
  220. C                               significant figures required  17.76
  221. C                                    decimal places required  19.44
  222. C
  223. C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
  224. C                                        with weighted error   1.51E-17
  225. C                                         log weighted error  16.82
  226. C                               significant figures required  15.19
  227. C                                    decimal places required  17.27
  228. C
  229. C Series for AIP        on the interval  0.          to  1.00000D+00
  230. C                                        with weighted error   5.10E-17
  231. C                                         log weighted error  16.29
  232. C                               significant figures required  14.41
  233. C                                    decimal places required  17.06
  234. C
  235. C***REFERENCES  (NONE)
  236. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
  237. C***REVISION HISTORY  (YYMMDD)
  238. C   770701  DATE WRITTEN
  239. C   890206  REVISION DATE from Version 3.2
  240. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  241. C   920618  Removed space from variable names.  (RWC, WRB)
  242. C***END PROLOGUE  AIE
  243.       DIMENSION AIFCS(9), AIGCS(8), AIPCS(34)
  244.       LOGICAL FIRST
  245.       SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG,
  246.      1 NAIP, X3SML, X32SML, XBIG, FIRST
  247.       DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
  248.       DATA AIFCS( 2) /    .0591918885 3726363857E0 /
  249.       DATA AIFCS( 3) /    .0009862928 0577279975E0 /
  250.       DATA AIFCS( 4) /    .0000068488 4381907656E0 /
  251.       DATA AIFCS( 5) /    .0000000259 4202596219E0 /
  252.       DATA AIFCS( 6) /    .0000000000 6176612774E0 /
  253.       DATA AIFCS( 7) /    .0000000000 0010092454E0 /
  254.       DATA AIFCS( 8) /    .0000000000 0000012014E0 /
  255.       DATA AIFCS( 9) /    .0000000000 0000000010E0 /
  256.       DATA AIGCS( 1) /    .0181523655 8116127E0 /
  257.       DATA AIGCS( 2) /    .0215725631 6601076E0 /
  258.       DATA AIGCS( 3) /    .0002567835 6987483E0 /
  259.       DATA AIGCS( 4) /    .0000014265 2141197E0 /
  260.       DATA AIGCS( 5) /    .0000000045 7211492E0 /
  261.       DATA AIGCS( 6) /    .0000000000 0952517E0 /
  262.       DATA AIGCS( 7) /    .0000000000 0001392E0 /
  263.       DATA AIGCS( 8) /    .0000000000 0000001E0 /
  264.       DATA AIPCS( 1) /   -.0187519297 793868E0 /
  265.       DATA AIPCS( 2) /   -.0091443848 250055E0 /
  266.       DATA AIPCS( 3) /    .0009010457 337825E0 /
  267.       DATA AIPCS( 4) /   -.0001394184 127221E0 /
  268.       DATA AIPCS( 5) /    .0000273815 815785E0 /
  269.       DATA AIPCS( 6) /   -.0000062750 421119E0 /
  270.       DATA AIPCS( 7) /    .0000016064 844184E0 /
  271.       DATA AIPCS( 8) /   -.0000004476 392158E0 /
  272.       DATA AIPCS( 9) /    .0000001334 635874E0 /
  273.       DATA AIPCS(10) /   -.0000000420 735334E0 /
  274.       DATA AIPCS(11) /    .0000000139 021990E0 /
  275.       DATA AIPCS(12) /   -.0000000047 831848E0 /
  276.       DATA AIPCS(13) /    .0000000017 047897E0 /
  277.       DATA AIPCS(14) /   -.0000000006 268389E0 /
  278.       DATA AIPCS(15) /    .0000000002 369824E0 /
  279.       DATA AIPCS(16) /   -.0000000000 918641E0 /
  280.       DATA AIPCS(17) /    .0000000000 364278E0 /
  281.       DATA AIPCS(18) /   -.0000000000 147475E0 /
  282.       DATA AIPCS(19) /    .0000000000 060851E0 /
  283.       DATA AIPCS(20) /   -.0000000000 025552E0 /
  284.       DATA AIPCS(21) /    .0000000000 010906E0 /
  285.       DATA AIPCS(22) /   -.0000000000 004725E0 /
  286.       DATA AIPCS(23) /    .0000000000 002076E0 /
  287.       DATA AIPCS(24) /   -.0000000000 000924E0 /
  288.       DATA AIPCS(25) /    .0000000000 000417E0 /
  289.       DATA AIPCS(26) /   -.0000000000 000190E0 /
  290.       DATA AIPCS(27) /    .0000000000 000087E0 /
  291.       DATA AIPCS(28) /   -.0000000000 000040E0 /
  292.       DATA AIPCS(29) /    .0000000000 000019E0 /
  293.       DATA AIPCS(30) /   -.0000000000 000009E0 /
  294.       DATA AIPCS(31) /    .0000000000 000004E0 /
  295.       DATA AIPCS(32) /   -.0000000000 000002E0 /
  296.       DATA AIPCS(33) /    .0000000000 000001E0 /
  297.       DATA AIPCS(34) /   -.0000000000 000000E0 /
  298.       DATA FIRST /.TRUE./
  299. C***FIRST EXECUTABLE STATEMENT  AIE
  300.       IF (FIRST) THEN
  301.          ETA = 0.1*R1MACH(3)
  302.          NAIF  = INITS (AIFCS, 9, ETA)
  303.          NAIG  = INITS (AIGCS, 8, ETA)
  304.          NAIP  = INITS (AIPCS, 34, ETA)
  305. C
  306.          X3SML = ETA**0.3333
  307.          X32SML = 1.3104*X3SML**2
  308.          XBIG = R1MACH(2)**0.6666
  309.       ENDIF
  310.       FIRST = .FALSE.
  311. C
  312.       IF (X.GE.(-1.0)) GO TO 20
  313.       CALL R9AIMP (X, XM, THETA)
  314.       AIE = XM * COS(THETA)
  315.       RETURN
  316. C
  317.  20   IF (X.GT.1.0) GO TO 30
  318.       Z = 0.0
  319.       IF (ABS(X).GT.X3SML) Z = X**3
  320.       AIE = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
  321.      1  CSEVL (Z, AIGCS, NAIG)) )
  322.       IF (X.GT.X32SML) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0)
  323.       RETURN
  324. C
  325.  30   SQRTX = SQRT(X)
  326.       Z = -1.0
  327.       IF (X.LT.XBIG) Z = 2.0/(X*SQRTX) - 1.0
  328.       AIE = (.28125 + CSEVL (Z, AIPCS, NAIP))/SQRT(SQRTX)
  329.       RETURN
  330. C
  331.       END
  332. *DECK ALBETA
  333.       FUNCTION ALBETA (A, B)
  334. C***BEGIN PROLOGUE  ALBETA
  335. C***PURPOSE  Compute the natural logarithm of the complete Beta
  336. C            function.
  337. C***LIBRARY   SLATEC (FNLIB)
  338. C***CATEGORY  C7B
  339. C***TYPE      SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
  340. C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
  341. C             SPECIAL FUNCTIONS
  342. C***AUTHOR  Fullerton, W., (LANL)
  343. C***DESCRIPTION
  344. C
  345. C ALBETA computes the natural log of the complete beta function.
  346. C
  347. C Input Parameters:
  348. C       A   real and positive
  349. C       B   real and positive
  350. C
  351. C***REFERENCES  (NONE)
  352. C***ROUTINES CALLED  ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG
  353. C***REVISION HISTORY  (YYMMDD)
  354. C   770701  DATE WRITTEN
  355. C   890531  Changed all specific intrinsics to generic.  (WRB)
  356. C   890531  REVISION DATE from Version 3.2
  357. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  358. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  359. C   900326  Removed duplicate information from DESCRIPTION section.
  360. C           (WRB)
  361. C   900727  Added EXTERNAL statement.  (WRB)
  362. C***END PROLOGUE  ALBETA
  363.       EXTERNAL GAMMA
  364.       SAVE SQ2PIL
  365.       DATA SQ2PIL / 0.9189385332 0467274 E0 /
  366. C***FIRST EXECUTABLE STATEMENT  ALBETA
  367.       P = MIN (A, B)
  368.       Q = MAX (A, B)
  369. C
  370.       IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA',
  371.      +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
  372.       IF (P.GE.10.0) GO TO 30
  373.       IF (Q.GE.10.0) GO TO 20
  374. C
  375. C P AND Q ARE SMALL.
  376. C
  377.       ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) )
  378.       RETURN
  379. C
  380. C P IS SMALL, BUT Q IS BIG.
  381. C
  382.  20   CORR = R9LGMC(Q) - R9LGMC(P+Q)
  383.       ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) +
  384.      1  (Q-0.5)*ALNREL(-P/(P+Q))
  385.       RETURN
  386. C
  387. C P AND Q ARE BIG.
  388. C
  389.  30   CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q)
  390.       ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q))
  391.      1  + Q*ALNREL(-P/(P+Q))
  392.       RETURN
  393. C
  394.       END
  395. *DECK ALGAMS
  396.       SUBROUTINE ALGAMS (X, ALGAM, SGNGAM)
  397. C***BEGIN PROLOGUE  ALGAMS
  398. C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
  399. C            function.
  400. C***LIBRARY   SLATEC (FNLIB)
  401. C***CATEGORY  C7A
  402. C***TYPE      SINGLE PRECISION (ALGAMS-S, DLGAMS-D)
  403. C***KEYWORDS  ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION,
  404. C             FNLIB, SPECIAL FUNCTIONS
  405. C***AUTHOR  Fullerton, W., (LANL)
  406. C***DESCRIPTION
  407. C
  408. C Evaluates the logarithm of the absolute value of the gamma
  409. C function.
  410. C     X           - input argument
  411. C     ALGAM       - result
  412. C     SGNGAM      - is set to the sign of GAMMA(X) and will
  413. C                   be returned at +1.0 or -1.0.
  414. C
  415. C***REFERENCES  (NONE)
  416. C***ROUTINES CALLED  ALNGAM
  417. C***REVISION HISTORY  (YYMMDD)
  418. C   770701  DATE WRITTEN
  419. C   890531  Changed all specific intrinsics to generic.  (WRB)
  420. C   890531  REVISION DATE from Version 3.2
  421. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  422. C***END PROLOGUE  ALGAMS
  423. C***FIRST EXECUTABLE STATEMENT  ALGAMS
  424.       ALGAM = ALNGAM(X)
  425.       SGNGAM = 1.0
  426.       IF (X.GT.0.0) RETURN
  427. C
  428.       INT = MOD (-AINT(X), 2.0) + 0.1
  429.       IF (INT.EQ.0) SGNGAM = -1.0
  430. C
  431.       RETURN
  432.       END
  433. *DECK ALI
  434.       FUNCTION ALI (X)
  435. C***BEGIN PROLOGUE  ALI
  436. C***PURPOSE  Compute the logarithmic integral.
  437. C***LIBRARY   SLATEC (FNLIB)
  438. C***CATEGORY  C5
  439. C***TYPE      SINGLE PRECISION (ALI-S, DLI-D)
  440. C***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
  441. C***AUTHOR  Fullerton, W., (LANL)
  442. C***DESCRIPTION
  443. C
  444. C ALI(X) computes the logarithmic integral; i.e., the
  445. C integral from 0.0 to X of (1.0/ln(t))dt.
  446. C
  447. C***REFERENCES  (NONE)
  448. C***ROUTINES CALLED  EI, XERMSG
  449. C***REVISION HISTORY  (YYMMDD)
  450. C   770601  DATE WRITTEN
  451. C   890531  Changed all specific intrinsics to generic.  (WRB)
  452. C   890531  REVISION DATE from Version 3.2
  453. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  454. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  455. C   900326  Removed duplicate information from DESCRIPTION section.
  456. C           (WRB)
  457. C***END PROLOGUE  ALI
  458. C***FIRST EXECUTABLE STATEMENT  ALI
  459.       IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'ALI',
  460.      +   'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2)
  461.       IF (X .EQ. 1.0) CALL XERMSG ('SLATEC', 'ALI',
  462.      +   'LOG INTEGRAL UNDEFINED FOR X = 1', 2, 2)
  463. C
  464.       ALI = EI (LOG(X) )
  465. C
  466.       RETURN
  467.       END
  468. *DECK ALNGAM
  469.       FUNCTION ALNGAM (X)
  470. C***BEGIN PROLOGUE  ALNGAM
  471. C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
  472. C            function.
  473. C***LIBRARY   SLATEC (FNLIB)
  474. C***CATEGORY  C7A
  475. C***TYPE      SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
  476. C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
  477. C             SPECIAL FUNCTIONS
  478. C***AUTHOR  Fullerton, W., (LANL)
  479. C***DESCRIPTION
  480. C
  481. C ALNGAM(X) computes the logarithm of the absolute value of the
  482. C gamma function at X.
  483. C
  484. C***REFERENCES  (NONE)
  485. C***ROUTINES CALLED  GAMMA, R1MACH, R9LGMC, XERMSG
  486. C***REVISION HISTORY  (YYMMDD)
  487. C   770601  DATE WRITTEN
  488. C   890531  Changed all specific intrinsics to generic.  (WRB)
  489. C   890531  REVISION DATE from Version 3.2
  490. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  491. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  492. C   900326  Removed duplicate information from DESCRIPTION section.
  493. C           (WRB)
  494. C   900727  Added EXTERNAL statement.  (WRB)
  495. C***END PROLOGUE  ALNGAM
  496.       LOGICAL FIRST
  497.       EXTERNAL GAMMA
  498.       SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
  499.       DATA SQ2PIL / 0.9189385332 0467274E0/
  500.       DATA SQPI2L / 0.2257913526 4472743E0/
  501.       DATA PI     / 3.1415926535 8979324E0/
  502.       DATA FIRST  /.TRUE./
  503. C***FIRST EXECUTABLE STATEMENT  ALNGAM
  504.       IF (FIRST) THEN
  505.          XMAX = R1MACH(2)/LOG(R1MACH(2))
  506.          DXREL = SQRT (R1MACH(4))
  507.       ENDIF
  508.       FIRST = .FALSE.
  509. C
  510.       Y = ABS(X)
  511.       IF (Y.GT.10.0) GO TO 20
  512. C
  513. C LOG (ABS (GAMMA(X))) FOR  ABS(X) .LE. 10.0
  514. C
  515.       ALNGAM = LOG (ABS (GAMMA(X)))
  516.       RETURN
  517. C
  518. C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0
  519. C
  520.  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM',
  521.      +   'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2)
  522. C
  523.       IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y)
  524.       IF (X.GT.0.) RETURN
  525. C
  526.       SINPIY = ABS (SIN(PI*Y))
  527.       IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM',
  528.      +   'X IS A NEGATIVE INTEGER', 3, 2)
  529. C
  530.       IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
  531.      +   'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' //
  532.      +   'NEGATIVE INTEGER', 1, 1)
  533. C
  534.       ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y)
  535.       RETURN
  536. C
  537.       END
  538. *DECK ALNREL
  539.       FUNCTION ALNREL (X)
  540. C***BEGIN PROLOGUE  ALNREL
  541. C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
  542. C***LIBRARY   SLATEC (FNLIB)
  543. C***CATEGORY  C4B
  544. C***TYPE      SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C)
  545. C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
  546. C***AUTHOR  Fullerton, W., (LANL)
  547. C***DESCRIPTION
  548. C
  549. C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative
  550. C error when X is very small.  This routine must be used to
  551. C maintain relative error accuracy whenever X is small and
  552. C accurately known.
  553. C
  554. C Series for ALNR       on the interval -3.75000D-01 to  3.75000D-01
  555. C                                        with weighted error   1.93E-17
  556. C                                         log weighted error  16.72
  557. C                               significant figures required  16.44
  558. C                                    decimal places required  17.40
  559. C
  560. C***REFERENCES  (NONE)
  561. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  562. C***REVISION HISTORY  (YYMMDD)
  563. C   770401  DATE WRITTEN
  564. C   890531  Changed all specific intrinsics to generic.  (WRB)
  565. C   890531  REVISION DATE from Version 3.2
  566. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  567. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  568. C   900326  Removed duplicate information from DESCRIPTION section.
  569. C           (WRB)
  570. C***END PROLOGUE  ALNREL
  571.       DIMENSION ALNRCS(23)
  572.       LOGICAL FIRST
  573.       SAVE ALNRCS, NLNREL, XMIN, FIRST
  574.       DATA ALNRCS( 1) /   1.0378693562 743770E0 /
  575.       DATA ALNRCS( 2) /   -.1336430150 4908918E0 /
  576.       DATA ALNRCS( 3) /    .0194082491 35520563E0 /
  577.       DATA ALNRCS( 4) /   -.0030107551 12753577E0 /
  578.       DATA ALNRCS( 5) /    .0004869461 47971548E0 /
  579.       DATA ALNRCS( 6) /   -.0000810548 81893175E0 /
  580.       DATA ALNRCS( 7) /    .0000137788 47799559E0 /
  581.       DATA ALNRCS( 8) /   -.0000023802 21089435E0 /
  582.       DATA ALNRCS( 9) /    .0000004164 04162138E0 /
  583.       DATA ALNRCS(10) /   -.0000000735 95828378E0 /
  584.       DATA ALNRCS(11) /    .0000000131 17611876E0 /
  585.       DATA ALNRCS(12) /   -.0000000023 54670931E0 /
  586.       DATA ALNRCS(13) /    .0000000004 25227732E0 /
  587.       DATA ALNRCS(14) /   -.0000000000 77190894E0 /
  588.       DATA ALNRCS(15) /    .0000000000 14075746E0 /
  589.       DATA ALNRCS(16) /   -.0000000000 02576907E0 /
  590.       DATA ALNRCS(17) /    .0000000000 00473424E0 /
  591.       DATA ALNRCS(18) /   -.0000000000 00087249E0 /
  592.       DATA ALNRCS(19) /    .0000000000 00016124E0 /
  593.       DATA ALNRCS(20) /   -.0000000000 00002987E0 /
  594.       DATA ALNRCS(21) /    .0000000000 00000554E0 /
  595.       DATA ALNRCS(22) /   -.0000000000 00000103E0 /
  596.       DATA ALNRCS(23) /    .0000000000 00000019E0 /
  597.       DATA FIRST /.TRUE./
  598. C***FIRST EXECUTABLE STATEMENT  ALNREL
  599.       IF (FIRST) THEN
  600.          NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3))
  601.          XMIN = -1.0 + SQRT(R1MACH(4))
  602.       ENDIF
  603.       FIRST = .FALSE.
  604. C
  605.       IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1',
  606.      +   2, 2)
  607.       IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL',
  608.      +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1)
  609. C
  610.       IF (ABS(X).LE.0.375) ALNREL = X*(1. -
  611.      1  X*CSEVL (X/.375, ALNRCS, NLNREL))
  612.       IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X)
  613. C
  614.       RETURN
  615.       END
  616. *DECK ASINH
  617.       FUNCTION ASINH (X)
  618. C***BEGIN PROLOGUE  ASINH
  619. C***PURPOSE  Compute the arc hyperbolic sine.
  620. C***LIBRARY   SLATEC (FNLIB)
  621. C***CATEGORY  C4C
  622. C***TYPE      SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C)
  623. C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
  624. C             INVERSE HYPERBOLIC SINE
  625. C***AUTHOR  Fullerton, W., (LANL)
  626. C***DESCRIPTION
  627. C
  628. C ASINH(X) computes the arc hyperbolic sine of X.
  629. C
  630. C Series for ASNH       on the interval  0.          to  1.00000D+00
  631. C                                        with weighted error   2.19E-17
  632. C                                         log weighted error  16.66
  633. C                               significant figures required  15.60
  634. C                                    decimal places required  17.31
  635. C
  636. C***REFERENCES  (NONE)
  637. C***ROUTINES CALLED  CSEVL, INITS, R1MACH
  638. C***REVISION HISTORY  (YYMMDD)
  639. C   770401  DATE WRITTEN
  640. C   890531  Changed all specific intrinsics to generic.  (WRB)
  641. C   890531  REVISION DATE from Version 3.2
  642. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  643. C***END PROLOGUE  ASINH
  644.       DIMENSION ASNHCS(20)
  645.       LOGICAL FIRST
  646.       SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST
  647.       DATA ALN2 /0.6931471805 5994530942E0/
  648.       DATA ASNHCS( 1) /   -.1282003991 1738186E0 /
  649.       DATA ASNHCS( 2) /   -.0588117611 89951768E0 /
  650.       DATA ASNHCS( 3) /    .0047274654 32212481E0 /
  651.       DATA ASNHCS( 4) /   -.0004938363 16265361E0 /
  652.       DATA ASNHCS( 5) /    .0000585062 07058557E0 /
  653.       DATA ASNHCS( 6) /   -.0000074669 98328931E0 /
  654.       DATA ASNHCS( 7) /    .0000010011 69358355E0 /
  655.       DATA ASNHCS( 8) /   -.0000001390 35438587E0 /
  656.       DATA ASNHCS( 9) /    .0000000198 23169483E0 /
  657.       DATA ASNHCS(10) /   -.0000000028 84746841E0 /
  658.       DATA ASNHCS(11) /    .0000000004 26729654E0 /
  659.       DATA ASNHCS(12) /   -.0000000000 63976084E0 /
  660.       DATA ASNHCS(13) /    .0000000000 09699168E0 /
  661.       DATA ASNHCS(14) /   -.0000000000 01484427E0 /
  662.       DATA ASNHCS(15) /    .0000000000 00229037E0 /
  663.       DATA ASNHCS(16) /   -.0000000000 00035588E0 /
  664.       DATA ASNHCS(17) /    .0000000000 00005563E0 /
  665.       DATA ASNHCS(18) /   -.0000000000 00000874E0 /
  666.       DATA ASNHCS(19) /    .0000000000 00000138E0 /
  667.       DATA ASNHCS(20) /   -.0000000000 00000021E0 /
  668.       DATA FIRST /.TRUE./
  669. C***FIRST EXECUTABLE STATEMENT  ASINH
  670.       IF (FIRST) THEN
  671.          NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3))
  672.          SQEPS = SQRT (R1MACH(3))
  673.          XMAX = 1.0/SQEPS
  674.       ENDIF
  675.       FIRST = .FALSE.
  676. C
  677.       Y = ABS(X)
  678.       IF (Y.GT.1.0) GO TO 20
  679. C
  680.       ASINH = X
  681.       IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS))
  682.       RETURN
  683. C
  684.  20   IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.))
  685.       IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y)
  686.       ASINH = SIGN (ASINH, X)
  687. C
  688.       RETURN
  689.       END
  690. *DECK ASYIK
  691.       SUBROUTINE ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y)
  692. C***BEGIN PROLOGUE  ASYIK
  693. C***SUBSIDIARY
  694. C***PURPOSE  Subsidiary to BESI and BESK
  695. C***LIBRARY   SLATEC
  696. C***TYPE      SINGLE PRECISION (ASYIK-S, DASYIK-D)
  697. C***AUTHOR  Amos, D. E., (SNLA)
  698. C***DESCRIPTION
  699. C
  700. C                    ASYIK computes Bessel functions I and K
  701. C                  for arguments X.GT.0.0 and orders FNU.GE.35
  702. C                  on FLGIK = 1 and FLGIK = -1 respectively.
  703. C
  704. C                                    INPUT
  705. C
  706. C      X    - argument, X.GT.0.0E0
  707. C      FNU  - order of first Bessel function
  708. C      KODE - a parameter to indicate the scaling option
  709. C             KODE=1 returns Y(I)=        I/SUB(FNU+I-1)/(X), I=1,IN
  710. C                    or      Y(I)=        K/SUB(FNU+I-1)/(X), I=1,IN
  711. C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
  712. C             KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN
  713. C                    or      Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN
  714. C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
  715. C     FLGIK - selection parameter for I or K function
  716. C             FLGIK =  1.0E0 gives the I function
  717. C             FLGIK = -1.0E0 gives the K function
  718. C        RA - SQRT(1.+Z*Z), Z=X/FNU
  719. C       ARG - argument of the leading exponential
  720. C        IN - number of functions desired, IN=1 or 2
  721. C
  722. C                                    OUTPUT
  723. C
  724. C         Y - a vector whose first in components contain the sequence
  725. C
  726. C     Abstract
  727. C         ASYIK implements the uniform asymptotic expansion of
  728. C         the I and K Bessel functions for FNU.GE.35 and real
  729. C         X.GT.0.0E0. The forms are identical except for a change
  730. C         in sign of some of the terms. This change in sign is
  731. C         accomplished by means of the flag FLGIK = 1 or -1.
  732. C
  733. C***SEE ALSO  BESI, BESK
  734. C***ROUTINES CALLED  R1MACH
  735. C***REVISION HISTORY  (YYMMDD)
  736. C   750101  DATE WRITTEN
  737. C   890531  Changed all specific intrinsics to generic.  (WRB)
  738. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  739. C   900328  Added TYPE section.  (WRB)
  740. C   910408  Updated the AUTHOR section.  (WRB)
  741. C***END PROLOGUE  ASYIK
  742. C
  743.       INTEGER IN, J, JN, K, KK, KODE, L
  744.       REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2,
  745.      1 T, TOL, T2, X, Y, Z
  746.       REAL R1MACH
  747.       DIMENSION Y(*), C(65), CON(2)
  748.       SAVE CON, C
  749.       DATA CON(1), CON(2)  /
  750.      1        3.98942280401432678E-01,    1.25331413731550025E+00/
  751.       DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
  752.      1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
  753.      2     C(19), C(20), C(21), C(22), C(23), C(24)/
  754.      3       -2.08333333333333E-01,        1.25000000000000E-01,
  755.      4        3.34201388888889E-01,       -4.01041666666667E-01,
  756.      5        7.03125000000000E-02,       -1.02581259645062E+00,
  757.      6        1.84646267361111E+00,       -8.91210937500000E-01,
  758.      7        7.32421875000000E-02,        4.66958442342625E+00,
  759.      8       -1.12070026162230E+01,        8.78912353515625E+00,
  760.      9       -2.36408691406250E+00,        1.12152099609375E-01,
  761.      1       -2.82120725582002E+01,        8.46362176746007E+01,
  762.      2       -9.18182415432400E+01,        4.25349987453885E+01,
  763.      3       -7.36879435947963E+00,        2.27108001708984E-01,
  764.      4        2.12570130039217E+02,       -7.65252468141182E+02,
  765.      5        1.05999045252800E+03,       -6.99579627376133E+02/
  766.       DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
  767.      1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
  768.      2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
  769.      3        2.18190511744212E+02,       -2.64914304869516E+01,
  770.      4        5.72501420974731E-01,       -1.91945766231841E+03,
  771.      5        8.06172218173731E+03,       -1.35865500064341E+04,
  772.      6        1.16553933368645E+04,       -5.30564697861340E+03,
  773.      7        1.20090291321635E+03,       -1.08090919788395E+02,
  774.      8        1.72772750258446E+00,        2.02042913309661E+04,
  775.      9       -9.69805983886375E+04,        1.92547001232532E+05,
  776.      1       -2.03400177280416E+05,        1.22200464983017E+05,
  777.      2       -4.11926549688976E+04,        7.10951430248936E+03,
  778.      3       -4.93915304773088E+02,        6.07404200127348E+00,
  779.      4       -2.42919187900551E+05,        1.31176361466298E+06,
  780.      5       -2.99801591853811E+06,        3.76327129765640E+06/
  781.       DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
  782.      1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
  783.      2     C(65)/
  784.      3       -2.81356322658653E+06,        1.26836527332162E+06,
  785.      4       -3.31645172484564E+05,        4.52187689813627E+04,
  786.      5       -2.49983048181121E+03,        2.43805296995561E+01,
  787.      6        3.28446985307204E+06,       -1.97068191184322E+07,
  788.      7        5.09526024926646E+07,       -7.41051482115327E+07,
  789.      8        6.63445122747290E+07,       -3.75671766607634E+07,
  790.      9        1.32887671664218E+07,       -2.78561812808645E+06,
  791.      1        3.08186404612662E+05,       -1.38860897537170E+04,
  792.      2        1.10017140269247E+02/
  793. C***FIRST EXECUTABLE STATEMENT  ASYIK
  794.       TOL = R1MACH(3)
  795.       TOL = MAX(TOL,1.0E-15)
  796.       FN = FNU
  797.       Z  = (3.0E0-FLGIK)/2.0E0
  798.       KK = INT(Z)
  799.       DO 50 JN=1,IN
  800.         IF (JN.EQ.1) GO TO 10
  801.         FN = FN - FLGIK
  802.         Z = X/FN
  803.         RA = SQRT(1.0E0+Z*Z)
  804.         GLN = LOG((1.0E0+RA)/Z)
  805.         ETX = KODE - 1
  806.         T = RA*(1.0E0-ETX) + ETX/(Z+RA)
  807.         ARG = FN*(T-GLN)*FLGIK
  808.    10   COEF = EXP(ARG)
  809.         T = 1.0E0/RA
  810.         T2 = T*T
  811.         T = T/FN
  812.         T = SIGN(T,FLGIK)
  813.         S2 = 1.0E0
  814.         AP = 1.0E0
  815.         L = 0
  816.         DO 30 K=2,11
  817.           L = L + 1
  818.           S1 = C(L)
  819.           DO 20 J=2,K
  820.             L = L + 1
  821.             S1 = S1*T2 + C(L)
  822.    20     CONTINUE
  823.           AP = AP*T
  824.           AK = AP*S1
  825.           S2 = S2 + AK
  826.           IF (MAX(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40
  827.    30   CONTINUE
  828.    40   CONTINUE
  829.       T = ABS(T)
  830.       Y(JN) = S2*COEF*SQRT(T)*CON(KK)
  831.    50 CONTINUE
  832.       RETURN
  833.       END
  834. *DECK ASYJY
  835.       SUBROUTINE ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW)
  836. C***BEGIN PROLOGUE  ASYJY
  837. C***SUBSIDIARY
  838. C***PURPOSE  Subsidiary to BESJ and BESY
  839. C***LIBRARY   SLATEC
  840. C***TYPE      SINGLE PRECISION (ASYJY-S, DASYJY-D)
  841. C***AUTHOR  Amos, D. E., (SNLA)
  842. C***DESCRIPTION
  843. C
  844. C                 ASYJY computes Bessel functions J and Y
  845. C               for arguments X.GT.0.0 and orders FNU.GE.35.0
  846. C               on FLGJY = 1 and FLGJY = -1 respectively
  847. C
  848. C                                  INPUT
  849. C
  850. C      FUNJY - external function JAIRY or YAIRY
  851. C          X - argument, X.GT.0.0E0
  852. C        FNU - order of the first Bessel function
  853. C      FLGJY - selection flag
  854. C              FLGJY =  1.0E0 gives the J function
  855. C              FLGJY = -1.0E0 gives the Y function
  856. C         IN - number of functions desired, IN = 1 or 2
  857. C
  858. C                                  OUTPUT
  859. C
  860. C         Y  - a vector whose first in components contain the sequence
  861. C       IFLW - a flag indicating underflow or overflow
  862. C                    return variables for BESJ only
  863. C      WK(1) = 1 - (X/FNU)**2 = W**2
  864. C      WK(2) = SQRT(ABS(WK(1)))
  865. C      WK(3) = ABS(WK(2) - ATAN(WK(2)))  or
  866. C              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
  867. C            = ABS((2/3)*ZETA**(3/2))
  868. C      WK(4) = FNU*WK(3)
  869. C      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
  870. C      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
  871. C      WK(7) = FNU**(1/3)
  872. C
  873. C     Abstract
  874. C         ASYJY implements the uniform asymptotic expansion of
  875. C         the J and Y Bessel functions for FNU.GE.35 and real
  876. C         X.GT.0.0E0. The forms are identical except for a change
  877. C         in sign of some of the terms. This change in sign is
  878. C         accomplished by means of the flag FLGJY = 1 or -1. On
  879. C         FLGJY = 1 the AIRY functions AI(X) and DAI(X) are
  880. C         supplied by the external function JAIRY, and on
  881. C         FLGJY = -1 the AIRY functions BI(X) and DBI(X) are
  882. C         supplied by the external function YAIRY.
  883. C
  884. C***SEE ALSO  BESJ, BESY
  885. C***ROUTINES CALLED  I1MACH, R1MACH
  886. C***REVISION HISTORY  (YYMMDD)
  887. C   750101  DATE WRITTEN
  888. C   890531  Changed all specific intrinsics to generic.  (WRB)
  889. C   891009  Removed unreferenced variable.  (WRB)
  890. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  891. C   900328  Added TYPE section.  (WRB)
  892. C   910408  Updated the AUTHOR section.  (WRB)
  893. C***END PROLOGUE  ASYJY
  894.       INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1,
  895.      * KSTEMP, L, LR, LRP1, ISETA, ISETB
  896.       INTEGER I1MACH
  897.       REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ,
  898.      * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2,
  899.      * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU,
  900.      * FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN,
  901.      * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL,
  902.      *  WK, X, XX, Y, Z, Z32
  903.       REAL R1MACH
  904.       DIMENSION Y(*), WK(*), C(65)
  905.       DIMENSION ALFA(26,4), BETA(26,5)
  906.       DIMENSION ALFA1(26,2), ALFA2(26,2)
  907.       DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
  908.       DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
  909.       DIMENSION CR(10), DR(10)
  910.       EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
  911.       EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
  912.       EQUIVALENCE (BETA(1,1),BETA1(1,1))
  913.       EQUIVALENCE (BETA(1,3),BETA2(1,1))
  914.       EQUIVALENCE (BETA(1,5),BETA3(1,1))
  915.       SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2,
  916.      1 BETA1, BETA2, BETA3, GAMA
  917.       DATA TOLS            /-6.90775527898214E+00/
  918.       DATA CON1,CON2,CON548/
  919.      1 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/
  920.       DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7),
  921.      A      AR(8)          / 8.35503472222222E-02, 1.28226574556327E-01,
  922.      1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00,
  923.      2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/
  924.       DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
  925.      A      BR(9), BR(10)  /-1.45833333333333E-01,-9.87413194444444E-02,
  926.      1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01,
  927.      2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01,
  928.      3-4.92355370523671E+02,-3.31621856854797E+03/
  929.       DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
  930.      1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
  931.      2     C(19), C(20), C(21), C(22), C(23), C(24)/
  932.      3       -2.08333333333333E-01,        1.25000000000000E-01,
  933.      4        3.34201388888889E-01,       -4.01041666666667E-01,
  934.      5        7.03125000000000E-02,       -1.02581259645062E+00,
  935.      6        1.84646267361111E+00,       -8.91210937500000E-01,
  936.      7        7.32421875000000E-02,        4.66958442342625E+00,
  937.      8       -1.12070026162230E+01,        8.78912353515625E+00,
  938.      9       -2.36408691406250E+00,        1.12152099609375E-01,
  939.      A       -2.82120725582002E+01,        8.46362176746007E+01,
  940.      B       -9.18182415432400E+01,        4.25349987453885E+01,
  941.      C       -7.36879435947963E+00,        2.27108001708984E-01,
  942.      D        2.12570130039217E+02,       -7.65252468141182E+02,
  943.      E        1.05999045252800E+03,       -6.99579627376133E+02/
  944.       DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
  945.      1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
  946.      2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
  947.      3        2.18190511744212E+02,       -2.64914304869516E+01,
  948.      4        5.72501420974731E-01,       -1.91945766231841E+03,
  949.      5        8.06172218173731E+03,       -1.35865500064341E+04,
  950.      6        1.16553933368645E+04,       -5.30564697861340E+03,
  951.      7        1.20090291321635E+03,       -1.08090919788395E+02,
  952.      8        1.72772750258446E+00,        2.02042913309661E+04,
  953.      9       -9.69805983886375E+04,        1.92547001232532E+05,
  954.      A       -2.03400177280416E+05,        1.22200464983017E+05,
  955.      B       -4.11926549688976E+04,        7.10951430248936E+03,
  956.      C       -4.93915304773088E+02,        6.07404200127348E+00,
  957.      D       -2.42919187900551E+05,        1.31176361466298E+06,
  958.      E       -2.99801591853811E+06,        3.76327129765640E+06/
  959.       DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
  960.      1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
  961.      2     C(65)/
  962.      3       -2.81356322658653E+06,        1.26836527332162E+06,
  963.      4       -3.31645172484564E+05,        4.52187689813627E+04,
  964.      5       -2.49983048181121E+03,        2.43805296995561E+01,
  965.      6        3.28446985307204E+06,       -1.97068191184322E+07,
  966.      7        5.09526024926646E+07,       -7.41051482115327E+07,
  967.      8        6.63445122747290E+07,       -3.75671766607634E+07,
  968.      9        1.32887671664218E+07,       -2.78561812808645E+06,
  969.      A        3.08186404612662E+05,       -1.38860897537170E+04,
  970.      B        1.10017140269247E+02/
  971.       DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1),
  972.      1     ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1),
  973.      2     ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1),
  974.      3     ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1),
  975.      4     ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1),
  976.      5     ALFA1(26,1)     /-4.44444444444444E-03,-9.22077922077922E-04,
  977.      6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04,
  978.      7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04,
  979.      8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04,
  980.      9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04,
  981.      1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04,
  982.      2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04,
  983.      3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05,
  984.      4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/
  985.       DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2),
  986.      1     ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2),
  987.      2     ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2),
  988.      3     ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2),
  989.      4     ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2),
  990.      5     ALFA1(26,2)     / 6.93735541354589E-04, 2.32241745182922E-04,
  991.      6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04,
  992.      7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04,
  993.      8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05,
  994.      9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05,
  995.      1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05,
  996.      2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05,
  997.      3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05,
  998.      4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/
  999.       DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1),
  1000.      1     ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1),
  1001.      2     ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1),
  1002.      3     ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1),
  1003.      4     ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1),
  1004.      5     ALFA2(26,1)     /-3.54211971457744E-04,-1.56161263945159E-04,
  1005.      6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04,
  1006.      7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04,
  1007.      8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05,
  1008.      9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05,
  1009.      1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05,
  1010.      2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07,
  1011.      3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06,
  1012.      4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/
  1013.       DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2),
  1014.      1     ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2),
  1015.      2     ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2),
  1016.      3     ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2),
  1017.      4     ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2),
  1018.      5     ALFA2(26,2)     / 3.78194199201773E-04, 2.02471952761816E-04,
  1019.      6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04,
  1020.      7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04,
  1021.      8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05,
  1022.      9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06,
  1023.      1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05,
  1024.      2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05,
  1025.      3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05,
  1026.      4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/
  1027.       DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1),
  1028.      1     BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1),
  1029.      2     BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1),
  1030.      3     BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1),
  1031.      4     BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1),
  1032.      5     BETA1(26,1)     / 1.79988721413553E-02, 5.59964911064388E-03,
  1033.      6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03,
  1034.      7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04,
  1035.      8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04,
  1036.      9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04,
  1037.      1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04,
  1038.      2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04,
  1039.      3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05,
  1040.      4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/
  1041.       DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2),
  1042.      1     BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2),
  1043.      2     BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2),
  1044.      3     BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2),
  1045.      4     BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2),
  1046.      5     BETA1(26,2)     /-1.49282953213429E-03,-8.78204709546389E-04,
  1047.      6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04,
  1048.      7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05,
  1049.      8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06,
  1050.      9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05,
  1051.      1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05,
  1052.      2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05,
  1053.      3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05,
  1054.      4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/
  1055.       DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1),
  1056.      1     BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1),
  1057.      2     BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1),
  1058.      3     BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1),
  1059.      4     BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1),
  1060.      5     BETA2(26,1)     / 5.52213076721293E-04, 4.47932581552385E-04,
  1061.      6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05,
  1062.      7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05,
  1063.      8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05,
  1064.      9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05,
  1065.      1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05,
  1066.      2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05,
  1067.      3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05,
  1068.      4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/
  1069.       DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2),
  1070.      1     BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2),
  1071.      2     BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2),
  1072.      3     BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2),
  1073.      4     BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2),
  1074.      5     BETA2(26,2)     /-4.74617796559960E-04,-4.77864567147321E-04,
  1075.      6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05,
  1076.      7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04,
  1077.      8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04,
  1078.      9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05,
  1079.      1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05,
  1080.      2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05,
  1081.      3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05,
  1082.      4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/
  1083.       DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1),
  1084.      1     BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1),
  1085.      2     BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1),
  1086.      3     BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1),
  1087.      4     BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1),
  1088.      5     BETA3(26,1)     / 7.36465810572578E-04, 8.72790805146194E-04,
  1089.      6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06,
  1090.      7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04,
  1091.      8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04,
  1092.      9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04,
  1093.      1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05,
  1094.      2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05,
  1095.      3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06,
  1096.      4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/
  1097.       DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5),
  1098.      1     GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10),
  1099.      2     GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15),
  1100.      3     GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20),
  1101.      4     GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25),
  1102.      5     GAMA(26)        / 6.29960524947437E-01, 2.51984209978975E-01,
  1103.      6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02,
  1104.      7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02,
  1105.      8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02,
  1106.      9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02,
  1107.      1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02,
  1108.      2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02,
  1109.      3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02,
  1110.      4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/
  1111. C***FIRST EXECUTABLE STATEMENT  ASYJY
  1112.       TA = R1MACH(3)
  1113.       TOL = MAX(TA,1.0E-15)
  1114.       TB = R1MACH(5)
  1115.       JU = I1MACH(12)
  1116.       IF(FLGJY.EQ.1.0E0) GO TO 6
  1117.       JR = I1MACH(11)
  1118.       ELIM = -2.303E0*TB*(JU+JR)
  1119.       GO TO 7
  1120.     6 CONTINUE
  1121.       ELIM = -2.303E0*(TB*JU+3.0E0)
  1122.     7 CONTINUE
  1123.       FN = FNU
  1124.       IFLW = 0
  1125.       DO 170 JN=1,IN
  1126.         XX = X/FN
  1127.         WK(1) = 1.0E0 - XX*XX
  1128.         ABW2 = ABS(WK(1))
  1129.         WK(2) = SQRT(ABW2)
  1130.         WK(7) = FN**CON2
  1131.         IF (ABW2.GT.0.27750E0) GO TO 80
  1132. C
  1133. C     ASYMPTOTIC EXPANSION
  1134. C     CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775
  1135. C     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
  1136. C
  1137. C     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
  1138. C
  1139. C     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
  1140. C
  1141.         SA = 0.0E0
  1142.         IF (ABW2.EQ.0.0E0) GO TO 10
  1143.         SA = TOLS/LOG(ABW2)
  1144.    10   SB = SA
  1145.         DO 20 I=1,5
  1146.           AKM = MAX(SA,2.0E0)
  1147.           KMAX(I) = INT(AKM)
  1148.           SA = SA + SB
  1149.    20   CONTINUE
  1150.         KB = KMAX(5)
  1151.         KLAST = KB - 1
  1152.         SA = GAMA(KB)
  1153.         DO 30 K=1,KLAST
  1154.           KB = KB - 1
  1155.           SA = SA*WK(1) + GAMA(KB)
  1156.    30   CONTINUE
  1157.         Z = WK(1)*SA
  1158.         AZ = ABS(Z)
  1159.         RTZ = SQRT(AZ)
  1160.         WK(3) = CON1*AZ*RTZ
  1161.         WK(4) = WK(3)*FN
  1162.         WK(5) = RTZ*WK(7)
  1163.         WK(6) = -WK(5)*WK(5)
  1164.         IF(Z.LE.0.0E0) GO TO 35
  1165.         IF(WK(4).GT.ELIM) GO TO 75
  1166.         WK(6) = -WK(6)
  1167.    35   CONTINUE
  1168.         PHI = SQRT(SQRT(SA+SA+SA+SA))
  1169. C
  1170. C     B(ZETA) FOR S=0
  1171. C
  1172.         KB = KMAX(5)
  1173.         KLAST = KB - 1
  1174.         SB = BETA(KB,1)
  1175.         DO 40 K=1,KLAST
  1176.           KB = KB - 1
  1177.           SB = SB*WK(1) + BETA(KB,1)
  1178.    40   CONTINUE
  1179.         KSP1 = 1
  1180.         FN2 = FN*FN
  1181.         RFN2 = 1.0E0/FN2
  1182.         RDEN = 1.0E0
  1183.         ASUM = 1.0E0
  1184.         RELB = TOL*ABS(SB)
  1185.         BSUM = SB
  1186.         DO 60 KS=1,4
  1187.           KSP1 = KSP1 + 1
  1188.           RDEN = RDEN*RFN2
  1189. C
  1190. C     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
  1191. C
  1192.           KSTEMP = 5 - KS
  1193.           KB = KMAX(KSTEMP)
  1194.           KLAST = KB - 1
  1195.           SA = ALFA(KB,KS)
  1196.           SB = BETA(KB,KSP1)
  1197.           DO 50 K=1,KLAST
  1198.             KB = KB - 1
  1199.             SA = SA*WK(1) + ALFA(KB,KS)
  1200.             SB = SB*WK(1) + BETA(KB,KSP1)
  1201.    50     CONTINUE
  1202.           TA = SA*RDEN
  1203.           TB = SB*RDEN
  1204.           ASUM = ASUM + TA
  1205.           BSUM = BSUM + TB
  1206.           IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70
  1207.    60   CONTINUE
  1208.    70   CONTINUE
  1209.         BSUM = BSUM/(FN*WK(7))
  1210.         GO TO 160
  1211. C
  1212.    75   CONTINUE
  1213.         IFLW = 1
  1214.         RETURN
  1215. C
  1216.    80   CONTINUE
  1217.         UPOL(1) = 1.0E0
  1218.         TAU = 1.0E0/WK(2)
  1219.         T2 = 1.0E0/WK(1)
  1220.         IF (WK(1).GE.0.0E0) GO TO 90
  1221. C
  1222. C     CASES FOR (X/FN).GT.SQRT(1.2775)
  1223. C
  1224.         WK(3) = ABS(WK(2)-ATAN(WK(2)))
  1225.         WK(4) = WK(3)*FN
  1226.         RCZ = -CON1/WK(4)
  1227.         Z32 = 1.5E0*WK(3)
  1228.         RTZ = Z32**CON2
  1229.         WK(5) = RTZ*WK(7)
  1230.         WK(6) = -WK(5)*WK(5)
  1231.         GO TO 100
  1232.    90   CONTINUE
  1233. C
  1234. C     CASES FOR (X/FN).LT.SQRT(0.7225)
  1235. C
  1236.         WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2))
  1237.         WK(4) = WK(3)*FN
  1238.         RCZ = CON1/WK(4)
  1239.         IF(WK(4).GT.ELIM) GO TO 75
  1240.         Z32 = 1.5E0*WK(3)
  1241.         RTZ = Z32**CON2
  1242.         WK(7) = FN**CON2
  1243.         WK(5) = RTZ*WK(7)
  1244.         WK(6) = WK(5)*WK(5)
  1245.   100   CONTINUE
  1246.         PHI = SQRT((RTZ+RTZ)*TAU)
  1247.         TB = 1.0E0
  1248.         ASUM = 1.0E0
  1249.         TFN = TAU/FN
  1250.         RDEN=1.0E0/FN
  1251.         RFN2=RDEN*RDEN
  1252.         RDEN=1.0E0
  1253.         UPOL(2) = (C(1)*T2+C(2))*TFN
  1254.         CRZ32 = CON548*RCZ
  1255.         BSUM = UPOL(2) + CRZ32
  1256.         RELB = TOL*ABS(BSUM)
  1257.         AP = TFN
  1258.         KS = 0
  1259.         KP1 = 2
  1260.         RZDEN = RCZ
  1261.         L = 2
  1262.         ISETA=0
  1263.         ISETB=0
  1264.         DO 140 LR=2,8,2
  1265. C
  1266. C     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
  1267. C
  1268.           LRP1 = LR + 1
  1269.           DO 120 K=LR,LRP1
  1270.             KS = KS + 1
  1271.             KP1 = KP1 + 1
  1272.             L = L + 1
  1273.             S1 = C(L)
  1274.             DO 110 J=2,KP1
  1275.               L = L + 1
  1276.               S1 = S1*T2 + C(L)
  1277.   110       CONTINUE
  1278.             AP = AP*TFN
  1279.             UPOL(KP1) = AP*S1
  1280.             CR(KS) = BR(KS)*RZDEN
  1281.             RZDEN = RZDEN*RCZ
  1282.             DR(KS) = AR(KS)*RZDEN
  1283.   120     CONTINUE
  1284.           SUMA = UPOL(LRP1)
  1285.           SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
  1286.           JU = LRP1
  1287.           DO 130 JR=1,LR
  1288.             JU = JU - 1
  1289.             SUMA = SUMA + CR(JR)*UPOL(JU)
  1290.             SUMB = SUMB + DR(JR)*UPOL(JU)
  1291.   130     CONTINUE
  1292.           RDEN=RDEN*RFN2
  1293.           TB = -TB
  1294.           IF (WK(1).GT.0.0E0) TB = ABS(TB)
  1295.           IF (RDEN.LT.TOL) GO TO 131
  1296.           ASUM = ASUM + SUMA*TB
  1297.           BSUM = BSUM + SUMB*TB
  1298.           GO TO 140
  1299.   131     IF(ISETA.EQ.1) GO TO 132
  1300.           IF(ABS(SUMA).LT.TOL) ISETA=1
  1301.           ASUM=ASUM+SUMA*TB
  1302.   132     IF(ISETB.EQ.1) GO TO 133
  1303.           IF(ABS(SUMB).LT.RELB) ISETB=1
  1304.           BSUM=BSUM+SUMB*TB
  1305.   133     IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150
  1306.   140   CONTINUE
  1307.   150   TB = WK(5)
  1308.         IF (WK(1).GT.0.0E0) TB = -TB
  1309.         BSUM = BSUM/TB
  1310. C
  1311.   160   CONTINUE
  1312.         CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI)
  1313.         TA=1.0E0/TOL
  1314.         TB=R1MACH(1)*TA*1.0E+3
  1315.         IF(ABS(FI).GT.TB) GO TO 165
  1316.         FI=FI*TA
  1317.         DFI=DFI*TA
  1318.         PHI=PHI*TOL
  1319.   165   CONTINUE
  1320.         Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
  1321.         FN = FN - FLGJY
  1322.   170 CONTINUE
  1323.       RETURN
  1324.       END
  1325. *DECK ATANH
  1326.       FUNCTION ATANH (X)
  1327. C***BEGIN PROLOGUE  ATANH
  1328. C***PURPOSE  Compute the arc hyperbolic tangent.
  1329. C***LIBRARY   SLATEC (FNLIB)
  1330. C***CATEGORY  C4C
  1331. C***TYPE      SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C)
  1332. C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
  1333. C             FNLIB, INVERSE HYPERBOLIC TANGENT
  1334. C***AUTHOR  Fullerton, W., (LANL)
  1335. C***DESCRIPTION
  1336. C
  1337. C ATANH(X) computes the arc hyperbolic tangent of X.
  1338. C
  1339. C Series for ATNH       on the interval  0.          to  2.50000D-01
  1340. C                                        with weighted error   6.70E-18
  1341. C                                         log weighted error  17.17
  1342. C                               significant figures required  16.01
  1343. C                                    decimal places required  17.76
  1344. C
  1345. C***REFERENCES  (NONE)
  1346. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  1347. C***REVISION HISTORY  (YYMMDD)
  1348. C   770401  DATE WRITTEN
  1349. C   890531  Changed all specific intrinsics to generic.  (WRB)
  1350. C   890531  REVISION DATE from Version 3.2
  1351. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  1352. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  1353. C   900326  Removed duplicate information from DESCRIPTION section.
  1354. C           (WRB)
  1355. C***END PROLOGUE  ATANH
  1356.       DIMENSION ATNHCS(15)
  1357.       LOGICAL FIRST
  1358.       SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST
  1359.       DATA ATNHCS( 1) /    .0943951023 93195492E0 /
  1360.       DATA ATNHCS( 2) /    .0491984370 55786159E0 /
  1361.       DATA ATNHCS( 3) /    .0021025935 22455432E0 /
  1362.       DATA ATNHCS( 4) /    .0001073554 44977611E0 /
  1363.       DATA ATNHCS( 5) /    .0000059782 67249293E0 /
  1364.       DATA ATNHCS( 6) /    .0000003505 06203088E0 /
  1365.       DATA ATNHCS( 7) /    .0000000212 63743437E0 /
  1366.       DATA ATNHCS( 8) /    .0000000013 21694535E0 /
  1367.       DATA ATNHCS( 9) /    .0000000000 83658755E0 /
  1368.       DATA ATNHCS(10) /    .0000000000 05370503E0 /
  1369.       DATA ATNHCS(11) /    .0000000000 00348665E0 /
  1370.       DATA ATNHCS(12) /    .0000000000 00022845E0 /
  1371.       DATA ATNHCS(13) /    .0000000000 00001508E0 /
  1372.       DATA ATNHCS(14) /    .0000000000 00000100E0 /
  1373.       DATA ATNHCS(15) /    .0000000000 00000006E0 /
  1374.       DATA FIRST /.TRUE./
  1375. C***FIRST EXECUTABLE STATEMENT  ATANH
  1376.       IF (FIRST) THEN
  1377.          NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3))
  1378.          DXREL = SQRT (R1MACH(4))
  1379.          SQEPS = SQRT (3.0*R1MACH(3))
  1380.       ENDIF
  1381.       FIRST = .FALSE.
  1382. C
  1383.       Y = ABS(X)
  1384.       IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2,
  1385.      +   2)
  1386. C
  1387.       IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH',
  1388.      +   'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1)
  1389. C
  1390.       ATANH = X
  1391.       IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1.,
  1392.      1  ATNHCS, NTERMS))
  1393.       IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X))
  1394. C
  1395.       RETURN
  1396.       END
  1397. *DECK AVINT
  1398.       SUBROUTINE AVINT (X, Y, N, XLO, XUP, ANS, IERR)
  1399. C***BEGIN PROLOGUE  AVINT
  1400. C***PURPOSE  Integrate a function tabulated at arbitrarily spaced
  1401. C            abscissas using overlapping parabolas.
  1402. C***LIBRARY   SLATEC
  1403. C***CATEGORY  H2A1B2
  1404. C***TYPE      SINGLE PRECISION (AVINT-S, DAVINT-D)
  1405. C***KEYWORDS  INTEGRATION, QUADRATURE, TABULATED DATA
  1406. C***AUTHOR  Jones, R. E., (SNLA)
  1407. C***DESCRIPTION
  1408. C
  1409. C     Abstract
  1410. C         AVINT integrates a function tabulated at arbitrarily spaced
  1411. C         abscissas.  The limits of integration need not coincide
  1412. C         with the tabulated abscissas.
  1413. C
  1414. C         A method of overlapping parabolas fitted to the data is used
  1415. C         provided that there are at least 3 abscissas between the
  1416. C         limits of integration.  AVINT also handles two special cases.
  1417. C         If the limits of integration are equal, AVINT returns a result
  1418. C         of zero regardless of the number of tabulated values.
  1419. C         If there are only two function values, AVINT uses the
  1420. C         trapezoid rule.
  1421. C
  1422. C     Description of Parameters
  1423. C         The user must dimension all arrays appearing in the call list
  1424. C              X(N), Y(N).
  1425. C
  1426. C         Input--
  1427. C         X    - real array of abscissas, which must be in increasing
  1428. C                order.
  1429. C         Y    - real array of functional values. i.e., Y(I)=FUNC(X(I)).
  1430. C         N    - the integer number of function values supplied.
  1431. C                N .GE. 2 unless XLO = XUP.
  1432. C         XLO  - real lower limit of integration.
  1433. C         XUP  - real upper limit of integration.
  1434. C                Must have XLO .LE. XUP.
  1435. C
  1436. C         Output--
  1437. C         ANS  - computed approximate value of integral
  1438. C         IERR - a status code
  1439. C              --normal code
  1440. C                =1 means the requested integration was performed.
  1441. C              --abnormal codes
  1442. C                =2 means XUP was less than XLO.
  1443. C                =3 means the number of X(I) between XLO and XUP
  1444. C                   (inclusive) was less than 3 and neither of the two
  1445. C                   special cases described in the Abstract occurred.
  1446. C                   No integration was performed.
  1447. C                =4 means the restriction X(I+1) .GT. X(I) was violated.
  1448. C                =5 means the number N of function values was .LT. 2.
  1449. C                ANS is set to zero if IERR=2,3,4,or 5.
  1450. C
  1451. C     AVINT is documented completely in SC-M-69-335
  1452. C     Original program from "Numerical Integration" by Davis &
  1453. C     Rabinowitz.
  1454. C     Adaptation and modifications for Sandia Mathematical Program
  1455. C     Library by Rondall E. Jones.
  1456. C
  1457. C***REFERENCES  R. E. Jones, Approximate integrator of functions
  1458. C                 tabulated at arbitrarily spaced abscissas,
  1459. C                 Report SC-M-69-335, Sandia Laboratories, 1969.
  1460. C***ROUTINES CALLED  XERMSG
  1461. C***REVISION HISTORY  (YYMMDD)
  1462. C   690901  DATE WRITTEN
  1463. C   890831  Modified array declarations.  (WRB)
  1464. C   890831  REVISION DATE from Version 3.2
  1465. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  1466. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  1467. C   900326  Removed duplicate information from DESCRIPTION section.
  1468. C           (WRB)
  1469. C   920501  Reformatted the REFERENCES section.  (WRB)
  1470. C***END PROLOGUE  AVINT
  1471. C
  1472.       DOUBLE PRECISION R3,RP5,SUM,SYL,SYL2,SYL3,SYU,SYU2,SYU3,X1,X2,X3
  1473.      1,X12,X13,X23,TERM1,TERM2,TERM3,A,B,C,CA,CB,CC
  1474.       DIMENSION X(*),Y(*)
  1475. C***FIRST EXECUTABLE STATEMENT  AVINT
  1476.       IERR=1
  1477.       ANS =0.0
  1478.       IF (XLO-XUP) 3,100,200
  1479.     3 IF (N.LT.2) GO TO 215
  1480.       DO 5 I=2,N
  1481.       IF (X(I).LE.X(I-1)) GO TO 210
  1482.       IF (X(I).GT.XUP) GO TO 6
  1483.     5 CONTINUE
  1484.     6 CONTINUE
  1485.       IF (N.GE.3) GO TO 9
  1486. C
  1487. C     SPECIAL N=2 CASE
  1488.       SLOPE = (Y(2)-Y(1))/(X(2)-X(1))
  1489.       FL = Y(1) + SLOPE*(XLO-X(1))
  1490.       FR = Y(2) + SLOPE*(XUP-X(2))
  1491.       ANS = 0.5*(FL+FR)*(XUP-XLO)
  1492.       RETURN
  1493.     9 CONTINUE
  1494.       IF (X(N-2).LT.XLO)  GO TO 205
  1495.       IF (X(3).GT.XUP)    GO TO 205
  1496.       I = 1
  1497.    10 IF (X(I).GE.XLO) GO TO 15
  1498.       I = I+1
  1499.       GO TO 10
  1500.    15 INLFT = I
  1501.       I = N
  1502.    20 IF (X(I).LE.XUP) GO TO 25
  1503.       I = I-1
  1504.       GO TO 20
  1505.    25 INRT = I
  1506.       IF ((INRT-INLFT).LT.2) GO TO 205
  1507.       ISTART = INLFT
  1508.       IF (INLFT.EQ.1) ISTART = 2
  1509.       ISTOP  = INRT
  1510.       IF (INRT.EQ.N)  ISTOP  = N-1
  1511. C
  1512.       R3 = 3.0D0
  1513.       RP5= 0.5D0
  1514.       SUM = 0.0
  1515.       SYL = XLO
  1516.       SYL2= SYL*SYL
  1517.       SYL3= SYL2*SYL
  1518. C
  1519.       DO 50 I=ISTART,ISTOP
  1520.       X1 = X(I-1)
  1521.       X2 = X(I)
  1522.       X3 = X(I+1)
  1523.       X12 = X1-X2
  1524.       X13 = X1-X3
  1525.       X23 = X2-X3
  1526.       TERM1 = DBLE(Y(I-1))/(X12*X13)
  1527.       TERM2 =-DBLE(Y(I)) /(X12*X23)
  1528.       TERM3 = DBLE(Y(I+1))/(X13*X23)
  1529.       A = TERM1+TERM2+TERM3
  1530.       B = -(X2+X3)*TERM1 - (X1+X3)*TERM2 - (X1+X2)*TERM3
  1531.       C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3
  1532.       IF (I-ISTART) 30,30,35
  1533.    30 CA = A
  1534.       CB = B
  1535.       CC = C
  1536.       GO TO 40
  1537.    35 CA = 0.5*(A+CA)
  1538.       CB = 0.5*(B+CB)
  1539.       CC = 0.5*(C+CC)
  1540.    40 SYU = X2
  1541.       SYU2= SYU*SYU
  1542.       SYU3= SYU2*SYU
  1543.       SUM = SUM + CA*(SYU3-SYL3)/R3  + CB*RP5*(SYU2-SYL2) + CC*(SYU-SYL)
  1544.       CA  = A
  1545.       CB  = B
  1546.       CC  = C
  1547.       SYL = SYU
  1548.       SYL2= SYU2
  1549.       SYL3= SYU3
  1550.    50 CONTINUE
  1551.       SYU = XUP
  1552.       ANS = SUM + CA*(SYU**3-SYL3)/R3 + CB*RP5*(SYU**2-SYL2)
  1553.      1  + CC*(SYU-SYL)
  1554.   100 RETURN
  1555.   200 IERR=2
  1556.       CALL XERMSG ('SLATEC', 'AVINT',
  1557.      +   'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER THAN THE ' //
  1558.      +   'LOWER LIMIT.', 4, 1)
  1559.       RETURN
  1560.   205 IERR=3
  1561.       CALL XERMSG ('SLATEC', 'AVINT',
  1562.      +   'THERE WERE LESS THAN THREE FUNCTION VALUES BETWEEN THE ' //
  1563.      +   'LIMITS OF INTEGRATION.', 4, 1)
  1564.       RETURN
  1565.   210 IERR=4
  1566.       CALL XERMSG ('SLATEC', 'AVINT',
  1567.      +   'THE ABSCISSAS WERE NOT STRICTLY INCREASING.  MUST HAVE ' //
  1568.      +   'X(I-1) .LT. X(I) FOR ALL I.', 4, 1)
  1569.       RETURN
  1570.   215 IERR=5
  1571.       CALL XERMSG ('SLATEC', 'AVINT',
  1572.      +   'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', 4, 1)
  1573.       RETURN
  1574.       END
  1575. *DECK BAKVEC
  1576.       SUBROUTINE BAKVEC (NM, N, T, E, M, Z, IERR)
  1577. C***BEGIN PROLOGUE  BAKVEC
  1578. C***PURPOSE  Form the eigenvectors of a certain real non-symmetric
  1579. C            tridiagonal matrix from a symmetric tridiagonal matrix
  1580. C            output from FIGI.
  1581. C***LIBRARY   SLATEC (EISPACK)
  1582. C***CATEGORY  D4C4
  1583. C***TYPE      SINGLE PRECISION (BAKVEC-S)
  1584. C***KEYWORDS  EIGENVECTORS, EISPACK
  1585. C***AUTHOR  Smith, B. T., et al.
  1586. C***DESCRIPTION
  1587. C
  1588. C     This subroutine forms the eigenvectors of a NONSYMMETRIC
  1589. C     TRIDIAGONAL matrix by back transforming those of the
  1590. C     corresponding symmetric matrix determined by  FIGI.
  1591. C
  1592. C     On INPUT
  1593. C
  1594. C        NM must be set to the row dimension of the two-dimensional
  1595. C          array parameters, T and Z, as declared in the calling
  1596. C          program dimension statement.  NM is an INTEGER variable.
  1597. C
  1598. C        N is the order of the matrix T.  N is an INTEGER variable.
  1599. C          N must be less than or equal to NM.
  1600. C
  1601. C        T contains the nonsymmetric matrix.  Its subdiagonal is
  1602. C          stored in the last N-1 positions of the first column,
  1603. C          its diagonal in the N positions of the second column,
  1604. C          and its superdiagonal in the first N-1 positions of
  1605. C          the third column.  T(1,1) and T(N,3) are arbitrary.
  1606. C          T is a two-dimensional REAL array, dimensioned T(NM,3).
  1607. C
  1608. C        E contains the subdiagonal elements of the symmetric
  1609. C          matrix in its last N-1 positions.  E(1) is arbitrary.
  1610. C          E is a one-dimensional REAL array, dimensioned E(N).
  1611. C
  1612. C        M is the number of eigenvectors to be back transformed.
  1613. C          M is an INTEGER variable.
  1614. C
  1615. C        Z contains the eigenvectors to be back transformed
  1616. C          in its first M columns.  Z is a two-dimensional REAL
  1617. C          array, dimensioned Z(NM,M).
  1618. C
  1619. C     On OUTPUT
  1620. C
  1621. C        T is unaltered.
  1622. C
  1623. C        E is destroyed.
  1624. C
  1625. C        Z contains the transformed eigenvectors in its first M columns.
  1626. C
  1627. C        IERR is an INTEGER flag set to
  1628. C          Zero       for normal return,
  1629. C          2*N+I      if E(I) is zero with T(I,1) or T(I-1,3) non-zero.
  1630. C                     In this case, the symmetric matrix is not similar
  1631. C                     to the original matrix, and the eigenvectors
  1632. C                     cannot be found by this program.
  1633. C
  1634. C     Questions and comments should be directed to B. S. Garbow,
  1635. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  1636. C     ------------------------------------------------------------------
  1637. C
  1638. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  1639. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  1640. C                 system Routines - EISPACK Guide, Springer-Verlag,
  1641. C                 1976.
  1642. C***ROUTINES CALLED  (NONE)
  1643. C***REVISION HISTORY  (YYMMDD)
  1644. C   760101  DATE WRITTEN
  1645. C   890831  Modified array declarations.  (WRB)
  1646. C   890831  REVISION DATE from Version 3.2
  1647. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  1648. C   920501  Reformatted the REFERENCES section.  (WRB)
  1649. C***END PROLOGUE  BAKVEC
  1650. C
  1651.       INTEGER I,J,M,N,NM,IERR
  1652.       REAL T(NM,3),E(*),Z(NM,*)
  1653. C
  1654. C***FIRST EXECUTABLE STATEMENT  BAKVEC
  1655.       IERR = 0
  1656.       IF (M .EQ. 0) GO TO 1001
  1657.       E(1) = 1.0E0
  1658.       IF (N .EQ. 1) GO TO 1001
  1659. C
  1660.       DO 100 I = 2, N
  1661.          IF (E(I) .NE. 0.0E0) GO TO 80
  1662.          IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000
  1663.          E(I) = 1.0E0
  1664.          GO TO 100
  1665.    80    E(I) = E(I-1) * E(I) / T(I-1,3)
  1666.   100 CONTINUE
  1667. C
  1668.       DO 120 J = 1, M
  1669. C
  1670.          DO 120 I = 2, N
  1671.          Z(I,J) = Z(I,J) * E(I)
  1672.   120 CONTINUE
  1673. C
  1674.       GO TO 1001
  1675. C     .......... SET ERROR -- EIGENVECTORS CANNOT BE
  1676. C                FOUND BY THIS PROGRAM ..........
  1677.  1000 IERR = 2 * N + I
  1678.  1001 RETURN
  1679.       END
  1680. *DECK BALANC
  1681.       SUBROUTINE BALANC (NM, N, A, LOW, IGH, SCALE)
  1682. C***BEGIN PROLOGUE  BALANC
  1683. C***PURPOSE  Balance a real general matrix and isolate eigenvalues
  1684. C            whenever possible.
  1685. C***LIBRARY   SLATEC (EISPACK)
  1686. C***CATEGORY  D4C1A
  1687. C***TYPE      SINGLE PRECISION (BALANC-S, CBAL-C)
  1688. C***KEYWORDS  EIGENVECTORS, EISPACK
  1689. C***AUTHOR  Smith, B. T., et al.
  1690. C***DESCRIPTION
  1691. C
  1692. C     This subroutine is a translation of the ALGOL procedure BALANCE,
  1693. C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
  1694. C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
  1695. C
  1696. C     This subroutine balances a REAL matrix and isolates
  1697. C     eigenvalues whenever possible.
  1698. C
  1699. C     On INPUT
  1700. C
  1701. C        NM must be set to the row dimension of the two-dimensional
  1702. C          array parameter, A, as declared in the calling program
  1703. C          dimension statement.  NM is an INTEGER variable.
  1704. C
  1705. C        N is the order of the matrix A.  N is an INTEGER variable.
  1706. C          N must be less than or equal to NM.
  1707. C
  1708. C        A contains the input matrix to be balanced.  A is a
  1709. C          two-dimensional REAL array, dimensioned A(NM,N).
  1710. C
  1711. C     On OUTPUT
  1712. C
  1713. C        A contains the balanced matrix.
  1714. C
  1715. C        LOW and IGH are two INTEGER variables such that A(I,J)
  1716. C          is equal to zero if
  1717. C           (1) I is greater than J and
  1718. C           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
  1719. C
  1720. C        SCALE contains information determining the permutations and
  1721. C          scaling factors used.  SCALE is a one-dimensional REAL array,
  1722. C          dimensioned SCALE(N).
  1723. C
  1724. C     Suppose that the principal submatrix in rows LOW through IGH
  1725. C     has been balanced, that P(J) denotes the index interchanged
  1726. C     with J during the permutation step, and that the elements
  1727. C     of the diagonal matrix used are denoted by D(I,J).  Then
  1728. C        SCALE(J) = P(J),    for J = 1,...,LOW-1
  1729. C                 = D(J,J),      J = LOW,...,IGH
  1730. C                 = P(J)         J = IGH+1,...,N.
  1731. C     The order in which the interchanges are made is N to IGH+1,
  1732. C     then 1 TO LOW-1.
  1733. C
  1734. C     Note that 1 is returned for IGH if IGH is zero formally.
  1735. C
  1736. C     The ALGOL procedure EXC contained in BALANCE appears in
  1737. C     BALANC  in line.  (Note that the ALGOL roles of identifiers
  1738. C     K,L have been reversed.)
  1739. C
  1740. C     Questions and comments should be directed to B. S. Garbow,
  1741. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  1742. C     ------------------------------------------------------------------
  1743. C
  1744. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  1745. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  1746. C                 system Routines - EISPACK Guide, Springer-Verlag,
  1747. C                 1976.
  1748. C***ROUTINES CALLED  (NONE)
  1749. C***REVISION HISTORY  (YYMMDD)
  1750. C   760101  DATE WRITTEN
  1751. C   890831  Modified array declarations.  (WRB)
  1752. C   890831  REVISION DATE from Version 3.2
  1753. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  1754. C   920501  Reformatted the REFERENCES section.  (WRB)
  1755. C***END PROLOGUE  BALANC
  1756. C
  1757.       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
  1758.       REAL A(NM,*),SCALE(*)
  1759.       REAL C,F,G,R,S,B2,RADIX
  1760.       LOGICAL NOCONV
  1761. C
  1762. C***FIRST EXECUTABLE STATEMENT  BALANC
  1763.       RADIX = 16
  1764. C
  1765.       B2 = RADIX * RADIX
  1766.       K = 1
  1767.       L = N
  1768.       GO TO 100
  1769. C     .......... IN-LINE PROCEDURE FOR ROW AND
  1770. C                COLUMN EXCHANGE ..........
  1771.    20 SCALE(M) = J
  1772.       IF (J .EQ. M) GO TO 50
  1773. C
  1774.       DO 30 I = 1, L
  1775.          F = A(I,J)
  1776.          A(I,J) = A(I,M)
  1777.          A(I,M) = F
  1778.    30 CONTINUE
  1779. C
  1780.       DO 40 I = K, N
  1781.          F = A(J,I)
  1782.          A(J,I) = A(M,I)
  1783.          A(M,I) = F
  1784.    40 CONTINUE
  1785. C
  1786.    50 GO TO (80,130), IEXC
  1787. C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
  1788. C                AND PUSH THEM DOWN ..........
  1789.    80 IF (L .EQ. 1) GO TO 280
  1790.       L = L - 1
  1791. C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  1792.   100 DO 120 JJ = 1, L
  1793.          J = L + 1 - JJ
  1794. C
  1795.          DO 110 I = 1, L
  1796.             IF (I .EQ. J) GO TO 110
  1797.             IF (A(J,I) .NE. 0.0E0) GO TO 120
  1798.   110    CONTINUE
  1799. C
  1800.          M = L
  1801.          IEXC = 1
  1802.          GO TO 20
  1803.   120 CONTINUE
  1804. C
  1805.       GO TO 140
  1806. C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
  1807. C                AND PUSH THEM LEFT ..........
  1808.   130 K = K + 1
  1809. C
  1810.   140 DO 170 J = K, L
  1811. C
  1812.          DO 150 I = K, L
  1813.             IF (I .EQ. J) GO TO 150
  1814.             IF (A(I,J) .NE. 0.0E0) GO TO 170
  1815.   150    CONTINUE
  1816. C
  1817.          M = K
  1818.          IEXC = 2
  1819.          GO TO 20
  1820.   170 CONTINUE
  1821. C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
  1822.       DO 180 I = K, L
  1823.   180 SCALE(I) = 1.0E0
  1824. C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  1825.   190 NOCONV = .FALSE.
  1826. C
  1827.       DO 270 I = K, L
  1828.          C = 0.0E0
  1829.          R = 0.0E0
  1830. C
  1831.          DO 200 J = K, L
  1832.             IF (J .EQ. I) GO TO 200
  1833.             C = C + ABS(A(J,I))
  1834.             R = R + ABS(A(I,J))
  1835.   200    CONTINUE
  1836. C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
  1837.          IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270
  1838.          G = R / RADIX
  1839.          F = 1.0E0
  1840.          S = C + R
  1841.   210    IF (C .GE. G) GO TO 220
  1842.          F = F * RADIX
  1843.          C = C * B2
  1844.          GO TO 210
  1845.   220    G = R * RADIX
  1846.   230    IF (C .LT. G) GO TO 240
  1847.          F = F / RADIX
  1848.          C = C / B2
  1849.          GO TO 230
  1850. C     .......... NOW BALANCE ..........
  1851.   240    IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270
  1852.          G = 1.0E0 / F
  1853.          SCALE(I) = SCALE(I) * F
  1854.          NOCONV = .TRUE.
  1855. C
  1856.          DO 250 J = K, N
  1857.   250    A(I,J) = A(I,J) * G
  1858. C
  1859.          DO 260 J = 1, L
  1860.   260    A(J,I) = A(J,I) * F
  1861. C
  1862.   270 CONTINUE
  1863. C
  1864.       IF (NOCONV) GO TO 190
  1865. C
  1866.   280 LOW = K
  1867.       IGH = L
  1868.       RETURN
  1869.       END
  1870. *DECK BALBAK
  1871.       SUBROUTINE BALBAK (NM, N, LOW, IGH, SCALE, M, Z)
  1872. C***BEGIN PROLOGUE  BALBAK
  1873. C***PURPOSE  Form the eigenvectors of a real general matrix from the
  1874. C            eigenvectors of matrix output from BALANC.
  1875. C***LIBRARY   SLATEC (EISPACK)
  1876. C***CATEGORY  D4C4
  1877. C***TYPE      SINGLE PRECISION (BALBAK-S, CBABK2-C)
  1878. C***KEYWORDS  EIGENVECTORS, EISPACK
  1879. C***AUTHOR  Smith, B. T., et al.
  1880. C***DESCRIPTION
  1881. C
  1882. C     This subroutine is a translation of the ALGOL procedure BALBAK,
  1883. C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
  1884. C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
  1885. C
  1886. C     This subroutine forms the eigenvectors of a REAL GENERAL
  1887. C     matrix by back transforming those of the corresponding
  1888. C     balanced matrix determined by  BALANC.
  1889. C
  1890. C     On INPUT
  1891. C
  1892. C        NM must be set to the row dimension of the two-dimensional
  1893. C          array parameter, Z, as declared in the calling program
  1894. C          dimension statement.  NM is an INTEGER variable.
  1895. C
  1896. C        N is the number of components of the vectors in matrix Z.
  1897. C          N is an INTEGER variable.  N must be less than or equal
  1898. C          to NM.
  1899. C
  1900. C        LOW and IGH are INTEGER variables determined by  BALANC.
  1901. C
  1902. C        SCALE contains information determining the permutations and
  1903. C          scaling factors used by  BALANC.  SCALE is a one-dimensional
  1904. C          REAL array, dimensioned SCALE(N).
  1905. C
  1906. C        M is the number of columns of Z to be back transformed.
  1907. C          M is an INTEGER variable.
  1908. C
  1909. C        Z contains the real and imaginary parts of the eigen-
  1910. C          vectors to be back transformed in its first M columns.
  1911. C          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
  1912. C
  1913. C     On OUTPUT
  1914. C
  1915. C        Z contains the real and imaginary parts of the
  1916. C          transformed eigenvectors in its first M columns.
  1917. C
  1918. C     Questions and comments should be directed to B. S. Garbow,
  1919. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  1920. C     ------------------------------------------------------------------
  1921. C
  1922. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  1923. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  1924. C                 system Routines - EISPACK Guide, Springer-Verlag,
  1925. C                 1976.
  1926. C***ROUTINES CALLED  (NONE)
  1927. C***REVISION HISTORY  (YYMMDD)
  1928. C   760101  DATE WRITTEN
  1929. C   890831  Modified array declarations.  (WRB)
  1930. C   890831  REVISION DATE from Version 3.2
  1931. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  1932. C   920501  Reformatted the REFERENCES section.  (WRB)
  1933. C***END PROLOGUE  BALBAK
  1934. C
  1935.       INTEGER I,J,K,M,N,II,NM,IGH,LOW
  1936.       REAL SCALE(*),Z(NM,*)
  1937.       REAL S
  1938. C
  1939. C***FIRST EXECUTABLE STATEMENT  BALBAK
  1940.       IF (M .EQ. 0) GO TO 200
  1941.       IF (IGH .EQ. LOW) GO TO 120
  1942. C
  1943.       DO 110 I = LOW, IGH
  1944.          S = SCALE(I)
  1945. C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
  1946. C                IF THE FOREGOING STATEMENT IS REPLACED BY
  1947. C                S=1.0E0/SCALE(I). ..........
  1948.          DO 100 J = 1, M
  1949.   100    Z(I,J) = Z(I,J) * S
  1950. C
  1951.   110 CONTINUE
  1952. C     ......... FOR I=LOW-1 STEP -1 UNTIL 1,
  1953. C               IGH+1 STEP 1 UNTIL N DO -- ..........
  1954.   120 DO 140 II = 1, N
  1955.          I = II
  1956.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
  1957.          IF (I .LT. LOW) I = LOW - II
  1958.          K = SCALE(I)
  1959.          IF (K .EQ. I) GO TO 140
  1960. C
  1961.          DO 130 J = 1, M
  1962.             S = Z(I,J)
  1963.             Z(I,J) = Z(K,J)
  1964.             Z(K,J) = S
  1965.   130    CONTINUE
  1966. C
  1967.   140 CONTINUE
  1968. C
  1969.   200 RETURN
  1970.       END
  1971. *DECK BANDR
  1972.       SUBROUTINE BANDR (NM, N, MB, A, D, E, E2, MATZ, Z)
  1973. C***BEGIN PROLOGUE  BANDR
  1974. C***PURPOSE  Reduce a real symmetric band matrix to symmetric
  1975. C            tridiagonal matrix and, optionally, accumulate
  1976. C            orthogonal similarity transformations.
  1977. C***LIBRARY   SLATEC (EISPACK)
  1978. C***CATEGORY  D4C1B1
  1979. C***TYPE      SINGLE PRECISION (BANDR-S)
  1980. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  1981. C***AUTHOR  Smith, B. T., et al.
  1982. C***DESCRIPTION
  1983. C
  1984. C     This subroutine is a translation of the ALGOL procedure BANDRD,
  1985. C     NUM. MATH. 12, 231-241(1968) by Schwarz.
  1986. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971).
  1987. C
  1988. C     This subroutine reduces a REAL SYMMETRIC BAND matrix
  1989. C     to a symmetric tridiagonal matrix using and optionally
  1990. C     accumulating orthogonal similarity transformations.
  1991. C
  1992. C     On INPUT
  1993. C
  1994. C        NM must be set to the row dimension of the two-dimensional
  1995. C          array parameters, A and Z, as declared in the calling
  1996. C          program dimension statement.  NM is an INTEGER variable.
  1997. C
  1998. C        N is the order of the matrix A.  N is an INTEGER variable.
  1999. C          N must be less than or equal to NM.
  2000. C
  2001. C        MB is the (half) band width of the matrix, defined as the
  2002. C          number of adjacent diagonals, including the principal
  2003. C          diagonal, required to specify the non-zero portion of the
  2004. C          lower triangle of the matrix.  MB is less than or equal
  2005. C          to N.  MB is an INTEGER variable.
  2006. C
  2007. C        A contains the lower triangle of the real symmetric band
  2008. C          matrix.  Its lowest subdiagonal is stored in the last
  2009. C          N+1-MB  positions of the first column, its next subdiagonal
  2010. C          in the last  N+2-MB  positions of the second column, further
  2011. C          subdiagonals similarly, and finally its principal diagonal
  2012. C          in the  N  positions of the last column.  Contents of storage
  2013. C          locations not part of the matrix are arbitrary.  A is a
  2014. C          two-dimensional REAL array, dimensioned A(NM,MB).
  2015. C
  2016. C        MATZ should be set to .TRUE. if the transformation matrix is
  2017. C          to be accumulated, and to .FALSE. otherwise.  MATZ is a
  2018. C          LOGICAL variable.
  2019. C
  2020. C     On OUTPUT
  2021. C
  2022. C        A has been destroyed, except for its last two columns which
  2023. C          contain a copy of the tridiagonal matrix.
  2024. C
  2025. C        D contains the diagonal elements of the tridiagonal matrix.
  2026. C          D is a one-dimensional REAL array, dimensioned D(N).
  2027. C
  2028. C        E contains the subdiagonal elements of the tridiagonal
  2029. C          matrix in its last N-1 positions.  E(1) is set to zero.
  2030. C          E is a one-dimensional REAL array, dimensioned E(N).
  2031. C
  2032. C        E2 contains the squares of the corresponding elements of E.
  2033. C          E2 may coincide with E if the squares are not needed.
  2034. C          E2 is a one-dimensional REAL array, dimensioned E2(N).
  2035. C
  2036. C        Z contains the orthogonal transformation matrix produced in
  2037. C          the reduction if MATZ has been set to .TRUE.  Otherwise, Z
  2038. C          is not referenced.  Z is a two-dimensional REAL array,
  2039. C          dimensioned Z(NM,N).
  2040. C
  2041. C     Questions and comments should be directed to B. S. Garbow,
  2042. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  2043. C     ------------------------------------------------------------------
  2044. C
  2045. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  2046. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  2047. C                 system Routines - EISPACK Guide, Springer-Verlag,
  2048. C                 1976.
  2049. C***ROUTINES CALLED  (NONE)
  2050. C***REVISION HISTORY  (YYMMDD)
  2051. C   760101  DATE WRITTEN
  2052. C   890531  Changed all specific intrinsics to generic.  (WRB)
  2053. C   890831  Modified array declarations.  (WRB)
  2054. C   890831  REVISION DATE from Version 3.2
  2055. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  2056. C   920501  Reformatted the REFERENCES section.  (WRB)
  2057. C***END PROLOGUE  BANDR
  2058. C
  2059.       INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR
  2060.       REAL A(NM,*),D(*),E(*),E2(*),Z(NM,*)
  2061.       REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT
  2062.       LOGICAL MATZ
  2063. C
  2064. C***FIRST EXECUTABLE STATEMENT  BANDR
  2065.       DMIN = 2.0E0**(-64)
  2066.       DMINRT = 2.0E0**(-32)
  2067. C     .......... INITIALIZE DIAGONAL SCALING MATRIX ..........
  2068.       DO 30 J = 1, N
  2069.    30 D(J) = 1.0E0
  2070. C
  2071.       IF (.NOT. MATZ) GO TO 60
  2072. C
  2073.       DO 50 J = 1, N
  2074. C
  2075.          DO 40 K = 1, N
  2076.    40    Z(J,K) = 0.0E0
  2077. C
  2078.          Z(J,J) = 1.0E0
  2079.    50 CONTINUE
  2080. C
  2081.    60 M1 = MB - 1
  2082.       IF (M1 - 1) 900, 800, 70
  2083.    70 N2 = N - 2
  2084. C
  2085.       DO 700 K = 1, N2
  2086.          MAXR = MIN(M1,N-K)
  2087. C     .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- ..........
  2088.          DO 600 R1 = 2, MAXR
  2089.             R = MAXR + 2 - R1
  2090.             KR = K + R
  2091.             MR = MB - R
  2092.             G = A(KR,MR)
  2093.             A(KR-1,1) = A(KR-1,MR+1)
  2094.             UGL = K
  2095. C
  2096.             DO 500 J = KR, N, M1
  2097.                J1 = J - 1
  2098.                J2 = J1 - 1
  2099.                IF (G .EQ. 0.0E0) GO TO 600
  2100.                B1 = A(J1,1) / G
  2101.                B2 = B1 * D(J1) / D(J)
  2102.                S2 = 1.0E0 / (1.0E0 + B1 * B2)
  2103.                IF (S2 .GE. 0.5E0 ) GO TO 450
  2104.                B1 = G / A(J1,1)
  2105.                B2 = B1 * D(J) / D(J1)
  2106.                C2 = 1.0E0 - S2
  2107.                D(J1) = C2 * D(J1)
  2108.                D(J) = C2 * D(J)
  2109.                F1 = 2.0E0 * A(J,M1)
  2110.                F2 = B1 * A(J1,MB)
  2111.                A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1)
  2112.                A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB)
  2113.                A(J,MB) = B1 * (F2 - F1) + A(J,MB)
  2114. C
  2115.                DO 200 L = UGL, J2
  2116.                   I2 = MB - J + L
  2117.                   U = A(J1,I2+1) + B2 * A(J,I2)
  2118.                   A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2)
  2119.                   A(J1,I2+1) = U
  2120.   200          CONTINUE
  2121. C
  2122.                UGL = J
  2123.                A(J1,1) = A(J1,1) + B2 * G
  2124.                IF (J .EQ. N) GO TO 350
  2125.                MAXL = MIN(M1,N-J1)
  2126. C
  2127.                DO 300 L = 2, MAXL
  2128.                   I1 = J1 + L
  2129.                   I2 = MB - L
  2130.                   U = A(I1,I2) + B2 * A(I1,I2+1)
  2131.                   A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1)
  2132.                   A(I1,I2) = U
  2133.   300          CONTINUE
  2134. C
  2135.                I1 = J + M1
  2136.                IF (I1 .GT. N) GO TO 350
  2137.                G = B2 * A(I1,1)
  2138.   350          IF (.NOT. MATZ) GO TO 500
  2139. C
  2140.                DO 400 L = 1, N
  2141.                   U = Z(L,J1) + B2 * Z(L,J)
  2142.                   Z(L,J) = -B1 * Z(L,J1) + Z(L,J)
  2143.                   Z(L,J1) = U
  2144.   400          CONTINUE
  2145. C
  2146.                GO TO 500
  2147. C
  2148.   450          U = D(J1)
  2149.                D(J1) = S2 * D(J)
  2150.                D(J) = S2 * U
  2151.                F1 = 2.0E0 * A(J,M1)
  2152.                F2 = B1 * A(J,MB)
  2153.                U = B1 * (F2 - F1) + A(J1,MB)
  2154.                A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1)
  2155.                A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB)
  2156.                A(J,MB) = U
  2157. C
  2158.                DO 460 L = UGL, J2
  2159.                   I2 = MB - J + L
  2160.                   U = B2 * A(J1,I2+1) + A(J,I2)
  2161.                   A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2)
  2162.                   A(J1,I2+1) = U
  2163.   460          CONTINUE
  2164. C
  2165.                UGL = J
  2166.                A(J1,1) = B2 * A(J1,1) + G
  2167.                IF (J .EQ. N) GO TO 480
  2168.                MAXL = MIN(M1,N-J1)
  2169. C
  2170.                DO 470 L = 2, MAXL
  2171.                   I1 = J1 + L
  2172.                   I2 = MB - L
  2173.                   U = B2 * A(I1,I2) + A(I1,I2+1)
  2174.                   A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1)
  2175.                   A(I1,I2) = U
  2176.   470          CONTINUE
  2177. C
  2178.                I1 = J + M1
  2179.                IF (I1 .GT. N) GO TO 480
  2180.                G = A(I1,1)
  2181.                A(I1,1) = B1 * A(I1,1)
  2182.   480          IF (.NOT. MATZ) GO TO 500
  2183. C
  2184.                DO 490 L = 1, N
  2185.                   U = B2 * Z(L,J1) + Z(L,J)
  2186.                   Z(L,J) = -Z(L,J1) + B1 * Z(L,J)
  2187.                   Z(L,J1) = U
  2188.   490          CONTINUE
  2189. C
  2190.   500       CONTINUE
  2191. C
  2192.   600    CONTINUE
  2193. C
  2194.          IF (MOD(K,64) .NE. 0) GO TO 700
  2195. C     .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW ..........
  2196.          DO 650 J = K, N
  2197.             IF (D(J) .GE. DMIN) GO TO 650
  2198.             MAXL = MAX(1,MB+1-J)
  2199. C
  2200.             DO 610 L = MAXL, M1
  2201.   610       A(J,L) = DMINRT * A(J,L)
  2202. C
  2203.             IF (J .EQ. N) GO TO 630
  2204.             MAXL = MIN(M1,N-J)
  2205. C
  2206.             DO 620 L = 1, MAXL
  2207.                I1 = J + L
  2208.                I2 = MB - L
  2209.                A(I1,I2) = DMINRT * A(I1,I2)
  2210.   620       CONTINUE
  2211. C
  2212.   630       IF (.NOT. MATZ) GO TO 645
  2213. C
  2214.             DO 640 L = 1, N
  2215.   640       Z(L,J) = DMINRT * Z(L,J)
  2216. C
  2217.   645       A(J,MB) = DMIN * A(J,MB)
  2218.             D(J) = D(J) / DMIN
  2219.   650    CONTINUE
  2220. C
  2221.   700 CONTINUE
  2222. C     .......... FORM SQUARE ROOT OF SCALING MATRIX ..........
  2223.   800 DO 810 J = 2, N
  2224.   810 E(J) = SQRT(D(J))
  2225. C
  2226.       IF (.NOT. MATZ) GO TO 840
  2227. C
  2228.       DO 830 J = 1, N
  2229. C
  2230.          DO 820 K = 2, N
  2231.   820    Z(J,K) = E(K) * Z(J,K)
  2232. C
  2233.   830 CONTINUE
  2234. C
  2235.   840 U = 1.0E0
  2236. C
  2237.       DO 850 J = 2, N
  2238.          A(J,M1) = U * E(J) * A(J,M1)
  2239.          U = E(J)
  2240.          E2(J) = A(J,M1) ** 2
  2241.          A(J,MB) = D(J) * A(J,MB)
  2242.          D(J) = A(J,MB)
  2243.          E(J) = A(J,M1)
  2244.   850 CONTINUE
  2245. C
  2246.       D(1) = A(1,MB)
  2247.       E(1) = 0.0E0
  2248.       E2(1) = 0.0E0
  2249.       GO TO 1001
  2250. C
  2251.   900 DO 950 J = 1, N
  2252.          D(J) = A(J,MB)
  2253.          E(J) = 0.0E0
  2254.          E2(J) = 0.0E0
  2255.   950 CONTINUE
  2256. C
  2257.  1001 RETURN
  2258.       END
  2259. *DECK BANDV
  2260.       SUBROUTINE BANDV (NM, N, MBW, A, E21, M, W, Z, IERR, NV, RV, RV6)
  2261. C***BEGIN PROLOGUE  BANDV
  2262. C***PURPOSE  Form the eigenvectors of a real symmetric band matrix
  2263. C            associated with a set of ordered approximate eigenvalues
  2264. C            by inverse iteration.
  2265. C***LIBRARY   SLATEC (EISPACK)
  2266. C***CATEGORY  D4C3
  2267. C***TYPE      SINGLE PRECISION (BANDV-S)
  2268. C***KEYWORDS  EIGENVECTORS, EISPACK
  2269. C***AUTHOR  Smith, B. T., et al.
  2270. C***DESCRIPTION
  2271. C
  2272. C     This subroutine finds those eigenvectors of a REAL SYMMETRIC
  2273. C     BAND matrix corresponding to specified eigenvalues, using inverse
  2274. C     iteration.  The subroutine may also be used to solve systems
  2275. C     of linear equations with a symmetric or non-symmetric band
  2276. C     coefficient matrix.
  2277. C
  2278. C     On INPUT
  2279. C
  2280. C        NM must be set to the row dimension of the two-dimensional
  2281. C          array parameters, A and Z, as declared in the calling
  2282. C          program dimension statement.  NM is an INTEGER variable.
  2283. C
  2284. C        N is the order of the matrix A.  N is an INTEGER variable.
  2285. C          N must be less than or equal to NM.
  2286. C
  2287. C        MBW is the number of columns of the array A used to store the
  2288. C          band matrix.  If the matrix is symmetric, MBW is its (half)
  2289. C          band width, denoted MB and defined as the number of adjacent
  2290. C          diagonals, including the principal diagonal, required to
  2291. C          specify the non-zero portion of the lower triangle of the
  2292. C          matrix.  If the subroutine is being used to solve systems
  2293. C          of linear equations and the coefficient matrix is not
  2294. C          symmetric, it must however have the same number of adjacent
  2295. C          diagonals above the main diagonal as below, and in this
  2296. C          case, MBW=2*MB-1.  MBW is an INTEGER variable.  MB must not
  2297. C          be greater than N.
  2298. C
  2299. C        A contains the lower triangle of the symmetric band input
  2300. C          matrix stored as an N by MB array.  Its lowest subdiagonal
  2301. C          is stored in the last N+1-MB positions of the first column,
  2302. C          its next subdiagonal in the last N+2-MB positions of the
  2303. C          second column, further subdiagonals similarly, and finally
  2304. C          its principal diagonal in the N positions of column MB.
  2305. C          If the subroutine is being used to solve systems of linear
  2306. C          equations and the coefficient matrix is not symmetric, A is
  2307. C          N by 2*MB-1 instead with lower triangle as above and with
  2308. C          its first superdiagonal stored in the first N-1 positions of
  2309. C          column MB+1, its second superdiagonal in the first N-2
  2310. C          positions of column MB+2, further superdiagonals similarly,
  2311. C          and finally its highest superdiagonal in the first N+1-MB
  2312. C          positions of the last column.  Contents of storage locations
  2313. C          not part of the matrix are arbitrary.  A is a two-dimensional
  2314. C          REAL array, dimensioned A(NM,MBW).
  2315. C
  2316. C        E21 specifies the ordering of the eigenvalues and contains
  2317. C            0.0E0 if the eigenvalues are in ascending order, or
  2318. C            2.0E0 if the eigenvalues are in descending order.
  2319. C          If the subroutine is being used to solve systems of linear
  2320. C          equations, E21 should be set to 1.0E0 if the coefficient
  2321. C          matrix is symmetric and to -1.0E0 if not.  E21 is a REAL
  2322. C          variable.
  2323. C
  2324. C        M is the number of specified eigenvalues or the number of
  2325. C          systems of linear equations.  M is an INTEGER variable.
  2326. C
  2327. C        W contains the M eigenvalues in ascending or descending order.
  2328. C          If the subroutine is being used to solve systems of linear
  2329. C          equations (A-W(J)*I)*X(J)=B(J), where I is the identity
  2330. C          matrix, W(J) should be set accordingly, for J=1,2,...,M.
  2331. C          W is a one-dimensional REAL array, dimensioned W(M).
  2332. C
  2333. C        Z contains the constant matrix columns (B(J),J=1,2,...,M), if
  2334. C          the subroutine is used to solve systems of linear equations.
  2335. C          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
  2336. C
  2337. C        NV must be set to the dimension of the array parameter RV
  2338. C          as declared in the calling program dimension statement.
  2339. C          NV is an INTEGER variable.
  2340. C
  2341. C     On OUTPUT
  2342. C
  2343. C        A and W are unaltered.
  2344. C
  2345. C        Z contains the associated set of orthogonal eigenvectors.
  2346. C          Any vector which fails to converge is set to zero.  If the
  2347. C          subroutine is used to solve systems of linear equations,
  2348. C          Z contains the solution matrix columns (X(J),J=1,2,...,M).
  2349. C
  2350. C        IERR is an INTEGER flag set to
  2351. C          Zero       for normal return,
  2352. C          -J         if the eigenvector corresponding to the J-th
  2353. C                     eigenvalue fails to converge, or if the J-th
  2354. C                     system of linear equations is nearly singular.
  2355. C
  2356. C        RV and RV6 are temporary storage arrays.  If the subroutine
  2357. C          is being used to solve systems of linear equations, the
  2358. C          determinant (up to sign) of A-W(M)*I is available, upon
  2359. C          return, as the product of the first N elements of RV.
  2360. C          RV and RV6 are one-dimensional REAL arrays.  Note that RV
  2361. C          is dimensioned RV(NV), where NV must be at least N*(2*MB-1).
  2362. C          RV6 is dimensioned RV6(N).
  2363. C
  2364. C     Questions and comments should be directed to B. S. Garbow,
  2365. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  2366. C     ------------------------------------------------------------------
  2367. C
  2368. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  2369. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  2370. C                 system Routines - EISPACK Guide, Springer-Verlag,
  2371. C                 1976.
  2372. C***ROUTINES CALLED  (NONE)
  2373. C***REVISION HISTORY  (YYMMDD)
  2374. C   760101  DATE WRITTEN
  2375. C   890531  Changed all specific intrinsics to generic.  (WRB)
  2376. C   890831  Modified array declarations.  (WRB)
  2377. C   890831  REVISION DATE from Version 3.2
  2378. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  2379. C   920501  Reformatted the REFERENCES section.  (WRB)
  2380. C***END PROLOGUE  BANDV
  2381. C
  2382.       INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21
  2383.       INTEGER IERR,MAXJ,MAXK,GROUP
  2384.       REAL A(NM,*),W(*),Z(NM,*),RV(*),RV6(*)
  2385.       REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,S
  2386. C
  2387. C***FIRST EXECUTABLE STATEMENT  BANDV
  2388.       IERR = 0
  2389.       IF (M .EQ. 0) GO TO 1001
  2390.       MB = MBW
  2391.       IF (E21 .LT. 0.0E0) MB = (MBW + 1) / 2
  2392.       M1 = MB - 1
  2393.       M21 = M1 + MB
  2394.       ORDER = 1.0E0 - ABS(E21)
  2395. C     .......... FIND VECTORS BY INVERSE ITERATION ..........
  2396.       DO 920 R = 1, M
  2397.          ITS = 1
  2398.          X1 = W(R)
  2399.          IF (R .NE. 1) GO TO 100
  2400. C     .......... COMPUTE NORM OF MATRIX ..........
  2401.          NORM = 0.0E0
  2402. C
  2403.          DO 60 J = 1, MB
  2404.             JJ = MB + 1 - J
  2405.             KJ = JJ + M1
  2406.             IJ = 1
  2407.             S = 0.0E0
  2408. C
  2409.             DO 40 I = JJ, N
  2410.                S = S + ABS(A(I,J))
  2411.                IF (E21 .GE. 0.0E0) GO TO 40
  2412.                S = S + ABS(A(IJ,KJ))
  2413.                IJ = IJ + 1
  2414.    40       CONTINUE
  2415. C
  2416.             NORM = MAX(NORM,S)
  2417.    60    CONTINUE
  2418. C
  2419.          IF (E21 .LT. 0.0E0) NORM = 0.5E0 * NORM
  2420. C     .......... EPS2 IS THE CRITERION FOR GROUPING,
  2421. C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
  2422. C                ROOTS ARE MODIFIED BY EPS3,
  2423. C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
  2424.          IF (NORM .EQ. 0.0E0) NORM = 1.0E0
  2425.          EPS2 = 1.0E-3 * NORM * ABS(ORDER)
  2426.          EPS3 = NORM
  2427.    70    EPS3 = 0.5E0*EPS3
  2428.          IF (NORM + EPS3 .GT. NORM) GO TO 70
  2429.          UK = SQRT(REAL(N))
  2430.          EPS3 = UK * EPS3
  2431.          EPS4 = UK * EPS3
  2432.    80    GROUP = 0
  2433.          GO TO 120
  2434. C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  2435.   100    IF (ABS(X1-X0) .GE. EPS2) GO TO 80
  2436.          GROUP = GROUP + 1
  2437.          IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3
  2438. C     .......... EXPAND MATRIX, SUBTRACT EIGENVALUE,
  2439. C                AND INITIALIZE VECTOR ..........
  2440.   120    DO 200 I = 1, N
  2441.             IJ = I + MIN(0,I-M1) * N
  2442.             KJ = IJ + MB * N
  2443.             IJ1 = KJ + M1 * N
  2444.             IF (M1 .EQ. 0) GO TO 180
  2445. C
  2446.             DO 150 J = 1, M1
  2447.                IF (IJ .GT. M1) GO TO 125
  2448.                IF (IJ .GT. 0) GO TO 130
  2449.                RV(IJ1) = 0.0E0
  2450.                IJ1 = IJ1 + N
  2451.                GO TO 130
  2452.   125          RV(IJ) = A(I,J)
  2453.   130          IJ = IJ + N
  2454.                II = I + J
  2455.                IF (II .GT. N) GO TO 150
  2456.                JJ = MB - J
  2457.                IF (E21 .GE. 0.0E0) GO TO 140
  2458.                II = I
  2459.                JJ = MB + J
  2460.   140          RV(KJ) = A(II,JJ)
  2461.                KJ = KJ + N
  2462.   150       CONTINUE
  2463. C
  2464.   180       RV(IJ) = A(I,MB) - X1
  2465.             RV6(I) = EPS4
  2466.             IF (ORDER .EQ. 0.0E0) RV6(I) = Z(I,R)
  2467.   200    CONTINUE
  2468. C
  2469.          IF (M1 .EQ. 0) GO TO 600
  2470. C     .......... ELIMINATION WITH INTERCHANGES ..........
  2471.          DO 580 I = 1, N
  2472.             II = I + 1
  2473.             MAXK = MIN(I+M1-1,N)
  2474.             MAXJ = MIN(N-I,M21-2) * N
  2475. C
  2476.             DO 360 K = I, MAXK
  2477.                KJ1 = K
  2478.                J = KJ1 + N
  2479.                JJ = J + MAXJ
  2480. C
  2481.                DO 340 KJ = J, JJ, N
  2482.                   RV(KJ1) = RV(KJ)
  2483.                   KJ1 = KJ
  2484.   340          CONTINUE
  2485. C
  2486.                RV(KJ1) = 0.0E0
  2487.   360       CONTINUE
  2488. C
  2489.             IF (I .EQ. N) GO TO 580
  2490.             U = 0.0E0
  2491.             MAXK = MIN(I+M1,N)
  2492.             MAXJ = MIN(N-II,M21-2) * N
  2493. C
  2494.             DO 450 J = I, MAXK
  2495.                IF (ABS(RV(J)) .LT. ABS(U)) GO TO 450
  2496.                U = RV(J)
  2497.                K = J
  2498.   450       CONTINUE
  2499. C
  2500.             J = I + N
  2501.             JJ = J + MAXJ
  2502.             IF (K .EQ. I) GO TO 520
  2503.             KJ = K
  2504. C
  2505.             DO 500 IJ = I, JJ, N
  2506.                V = RV(IJ)
  2507.                RV(IJ) = RV(KJ)
  2508.                RV(KJ) = V
  2509.                KJ = KJ + N
  2510.   500       CONTINUE
  2511. C
  2512.             IF (ORDER .NE. 0.0E0) GO TO 520
  2513.             V = RV6(I)
  2514.             RV6(I) = RV6(K)
  2515.             RV6(K) = V
  2516.   520       IF (U .EQ. 0.0E0) GO TO 580
  2517. C
  2518.             DO 560 K = II, MAXK
  2519.                V = RV(K) / U
  2520.                KJ = K
  2521. C
  2522.                DO 540 IJ = J, JJ, N
  2523.                   KJ = KJ + N
  2524.                   RV(KJ) = RV(KJ) - V * RV(IJ)
  2525.   540          CONTINUE
  2526. C
  2527.                IF (ORDER .EQ. 0.0E0) RV6(K) = RV6(K) - V * RV6(I)
  2528.   560       CONTINUE
  2529. C
  2530.   580    CONTINUE
  2531. C     .......... BACK SUBSTITUTION
  2532. C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
  2533.   600    DO 630 II = 1, N
  2534.             I = N + 1 - II
  2535.             MAXJ = MIN(II,M21)
  2536.             IF (MAXJ .EQ. 1) GO TO 620
  2537.             IJ1 = I
  2538.             J = IJ1 + N
  2539.             JJ = J + (MAXJ - 2) * N
  2540. C
  2541.             DO 610 IJ = J, JJ, N
  2542.                IJ1 = IJ1 + 1
  2543.                RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1)
  2544.   610       CONTINUE
  2545. C
  2546.   620       V = RV(I)
  2547.             IF (ABS(V) .GE. EPS3) GO TO 625
  2548. C     .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..........
  2549.             IF (ORDER .EQ. 0.0E0) IERR = -R
  2550.             V = SIGN(EPS3,V)
  2551.   625       RV6(I) = RV6(I) / V
  2552.   630    CONTINUE
  2553. C
  2554.          XU = 1.0E0
  2555.          IF (ORDER .EQ. 0.0E0) GO TO 870
  2556. C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
  2557. C                MEMBERS OF GROUP ..........
  2558.          IF (GROUP .EQ. 0) GO TO 700
  2559. C
  2560.          DO 680 JJ = 1, GROUP
  2561.             J = R - GROUP - 1 + JJ
  2562.             XU = 0.0E0
  2563. C
  2564.             DO 640 I = 1, N
  2565.   640       XU = XU + RV6(I) * Z(I,J)
  2566. C
  2567.             DO 660 I = 1, N
  2568.   660       RV6(I) = RV6(I) - XU * Z(I,J)
  2569. C
  2570.   680    CONTINUE
  2571. C
  2572.   700    NORM = 0.0E0
  2573. C
  2574.          DO 720 I = 1, N
  2575.   720    NORM = NORM + ABS(RV6(I))
  2576. C
  2577.          IF (NORM .GE. 0.1E0) GO TO 840
  2578. C     .......... IN-LINE PROCEDURE FOR CHOOSING
  2579. C                A NEW STARTING VECTOR ..........
  2580.          IF (ITS .GE. N) GO TO 830
  2581.          ITS = ITS + 1
  2582.          XU = EPS4 / (UK + 1.0E0)
  2583.          RV6(1) = EPS4
  2584. C
  2585.          DO 760 I = 2, N
  2586.   760    RV6(I) = XU
  2587. C
  2588.          RV6(ITS) = RV6(ITS) - EPS4 * UK
  2589.          GO TO 600
  2590. C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  2591.   830    IERR = -R
  2592.          XU = 0.0E0
  2593.          GO TO 870
  2594. C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
  2595. C                1 AND EXPAND TO FULL ORDER ..........
  2596.   840    U = 0.0E0
  2597. C
  2598.          DO 860 I = 1, N
  2599.   860    U = U + RV6(I)**2
  2600. C
  2601.          XU = 1.0E0 / SQRT(U)
  2602. C
  2603.   870    DO 900 I = 1, N
  2604.   900    Z(I,R) = RV6(I) * XU
  2605. C
  2606.          X0 = X1
  2607.   920 CONTINUE
  2608. C
  2609.  1001 RETURN
  2610.       END
  2611. *DECK BCRH
  2612.       FUNCTION BCRH (XLL, XRR, IZ, C, A, BH, F, SGN)
  2613. C***BEGIN PROLOGUE  BCRH
  2614. C***SUBSIDIARY
  2615. C***PURPOSE  Subsidiary to CBLKTR
  2616. C***LIBRARY   SLATEC
  2617. C***TYPE      SINGLE PRECISION (BCRH-S, BSRH-S)
  2618. C***AUTHOR  (UNKNOWN)
  2619. C***SEE ALSO  CBLKTR
  2620. C***ROUTINES CALLED  (NONE)
  2621. C***COMMON BLOCKS    CCBLK
  2622. C***REVISION HISTORY  (YYMMDD)
  2623. C   801001  DATE WRITTEN
  2624. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  2625. C   900402  Added TYPE section.  (WRB)
  2626. C***END PROLOGUE  BCRH
  2627.       DIMENSION       A(*)       ,C(*)       ,BH(*)
  2628.       COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
  2629.      1                NM         ,NCMPLX     ,IK
  2630. C***FIRST EXECUTABLE STATEMENT  BCRH
  2631.       XL = XLL
  2632.       XR = XRR
  2633.       DX = .5*ABS(XR-XL)
  2634.   101 X = .5*(XL+XR)
  2635.       IF (SGN*F(X,IZ,C,A,BH)) 103,105,102
  2636.   102 XR = X
  2637.       GO TO 104
  2638.   103 XL = X
  2639.   104 DX = .5*DX
  2640.       IF (DX-CNV) 105,105,101
  2641.   105 BCRH = .5*(XL+XR)
  2642.       RETURN
  2643.       END
  2644. *DECK BDIFF
  2645.       SUBROUTINE BDIFF (L, V)
  2646. C***BEGIN PROLOGUE  BDIFF
  2647. C***SUBSIDIARY
  2648. C***PURPOSE  Subsidiary to BSKIN
  2649. C***LIBRARY   SLATEC
  2650. C***TYPE      SINGLE PRECISION (BDIFF-S, DBDIFF-D)
  2651. C***AUTHOR  Amos, D. E., (SNLA)
  2652. C***DESCRIPTION
  2653. C
  2654. C     BDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K)
  2655. C     are the binomial coefficients.  Truncated sums are computed by
  2656. C     setting last part of the V vector to zero. On return, the binomial
  2657. C     sum is in V(L).
  2658. C
  2659. C***SEE ALSO  BSKIN
  2660. C***ROUTINES CALLED  (NONE)
  2661. C***REVISION HISTORY  (YYMMDD)
  2662. C   820601  DATE WRITTEN
  2663. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  2664. C   900328  Added TYPE section.  (WRB)
  2665. C***END PROLOGUE  BDIFF
  2666.       INTEGER I, J, K, L
  2667.       REAL V
  2668.       DIMENSION V(*)
  2669. C***FIRST EXECUTABLE STATEMENT  BDIFF
  2670.       IF (L.EQ.1) RETURN
  2671.       DO 20 J=2,L
  2672.         K = L
  2673.         DO 10 I=J,L
  2674.           V(K) = V(K-1) - V(K)
  2675.           K = K - 1
  2676.    10   CONTINUE
  2677.    20 CONTINUE
  2678.       RETURN
  2679.       END
  2680. *DECK BESI
  2681.       SUBROUTINE BESI (X, ALPHA, KODE, N, Y, NZ)
  2682. C***BEGIN PROLOGUE  BESI
  2683. C***PURPOSE  Compute an N member sequence of I Bessel functions
  2684. C            I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
  2685. C            EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative
  2686. C            ALPHA and X.
  2687. C***LIBRARY   SLATEC
  2688. C***CATEGORY  C10B3
  2689. C***TYPE      SINGLE PRECISION (BESI-S, DBESI-D)
  2690. C***KEYWORDS  I BESSEL FUNCTION, SPECIAL FUNCTIONS
  2691. C***AUTHOR  Amos, D. E., (SNLA)
  2692. C           Daniel, S. L., (SNLA)
  2693. C***DESCRIPTION
  2694. C
  2695. C     Abstract
  2696. C         BESI computes an N member sequence of I Bessel functions
  2697. C         I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
  2698. C         EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
  2699. C         and X.  A combination of the power series, the asymptotic
  2700. C         expansion for X to infinity, and the uniform asymptotic
  2701. C         expansion for NU to infinity are applied over subdivisions of
  2702. C         the (NU,X) plane.  For values not covered by one of these
  2703. C         formulae, the order is incremented by an integer so that one
  2704. C         of these formulae apply.  Backward recursion is used to reduce
  2705. C         orders by integer values.  The asymptotic expansion for X to
  2706. C         infinity is used only when the entire sequence (specifically
  2707. C         the last member) lies within the region covered by the
  2708. C         expansion.  Leading terms of these expansions are used to test
  2709. C         for over or underflow where appropriate.  If a sequence is
  2710. C         requested and the last member would underflow, the result is
  2711. C         set to zero and the next lower order tried, etc., until a
  2712. C         member comes on scale or all are set to zero.  An overflow
  2713. C         cannot occur with scaling.
  2714. C
  2715. C     Description of Arguments
  2716. C
  2717. C         Input
  2718. C           X      - X .GE. 0.0E0
  2719. C           ALPHA  - order of first member of the sequence,
  2720. C                    ALPHA .GE. 0.0E0
  2721. C           KODE   - a parameter to indicate the scaling option
  2722. C                    KODE=1 returns
  2723. C                           Y(K)=        I/sub(ALPHA+K-1)/(X),
  2724. C                                K=1,...,N
  2725. C                    KODE=2 returns
  2726. C                           Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X),
  2727. C                                K=1,...,N
  2728. C           N      - number of members in the sequence, N .GE. 1
  2729. C
  2730. C         Output
  2731. C           Y      - a vector whose first N components contain
  2732. C                    values for I/sub(ALPHA+K-1)/(X) or scaled
  2733. C                    values for EXP(-X)*I/sub(ALPHA+K-1)/(X),
  2734. C                    K=1,...,N depending on KODE
  2735. C           NZ     - number of components of Y set to zero due to
  2736. C                    underflow,
  2737. C                    NZ=0   , normal return, computation completed
  2738. C                    NZ .NE. 0, last NZ components of Y set to zero,
  2739. C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
  2740. C
  2741. C     Error Conditions
  2742. C         Improper input arguments - a fatal error
  2743. C         Overflow with KODE=1 - a fatal error
  2744. C         Underflow - a non-fatal error (NZ .NE. 0)
  2745. C
  2746. C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
  2747. C                 subroutines IBESS and JBESS for Bessel functions
  2748. C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
  2749. C                 Transactions on Mathematical Software 3, (1977),
  2750. C                 pp. 76-92.
  2751. C               F. W. J. Olver, Tables of Bessel Functions of Moderate
  2752. C                 or Large Orders, NPL Mathematical Tables 6, Her
  2753. C                 Majesty's Stationery Office, London, 1962.
  2754. C***ROUTINES CALLED  ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG
  2755. C***REVISION HISTORY  (YYMMDD)
  2756. C   750101  DATE WRITTEN
  2757. C   890531  Changed all specific intrinsics to generic.  (WRB)
  2758. C   890531  REVISION DATE from Version 3.2
  2759. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  2760. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  2761. C   900326  Removed duplicate information from DESCRIPTION section.
  2762. C           (WRB)
  2763. C   920501  Reformatted the REFERENCES section.  (WRB)
  2764. C***END PROLOGUE  BESI
  2765. C
  2766.       INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT,
  2767.      1 N, NN, NS, NZ
  2768.       INTEGER I1MACH
  2769.       REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN,
  2770.      1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA,
  2771.      2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL,
  2772.      3 TRX, T2, X, XO2, XO2L, Y, Z
  2773.       REAL R1MACH, ALNGAM
  2774.       DIMENSION Y(*), TEMP(3)
  2775.       SAVE RTTPI, INLIM
  2776.       DATA RTTPI           / 3.98942280401433E-01/
  2777.       DATA INLIM           /          80         /
  2778. C***FIRST EXECUTABLE STATEMENT  BESI
  2779.       NZ = 0
  2780.       KT = 1
  2781. C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
  2782. C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
  2783.       RA = R1MACH(3)
  2784.       TOL = MAX(RA,1.0E-15)
  2785.       I1 = -I1MACH(12)
  2786.       GLN = R1MACH(5)
  2787.       ELIM = 2.303E0*(I1*GLN-3.0E0)
  2788. C     TOLLN = -LN(TOL)
  2789.       I1 = I1MACH(11)+1
  2790.       TOLLN = 2.303E0*GLN*I1
  2791.       TOLLN = MIN(TOLLN,34.5388E0)
  2792.       IF (N-1) 590, 10, 20
  2793.    10 KT = 2
  2794.    20 NN = N
  2795.       IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
  2796.       IF (X) 600, 30, 80
  2797.    30 IF (ALPHA) 580, 40, 50
  2798.    40 Y(1) = 1.0E0
  2799.       IF (N.EQ.1) RETURN
  2800.       I1 = 2
  2801.       GO TO 60
  2802.    50 I1 = 1
  2803.    60 DO 70 I=I1,N
  2804.         Y(I) = 0.0E0
  2805.    70 CONTINUE
  2806.       RETURN
  2807.    80 CONTINUE
  2808.       IF (ALPHA.LT.0.0E0) GO TO 580
  2809. C
  2810.       IALP = INT(ALPHA)
  2811.       FNI = IALP + N - 1
  2812.       FNF = ALPHA - IALP
  2813.       DFN = FNI + FNF
  2814.       FNU = DFN
  2815.       IN = 0
  2816.       XO2 = X*0.5E0
  2817.       SXO2 = XO2*XO2
  2818.       ETX = KODE - 1
  2819.       SX = ETX*X
  2820. C
  2821. C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
  2822. C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
  2823. C     APPLIED.
  2824. C
  2825.       IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
  2826.       IF (X.LE.12.0E0) GO TO 110
  2827.       FN = 0.55E0*FNU*FNU
  2828.       FN = MAX(17.0E0,FN)
  2829.       IF (X.GE.FN) GO TO 430
  2830.       ANS = MAX(36.0E0-FNU,0.0E0)
  2831.       NS = INT(ANS)
  2832.       FNI = FNI + NS
  2833.       DFN = FNI + FNF
  2834.       FN = DFN
  2835.       IS = KT
  2836.       KM = N - 1 + NS
  2837.       IF (KM.GT.0) IS = 3
  2838.       GO TO 120
  2839.    90 FN = FNU
  2840.       FNP1 = FN + 1.0E0
  2841.       XO2L = LOG(XO2)
  2842.       IS = KT
  2843.       IF (X.LE.0.5E0) GO TO 230
  2844.       NS = 0
  2845.   100 FNI = FNI + NS
  2846.       DFN = FNI + FNF
  2847.       FN = DFN
  2848.       FNP1 = FN + 1.0E0
  2849.       IS = KT
  2850.       IF (N-1+NS.GT.0) IS = 3
  2851.       GO TO 230
  2852.   110 XO2L = LOG(XO2)
  2853.       NS = INT(SXO2-FNU)
  2854.       GO TO 100
  2855.   120 CONTINUE
  2856. C
  2857. C     OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
  2858. C
  2859.       IF (KODE.EQ.2) GO TO 130
  2860.       IF (ALPHA.LT.1.0E0) GO TO 150
  2861.       Z = X/ALPHA
  2862.       RA = SQRT(1.0E0+Z*Z)
  2863.       GLN = LOG((1.0E0+RA)/Z)
  2864.       T = RA*(1.0E0-ETX) + ETX/(Z+RA)
  2865.       ARG = ALPHA*(T-GLN)
  2866.       IF (ARG.GT.ELIM) GO TO 610
  2867.       IF (KM.EQ.0) GO TO 140
  2868.   130 CONTINUE
  2869. C
  2870. C     UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
  2871. C
  2872.       Z = X/FN
  2873.       RA = SQRT(1.0E0+Z*Z)
  2874.       GLN = LOG((1.0E0+RA)/Z)
  2875.       T = RA*(1.0E0-ETX) + ETX/(Z+RA)
  2876.       ARG = FN*(T-GLN)
  2877.   140 IF (ARG.LT.(-ELIM)) GO TO 280
  2878.       GO TO 190
  2879.   150 IF (X.GT.ELIM) GO TO 610
  2880.       GO TO 130
  2881. C
  2882. C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
  2883. C
  2884.   160 IF (KM.NE.0) GO TO 170
  2885.       Y(1) = TEMP(3)
  2886.       RETURN
  2887.   170 TEMP(1) = TEMP(3)
  2888.       IN = NS
  2889.       KT = 1
  2890.       I1 = 0
  2891.   180 CONTINUE
  2892.       IS = 2
  2893.       FNI = FNI - 1.0E0
  2894.       DFN = FNI + FNF
  2895.       FN = DFN
  2896.       IF(I1.EQ.2) GO TO 350
  2897.       Z = X/FN
  2898.       RA = SQRT(1.0E0+Z*Z)
  2899.       GLN = LOG((1.0E0+RA)/Z)
  2900.       T = RA*(1.0E0-ETX) + ETX/(Z+RA)
  2901.       ARG = FN*(T-GLN)
  2902.   190 CONTINUE
  2903.       I1 = ABS(3-IS)
  2904.       I1 = MAX(I1,1)
  2905.       FLGIK = 1.0E0
  2906.       CALL ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS))
  2907.       GO TO (180, 350, 510), IS
  2908. C
  2909. C     SERIES FOR (X/2)**2.LE.NU+1
  2910. C
  2911.   230 CONTINUE
  2912.       GLN = ALNGAM(FNP1)
  2913.       ARG = FN*XO2L - GLN - SX
  2914.       IF (ARG.LT.(-ELIM)) GO TO 300
  2915.       EARG = EXP(ARG)
  2916.   240 CONTINUE
  2917.       S = 1.0E0
  2918.       IF (X.LT.TOL) GO TO 260
  2919.       AK = 3.0E0
  2920.       T2 = 1.0E0
  2921.       T = 1.0E0
  2922.       S1 = FN
  2923.       DO 250 K=1,17
  2924.         S2 = T2 + S1
  2925.         T = T*SXO2/S2
  2926.         S = S + T
  2927.         IF (ABS(T).LT.TOL) GO TO 260
  2928.         T2 = T2 + AK
  2929.         AK = AK + 2.0E0
  2930.         S1 = S1 + FN
  2931.   250 CONTINUE
  2932.   260 CONTINUE
  2933.       TEMP(IS) = S*EARG
  2934.       GO TO (270, 350, 500), IS
  2935.   270 EARG = EARG*FN/XO2
  2936.       FNI = FNI - 1.0E0
  2937.       DFN = FNI + FNF
  2938.       FN = DFN
  2939.       IS = 2
  2940.       GO TO 240
  2941. C
  2942. C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
  2943. C
  2944.   280 Y(NN) = 0.0E0
  2945.       NN = NN - 1
  2946.       FNI = FNI - 1.0E0
  2947.       DFN = FNI + FNF
  2948.       FN = DFN
  2949.       IF (NN-1) 340, 290, 130
  2950.   290 KT = 2
  2951.       IS = 2
  2952.       GO TO 130
  2953.   300 Y(NN) = 0.0E0
  2954.       NN = NN - 1
  2955.       FNP1 = FN
  2956.       FNI = FNI - 1.0E0
  2957.       DFN = FNI + FNF
  2958.       FN = DFN
  2959.       IF (NN-1) 340, 310, 320
  2960.   310 KT = 2
  2961.       IS = 2
  2962.   320 IF (SXO2.LE.FNP1) GO TO 330
  2963.       GO TO 130
  2964.   330 ARG = ARG - XO2L + LOG(FNP1)
  2965.       IF (ARG.LT.(-ELIM)) GO TO 300
  2966.       GO TO 230
  2967.   340 NZ = N - NN
  2968.       RETURN
  2969. C
  2970. C     BACKWARD RECURSION SECTION
  2971. C
  2972.   350 CONTINUE
  2973.       NZ = N - NN
  2974.   360 CONTINUE
  2975.       IF(KT.EQ.2) GO TO 420
  2976.       S1 = TEMP(1)
  2977.       S2 = TEMP(2)
  2978.       TRX = 2.0E0/X
  2979.       DTM = FNI
  2980.       TM = (DTM+FNF)*TRX
  2981.       IF (IN.EQ.0) GO TO 390
  2982. C     BACKWARD RECUR TO INDEX ALPHA+NN-1
  2983.       DO 380 I=1,IN
  2984.         S = S2
  2985.         S2 = TM*S2 + S1
  2986.         S1 = S
  2987.         DTM = DTM - 1.0E0
  2988.         TM = (DTM+FNF)*TRX
  2989.   380 CONTINUE
  2990.       Y(NN) = S1
  2991.       IF (NN.EQ.1) RETURN
  2992.       Y(NN-1) = S2
  2993.       IF (NN.EQ.2) RETURN
  2994.       GO TO 400
  2995.   390 CONTINUE
  2996. C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
  2997.       Y(NN) = S1
  2998.       Y(NN-1) = S2
  2999.       IF (NN.EQ.2) RETURN
  3000.   400 K = NN + 1
  3001.       DO 410 I=3,NN
  3002.         K = K - 1
  3003.         Y(K-2) = TM*Y(K-1) + Y(K)
  3004.         DTM = DTM - 1.0E0
  3005.         TM = (DTM+FNF)*TRX
  3006.   410 CONTINUE
  3007.       RETURN
  3008.   420 Y(1) = TEMP(2)
  3009.       RETURN
  3010. C
  3011. C     ASYMPTOTIC EXPANSION FOR X TO INFINITY
  3012. C
  3013.   430 CONTINUE
  3014.       EARG = RTTPI/SQRT(X)
  3015.       IF (KODE.EQ.2) GO TO 440
  3016.       IF (X.GT.ELIM) GO TO 610
  3017.       EARG = EARG*EXP(X)
  3018.   440 ETX = 8.0E0*X
  3019.       IS = KT
  3020.       IN = 0
  3021.       FN = FNU
  3022.   450 DX = FNI + FNI
  3023.       TM = 0.0E0
  3024.       IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460
  3025.       TM = 4.0E0*FNF*(FNI+FNI+FNF)
  3026.   460 CONTINUE
  3027.       DTM = DX*DX
  3028.       S1 = ETX
  3029.       TRX = DTM - 1.0E0
  3030.       DX = -(TRX+TM)/ETX
  3031.       T = DX
  3032.       S = 1.0E0 + DX
  3033.       ATOL = TOL*ABS(S)
  3034.       S2 = 1.0E0
  3035.       AK = 8.0E0
  3036.       DO 470 K=1,25
  3037.         S1 = S1 + ETX
  3038.         S2 = S2 + AK
  3039.         DX = DTM - S2
  3040.         AP = DX + TM
  3041.         T = -T*AP/S1
  3042.         S = S + T
  3043.         IF (ABS(T).LE.ATOL) GO TO 480
  3044.         AK = AK + 8.0E0
  3045.   470 CONTINUE
  3046.   480 TEMP(IS) = S*EARG
  3047.       IF(IS.EQ.2) GO TO 360
  3048.       IS = 2
  3049.       FNI = FNI - 1.0E0
  3050.       DFN = FNI + FNF
  3051.       FN = DFN
  3052.       GO TO 450
  3053. C
  3054. C     BACKWARD RECURSION WITH NORMALIZATION BY
  3055. C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
  3056. C
  3057.   500 CONTINUE
  3058. C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
  3059.       AKM = MAX(3.0E0-FN,0.0E0)
  3060.       KM = INT(AKM)
  3061.       TFN = FN + KM
  3062.       TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
  3063.       TA = XO2L - TA
  3064.       TB = -(1.0E0-1.0E0/TFN)/TFN
  3065.       AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
  3066.       IN = INT(AIN)
  3067.       IN = IN + KM
  3068.       GO TO 520
  3069.   510 CONTINUE
  3070. C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
  3071.       T = 1.0E0/(FN*RA)
  3072.       AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0
  3073.       IN = INT(AIN)
  3074.       IF (IN.GT.INLIM) GO TO 160
  3075.   520 CONTINUE
  3076.       TRX = 2.0E0/X
  3077.       DTM = FNI + IN
  3078.       TM = (DTM+FNF)*TRX
  3079.       TA = 0.0E0
  3080.       TB = TOL
  3081.       KK = 1
  3082.   530 CONTINUE
  3083. C
  3084. C     BACKWARD RECUR UNINDEXED
  3085. C
  3086.       DO 540 I=1,IN
  3087.         S = TB
  3088.         TB = TM*TB + TA
  3089.         TA = S
  3090.         DTM = DTM - 1.0E0
  3091.         TM = (DTM+FNF)*TRX
  3092.   540 CONTINUE
  3093. C     NORMALIZATION
  3094.       IF (KK.NE.1) GO TO 550
  3095.       TA = (TA/TB)*TEMP(3)
  3096.       TB = TEMP(3)
  3097.       KK = 2
  3098.       IN = NS
  3099.       IF (NS.NE.0) GO TO 530
  3100.   550 Y(NN) = TB
  3101.       NZ = N - NN
  3102.       IF (NN.EQ.1) RETURN
  3103.       TB = TM*TB + TA
  3104.       K = NN - 1
  3105.       Y(K) = TB
  3106.       IF (NN.EQ.2) RETURN
  3107.       DTM = DTM - 1.0E0
  3108.       TM = (DTM+FNF)*TRX
  3109.       KM = K - 1
  3110. C
  3111. C     BACKWARD RECUR INDEXED
  3112. C
  3113.       DO 560 I=1,KM
  3114.         Y(K-1) = TM*Y(K) + Y(K+1)
  3115.         DTM = DTM - 1.0E0
  3116.         TM = (DTM+FNF)*TRX
  3117.         K = K - 1
  3118.   560 CONTINUE
  3119.       RETURN
  3120. C
  3121. C
  3122. C
  3123.   570 CONTINUE
  3124.       CALL XERMSG ('SLATEC', 'BESI',
  3125.      +   'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1)
  3126.       RETURN
  3127.   580 CONTINUE
  3128.       CALL XERMSG ('SLATEC', 'BESI', 'ORDER, ALPHA, LESS THAN ZERO.',
  3129.      +   2, 1)
  3130.       RETURN
  3131.   590 CONTINUE
  3132.       CALL XERMSG ('SLATEC', 'BESI', 'N LESS THAN ONE.', 2, 1)
  3133.       RETURN
  3134.   600 CONTINUE
  3135.       CALL XERMSG ('SLATEC', 'BESI', 'X LESS THAN ZERO.', 2, 1)
  3136.       RETURN
  3137.   610 CONTINUE
  3138.       CALL XERMSG ('SLATEC', 'BESI',
  3139.      +   'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1)
  3140.       RETURN
  3141.       END
  3142. *DECK BESI0
  3143.       FUNCTION BESI0 (X)
  3144. C***BEGIN PROLOGUE  BESI0
  3145. C***PURPOSE  Compute the hyperbolic Bessel function of the first kind
  3146. C            of order zero.
  3147. C***LIBRARY   SLATEC (FNLIB)
  3148. C***CATEGORY  C10B1
  3149. C***TYPE      SINGLE PRECISION (BESI0-S, DBESI0-D)
  3150. C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  3151. C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS
  3152. C***AUTHOR  Fullerton, W., (LANL)
  3153. C***DESCRIPTION
  3154. C
  3155. C BESI0(X) computes the modified (hyperbolic) Bessel function
  3156. C of the first kind of order zero and real argument X.
  3157. C
  3158. C Series for BI0        on the interval  0.          to  9.00000D+00
  3159. C                                        with weighted error   2.46E-18
  3160. C                                         log weighted error  17.61
  3161. C                               significant figures required  17.90
  3162. C                                    decimal places required  18.15
  3163. C
  3164. C***REFERENCES  (NONE)
  3165. C***ROUTINES CALLED  BESI0E, CSEVL, INITS, R1MACH, XERMSG
  3166. C***REVISION HISTORY  (YYMMDD)
  3167. C   770401  DATE WRITTEN
  3168. C   890531  Changed all specific intrinsics to generic.  (WRB)
  3169. C   890531  REVISION DATE from Version 3.2
  3170. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  3171. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  3172. C   900326  Removed duplicate information from DESCRIPTION section.
  3173. C           (WRB)
  3174. C***END PROLOGUE  BESI0
  3175.       DIMENSION BI0CS(12)
  3176.       LOGICAL FIRST
  3177.       SAVE BI0CS, NTI0, XSML, XMAX, FIRST
  3178.       DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
  3179.       DATA BI0CS( 2) /   1.9273379539 93808270E0 /
  3180.       DATA BI0CS( 3) /    .2282644586 920301339E0 /
  3181.       DATA BI0CS( 4) /    .0130489146 6707290428E0 /
  3182.       DATA BI0CS( 5) /    .0004344270 9008164874E0 /
  3183.       DATA BI0CS( 6) /    .0000094226 5768600193E0 /
  3184.       DATA BI0CS( 7) /    .0000001434 0062895106E0 /
  3185.       DATA BI0CS( 8) /    .0000000016 1384906966E0 /
  3186.       DATA BI0CS( 9) /    .0000000000 1396650044E0 /
  3187.       DATA BI0CS(10) /    .0000000000 0009579451E0 /
  3188.       DATA BI0CS(11) /    .0000000000 0000053339E0 /
  3189.       DATA BI0CS(12) /    .0000000000 0000000245E0 /
  3190.       DATA FIRST /.TRUE./
  3191. C***FIRST EXECUTABLE STATEMENT  BESI0
  3192.       IF (FIRST) THEN
  3193.          NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
  3194.          XSML = SQRT (4.5*R1MACH(3))
  3195.          XMAX = LOG (R1MACH(2))
  3196.       ENDIF
  3197.       FIRST = .FALSE.
  3198. C
  3199.       Y = ABS(X)
  3200.       IF (Y.GT.3.0) GO TO 20
  3201. C
  3202.       BESI0 = 1.0
  3203.       IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0)
  3204.       RETURN
  3205. C
  3206.  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI0',
  3207.      +   'ABS(X) SO BIG I0 OVERFLOWS', 1, 2)
  3208. C
  3209.       BESI0 = EXP(Y) * BESI0E(X)
  3210. C
  3211.       RETURN
  3212.       END
  3213. *DECK BESI0E
  3214.       FUNCTION BESI0E (X)
  3215. C***BEGIN PROLOGUE  BESI0E
  3216. C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
  3217. C            Bessel function of the first kind of order zero.
  3218. C***LIBRARY   SLATEC (FNLIB)
  3219. C***CATEGORY  C10B1
  3220. C***TYPE      SINGLE PRECISION (BESI0E-S, DBSI0E-D)
  3221. C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
  3222. C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
  3223. C             ORDER ZERO, SPECIAL FUNCTIONS
  3224. C***AUTHOR  Fullerton, W., (LANL)
  3225. C***DESCRIPTION
  3226. C
  3227. C BESI0E(X) calculates the exponentially scaled modified (hyperbolic)
  3228. C Bessel function of the first kind of order zero for real argument X;
  3229. C i.e., EXP(-ABS(X))*I0(X).
  3230. C
  3231. C
  3232. C Series for BI0        on the interval  0.          to  9.00000D+00
  3233. C                                        with weighted error   2.46E-18
  3234. C                                         log weighted error  17.61
  3235. C                               significant figures required  17.90
  3236. C                                    decimal places required  18.15
  3237. C
  3238. C
  3239. C Series for AI0        on the interval  1.25000D-01 to  3.33333D-01
  3240. C                                        with weighted error   7.87E-17
  3241. C                                         log weighted error  16.10
  3242. C                               significant figures required  14.69
  3243. C                                    decimal places required  16.76
  3244. C
  3245. C
  3246. C Series for AI02       on the interval  0.          to  1.25000D-01
  3247. C                                        with weighted error   3.79E-17
  3248. C                                         log weighted error  16.42
  3249. C                               significant figures required  14.86
  3250. C                                    decimal places required  17.09
  3251. C
  3252. C***REFERENCES  (NONE)
  3253. C***ROUTINES CALLED  CSEVL, INITS, R1MACH
  3254. C***REVISION HISTORY  (YYMMDD)
  3255. C   770701  DATE WRITTEN
  3256. C   890313  REVISION DATE from Version 3.2
  3257. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  3258. C***END PROLOGUE  BESI0E
  3259.       DIMENSION BI0CS(12), AI0CS(21), AI02CS(22)
  3260.       LOGICAL FIRST
  3261.       SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST
  3262.       DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
  3263.       DATA BI0CS( 2) /   1.9273379539 93808270E0 /
  3264.       DATA BI0CS( 3) /    .2282644586 920301339E0 /
  3265.       DATA BI0CS( 4) /    .0130489146 6707290428E0 /
  3266.       DATA BI0CS( 5) /    .0004344270 9008164874E0 /
  3267.       DATA BI0CS( 6) /    .0000094226 5768600193E0 /
  3268.       DATA BI0CS( 7) /    .0000001434 0062895106E0 /
  3269.       DATA BI0CS( 8) /    .0000000016 1384906966E0 /
  3270.       DATA BI0CS( 9) /    .0000000000 1396650044E0 /
  3271.       DATA BI0CS(10) /    .0000000000 0009579451E0 /
  3272.       DATA BI0CS(11) /    .0000000000 0000053339E0 /
  3273.       DATA BI0CS(12) /    .0000000000 0000000245E0 /
  3274.       DATA AI0CS( 1) /    .0757599449 4023796E0 /
  3275.       DATA AI0CS( 2) /    .0075913808 1082334E0 /
  3276.       DATA AI0CS( 3) /    .0004153131 3389237E0 /
  3277.       DATA AI0CS( 4) /    .0000107007 6463439E0 /
  3278.       DATA AI0CS( 5) /   -.0000079011 7997921E0 /
  3279.       DATA AI0CS( 6) /   -.0000007826 1435014E0 /
  3280.       DATA AI0CS( 7) /    .0000002783 8499429E0 /
  3281.       DATA AI0CS( 8) /    .0000000082 5247260E0 /
  3282.       DATA AI0CS( 9) /   -.0000000120 4463945E0 /
  3283.       DATA AI0CS(10) /    .0000000015 5964859E0 /
  3284.       DATA AI0CS(11) /    .0000000002 2925563E0 /
  3285.       DATA AI0CS(12) /   -.0000000001 1916228E0 /
  3286.       DATA AI0CS(13) /    .0000000000 1757854E0 /
  3287.       DATA AI0CS(14) /    .0000000000 0112822E0 /
  3288.       DATA AI0CS(15) /   -.0000000000 0114684E0 /
  3289.       DATA AI0CS(16) /    .0000000000 0027155E0 /
  3290.       DATA AI0CS(17) /   -.0000000000 0002415E0 /
  3291.       DATA AI0CS(18) /   -.0000000000 0000608E0 /
  3292.       DATA AI0CS(19) /    .0000000000 0000314E0 /
  3293.       DATA AI0CS(20) /   -.0000000000 0000071E0 /
  3294.       DATA AI0CS(21) /    .0000000000 0000007E0 /
  3295.       DATA AI02CS( 1) /    .0544904110 1410882E0 /
  3296.       DATA AI02CS( 2) /    .0033691164 7825569E0 /
  3297.       DATA AI02CS( 3) /    .0000688975 8346918E0 /
  3298.       DATA AI02CS( 4) /    .0000028913 7052082E0 /
  3299.       DATA AI02CS( 5) /    .0000002048 9185893E0 /
  3300.       DATA AI02CS( 6) /    .0000000226 6668991E0 /
  3301.       DATA AI02CS( 7) /    .0000000033 9623203E0 /
  3302.       DATA AI02CS( 8) /    .0000000004 9406022E0 /
  3303.       DATA AI02CS( 9) /    .0000000000 1188914E0 /
  3304.       DATA AI02CS(10) /   -.0000000000 3149915E0 /
  3305.       DATA AI02CS(11) /   -.0000000000 1321580E0 /
  3306.       DATA AI02CS(12) /   -.0000000000 0179419E0 /
  3307.       DATA AI02CS(13) /    .0000000000 0071801E0 /
  3308.       DATA AI02CS(14) /    .0000000000 0038529E0 /
  3309.       DATA AI02CS(15) /    .0000000000 0001539E0 /
  3310.       DATA AI02CS(16) /   -.0000000000 0004151E0 /
  3311.       DATA AI02CS(17) /   -.0000000000 0000954E0 /
  3312.       DATA AI02CS(18) /    .0000000000 0000382E0 /
  3313.       DATA AI02CS(19) /    .0000000000 0000176E0 /
  3314.       DATA AI02CS(20) /   -.0000000000 0000034E0 /
  3315.       DATA AI02CS(21) /   -.0000000000 0000027E0 /
  3316.       DATA AI02CS(22) /    .0000000000 0000003E0 /
  3317.       DATA FIRST /.TRUE./
  3318. C***FIRST EXECUTABLE STATEMENT  BESI0E
  3319.       IF (FIRST) THEN
  3320.          NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
  3321.          NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3))
  3322.          NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3))
  3323.          XSML = SQRT (4.5*R1MACH(3))
  3324.       ENDIF
  3325.       FIRST = .FALSE.
  3326. C
  3327.       Y = ABS(X)
  3328.       IF (Y.GT.3.0) GO TO 20
  3329. C
  3330.       BESI0E = 1.0 - X
  3331.       IF (Y.GT.XSML) BESI0E = EXP(-Y) * ( 2.75 +
  3332.      1  CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) )
  3333.       RETURN
  3334. C
  3335.  20   IF (Y.LE.8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0)
  3336.      1  ) / SQRT(Y)
  3337.       IF (Y.GT.8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02))
  3338.      1  / SQRT(Y)
  3339. C
  3340.       RETURN
  3341.       END
  3342. *DECK BESI1
  3343.       FUNCTION BESI1 (X)
  3344. C***BEGIN PROLOGUE  BESI1
  3345. C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
  3346. C            first kind of order one.
  3347. C***LIBRARY   SLATEC (FNLIB)
  3348. C***CATEGORY  C10B1
  3349. C***TYPE      SINGLE PRECISION (BESI1-S, DBESI1-D)
  3350. C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  3351. C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
  3352. C***AUTHOR  Fullerton, W., (LANL)
  3353. C***DESCRIPTION
  3354. C
  3355. C BESI1(X) calculates the modified (hyperbolic) Bessel function
  3356. C of the first kind of order one for real argument X.
  3357. C
  3358. C Series for BI1        on the interval  0.          to  9.00000D+00
  3359. C                                        with weighted error   2.40E-17
  3360. C                                         log weighted error  16.62
  3361. C                               significant figures required  16.23
  3362. C                                    decimal places required  17.14
  3363. C
  3364. C***REFERENCES  (NONE)
  3365. C***ROUTINES CALLED  BESI1E, CSEVL, INITS, R1MACH, XERMSG
  3366. C***REVISION HISTORY  (YYMMDD)
  3367. C   770401  DATE WRITTEN
  3368. C   890531  Changed all specific intrinsics to generic.  (WRB)
  3369. C   890531  REVISION DATE from Version 3.2
  3370. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  3371. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  3372. C   900326  Removed duplicate information from DESCRIPTION section.
  3373. C           (WRB)
  3374. C***END PROLOGUE  BESI1
  3375.       DIMENSION BI1CS(11)
  3376.       LOGICAL FIRST
  3377.       SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
  3378.       DATA BI1CS( 1) /   -.0019717132 61099859E0 /
  3379.       DATA BI1CS( 2) /    .4073488766 7546481E0 /
  3380.       DATA BI1CS( 3) /    .0348389942 99959456E0 /
  3381.       DATA BI1CS( 4) /    .0015453945 56300123E0 /
  3382.       DATA BI1CS( 5) /    .0000418885 21098377E0 /
  3383.       DATA BI1CS( 6) /    .0000007649 02676483E0 /
  3384.       DATA BI1CS( 7) /    .0000000100 42493924E0 /
  3385.       DATA BI1CS( 8) /    .0000000000 99322077E0 /
  3386.       DATA BI1CS( 9) /    .0000000000 00766380E0 /
  3387.       DATA BI1CS(10) /    .0000000000 00004741E0 /
  3388.       DATA BI1CS(11) /    .0000000000 00000024E0 /
  3389.       DATA FIRST /.TRUE./
  3390. C***FIRST EXECUTABLE STATEMENT  BESI1
  3391.       IF (FIRST) THEN
  3392.          NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
  3393.          XMIN = 2.0*R1MACH(1)
  3394.          XSML = SQRT (4.5*R1MACH(3))
  3395.          XMAX = LOG (R1MACH(2))
  3396.       ENDIF
  3397.       FIRST = .FALSE.
  3398. C
  3399.       Y = ABS(X)
  3400.       IF (Y.GT.3.0) GO TO 20
  3401. C
  3402.       BESI1 = 0.0
  3403.       IF (Y.EQ.0.0)  RETURN
  3404. C
  3405.       IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1',
  3406.      +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
  3407.       IF (Y.GT.XMIN) BESI1 = 0.5*X
  3408.       IF (Y.GT.XSML) BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1))
  3409.       RETURN
  3410. C
  3411.  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI1',
  3412.      +   'ABS(X) SO BIG I1 OVERFLOWS', 2, 2)
  3413. C
  3414.       BESI1 = EXP(Y) * BESI1E(X)
  3415. C
  3416.       RETURN
  3417.       END
  3418. *DECK BESI1E
  3419.       FUNCTION BESI1E (X)
  3420. C***BEGIN PROLOGUE  BESI1E
  3421. C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
  3422. C            Bessel function of the first kind of order one.
  3423. C***LIBRARY   SLATEC (FNLIB)
  3424. C***CATEGORY  C10B1
  3425. C***TYPE      SINGLE PRECISION (BESI1E-S, DBSI1E-D)
  3426. C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
  3427. C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
  3428. C             ORDER ONE, SPECIAL FUNCTIONS
  3429. C***AUTHOR  Fullerton, W., (LANL)
  3430. C***DESCRIPTION
  3431. C
  3432. C BESI1E(X) calculates the exponentially scaled modified (hyperbolic)
  3433. C Bessel function of the first kind of order one for real argument X;
  3434. C i.e., EXP(-ABS(X))*I1(X).
  3435. C
  3436. C Series for BI1        on the interval  0.          to  9.00000D+00
  3437. C                                        with weighted error   2.40E-17
  3438. C                                         log weighted error  16.62
  3439. C                               significant figures required  16.23
  3440. C                                    decimal places required  17.14
  3441. C
  3442. C Series for AI1        on the interval  1.25000D-01 to  3.33333D-01
  3443. C                                        with weighted error   6.98E-17
  3444. C                                         log weighted error  16.16
  3445. C                               significant figures required  14.53
  3446. C                                    decimal places required  16.82
  3447. C
  3448. C Series for AI12       on the interval  0.          to  1.25000D-01
  3449. C                                        with weighted error   3.55E-17
  3450. C                                         log weighted error  16.45
  3451. C                               significant figures required  14.69
  3452. C                                    decimal places required  17.12
  3453. C
  3454. C***REFERENCES  (NONE)
  3455. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  3456. C***REVISION HISTORY  (YYMMDD)
  3457. C   770401  DATE WRITTEN
  3458. C   890210  REVISION DATE from Version 3.2
  3459. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  3460. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  3461. C   900326  Removed duplicate information from DESCRIPTION section.
  3462. C           (WRB)
  3463. C   920618  Removed space from variable names.  (RWC, WRB)
  3464. C***END PROLOGUE  BESI1E
  3465.       DIMENSION BI1CS(11), AI1CS(21), AI12CS(22)
  3466.       LOGICAL FIRST
  3467.       SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST
  3468.       DATA BI1CS( 1) /   -.0019717132 61099859E0 /
  3469.       DATA BI1CS( 2) /    .4073488766 7546481E0 /
  3470.       DATA BI1CS( 3) /    .0348389942 99959456E0 /
  3471.       DATA BI1CS( 4) /    .0015453945 56300123E0 /
  3472.       DATA BI1CS( 5) /    .0000418885 21098377E0 /
  3473.       DATA BI1CS( 6) /    .0000007649 02676483E0 /
  3474.       DATA BI1CS( 7) /    .0000000100 42493924E0 /
  3475.       DATA BI1CS( 8) /    .0000000000 99322077E0 /
  3476.       DATA BI1CS( 9) /    .0000000000 00766380E0 /
  3477.       DATA BI1CS(10) /    .0000000000 00004741E0 /
  3478.       DATA BI1CS(11) /    .0000000000 00000024E0 /
  3479.       DATA AI1CS( 1) /   -.0284674418 1881479E0 /
  3480.       DATA AI1CS( 2) /   -.0192295323 1443221E0 /
  3481.       DATA AI1CS( 3) /   -.0006115185 8579437E0 /
  3482.       DATA AI1CS( 4) /   -.0000206997 1253350E0 /
  3483.       DATA AI1CS( 5) /    .0000085856 1914581E0 /
  3484.       DATA AI1CS( 6) /    .0000010494 9824671E0 /
  3485.       DATA AI1CS( 7) /   -.0000002918 3389184E0 /
  3486.       DATA AI1CS( 8) /   -.0000000155 9378146E0 /
  3487.       DATA AI1CS( 9) /    .0000000131 8012367E0 /
  3488.       DATA AI1CS(10) /   -.0000000014 4842341E0 /
  3489.       DATA AI1CS(11) /   -.0000000002 9085122E0 /
  3490.       DATA AI1CS(12) /    .0000000001 2663889E0 /
  3491.       DATA AI1CS(13) /   -.0000000000 1664947E0 /
  3492.       DATA AI1CS(14) /   -.0000000000 0166665E0 /
  3493.       DATA AI1CS(15) /    .0000000000 0124260E0 /
  3494.       DATA AI1CS(16) /   -.0000000000 0027315E0 /
  3495.       DATA AI1CS(17) /    .0000000000 0002023E0 /
  3496.       DATA AI1CS(18) /    .0000000000 0000730E0 /
  3497.       DATA AI1CS(19) /   -.0000000000 0000333E0 /
  3498.       DATA AI1CS(20) /    .0000000000 0000071E0 /
  3499.       DATA AI1CS(21) /   -.0000000000 0000006E0 /
  3500.       DATA AI12CS( 1) /    .0285762350 1828014E0 /
  3501.       DATA AI12CS( 2) /   -.0097610974 9136147E0 /
  3502.       DATA AI12CS( 3) /   -.0001105889 3876263E0 /
  3503.       DATA AI12CS( 4) /   -.0000038825 6480887E0 /
  3504.       DATA AI12CS( 5) /   -.0000002512 2362377E0 /
  3505.       DATA AI12CS( 6) /   -.0000000263 1468847E0 /
  3506.       DATA AI12CS( 7) /   -.0000000038 3538039E0 /
  3507.       DATA AI12CS( 8) /   -.0000000005 5897433E0 /
  3508.       DATA AI12CS( 9) /   -.0000000000 1897495E0 /
  3509.       DATA AI12CS(10) /    .0000000000 3252602E0 /
  3510.       DATA AI12CS(11) /    .0000000000 1412580E0 /
  3511.       DATA AI12CS(12) /    .0000000000 0203564E0 /
  3512.       DATA AI12CS(13) /   -.0000000000 0071985E0 /
  3513.       DATA AI12CS(14) /   -.0000000000 0040836E0 /
  3514.       DATA AI12CS(15) /   -.0000000000 0002101E0 /
  3515.       DATA AI12CS(16) /    .0000000000 0004273E0 /
  3516.       DATA AI12CS(17) /    .0000000000 0001041E0 /
  3517.       DATA AI12CS(18) /   -.0000000000 0000382E0 /
  3518.       DATA AI12CS(19) /   -.0000000000 0000186E0 /
  3519.       DATA AI12CS(20) /    .0000000000 0000033E0 /
  3520.       DATA AI12CS(21) /    .0000000000 0000028E0 /
  3521.       DATA AI12CS(22) /   -.0000000000 0000003E0 /
  3522.       DATA FIRST /.TRUE./
  3523. C***FIRST EXECUTABLE STATEMENT  BESI1E
  3524.       IF (FIRST) THEN
  3525.          NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
  3526.          NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3))
  3527.          NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3))
  3528. C
  3529.          XMIN = 2.0*R1MACH(1)
  3530.          XSML = SQRT (4.5*R1MACH(3))
  3531.       ENDIF
  3532.       FIRST = .FALSE.
  3533. C
  3534.       Y = ABS(X)
  3535.       IF (Y.GT.3.0) GO TO 20
  3536. C
  3537.       BESI1E = 0.0
  3538.       IF (Y.EQ.0.0)  RETURN
  3539. C
  3540.       IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1E',
  3541.      +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
  3542.       IF (Y.GT.XMIN) BESI1E = 0.5*X
  3543.       IF (Y.GT.XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1))
  3544.       BESI1E = EXP(-Y) * BESI1E
  3545.       RETURN
  3546. C
  3547.  20   IF (Y.LE.8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1)
  3548.      1  ) / SQRT(Y)
  3549.       IF (Y.GT.8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12))
  3550.      1  / SQRT(Y)
  3551.       BESI1E = SIGN (BESI1E, X)
  3552. C
  3553.       RETURN
  3554.       END
  3555. *DECK BESJ
  3556.       SUBROUTINE BESJ (X, ALPHA, N, Y, NZ)
  3557. C***BEGIN PROLOGUE  BESJ
  3558. C***PURPOSE  Compute an N member sequence of J Bessel functions
  3559. C            J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
  3560. C            and X.
  3561. C***LIBRARY   SLATEC
  3562. C***CATEGORY  C10A3
  3563. C***TYPE      SINGLE PRECISION (BESJ-S, DBESJ-D)
  3564. C***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
  3565. C***AUTHOR  Amos, D. E., (SNLA)
  3566. C           Daniel, S. L., (SNLA)
  3567. C           Weston, M. K., (SNLA)
  3568. C***DESCRIPTION
  3569. C
  3570. C     Abstract
  3571. C         BESJ computes an N member sequence of J Bessel functions
  3572. C         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
  3573. C         A combination of the power series, the asymptotic expansion
  3574. C         for X to infinity and the uniform asymptotic expansion for
  3575. C         NU to infinity are applied over subdivisions of the (NU,X)
  3576. C         plane.  For values of (NU,X) not covered by one of these
  3577. C         formulae, the order is incremented or decremented by integer
  3578. C         values into a region where one of the formulae apply. Backward
  3579. C         recursion is applied to reduce orders by integer values except
  3580. C         where the entire sequence lies in the oscillatory region.  In
  3581. C         this case forward recursion is stable and values from the
  3582. C         asymptotic expansion for X to infinity start the recursion
  3583. C         when it is efficient to do so.  Leading terms of the series
  3584. C         and uniform expansion are tested for underflow.  If a sequence
  3585. C         is requested and the last member would underflow, the result
  3586. C         is set to zero and the next lower order tried, etc., until a
  3587. C         member comes on scale or all members are set to zero.
  3588. C         Overflow cannot occur.
  3589. C
  3590. C     Description of Arguments
  3591. C
  3592. C         Input
  3593. C           X      - X .GE. 0.0E0
  3594. C           ALPHA  - order of first member of the sequence,
  3595. C                    ALPHA .GE. 0.0E0
  3596. C           N      - number of members in the sequence, N .GE. 1
  3597. C
  3598. C         Output
  3599. C           Y      - a vector whose first  N components contain
  3600. C                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
  3601. C           NZ     - number of components of Y set to zero due to
  3602. C                    underflow,
  3603. C                    NZ=0   , normal return, computation completed
  3604. C                    NZ .NE. 0, last NZ components of Y set to zero,
  3605. C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
  3606. C
  3607. C     Error Conditions
  3608. C         Improper input arguments - a fatal error
  3609. C         Underflow  - a non-fatal error (NZ .NE. 0)
  3610. C
  3611. C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
  3612. C                 subroutines IBESS and JBESS for Bessel functions
  3613. C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
  3614. C                 Transactions on Mathematical Software 3, (1977),
  3615. C                 pp. 76-92.
  3616. C               F. W. J. Olver, Tables of Bessel Functions of Moderate
  3617. C                 or Large Orders, NPL Mathematical Tables 6, Her
  3618. C                 Majesty's Stationery Office, London, 1962.
  3619. C***ROUTINES CALLED  ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG
  3620. C***REVISION HISTORY  (YYMMDD)
  3621. C   750101  DATE WRITTEN
  3622. C   890531  Changed all specific intrinsics to generic.  (WRB)
  3623. C   890531  REVISION DATE from Version 3.2
  3624. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  3625. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  3626. C   900326  Removed duplicate information from DESCRIPTION section.
  3627. C           (WRB)
  3628. C   920501  Reformatted the REFERENCES section.  (WRB)
  3629. C***END PROLOGUE  BESJ
  3630.       EXTERNAL JAIRY
  3631.       INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN,
  3632.      1        NS,NZ
  3633.       INTEGER I1MACH
  3634.       REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG,
  3635.      1           ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM,
  3636.      2           GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN,
  3637.      3           S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL,
  3638.      4           TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM
  3639.       SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
  3640.       REAL R1MACH, ALNGAM
  3641.       DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
  3642.       DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00,
  3643.      1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
  3644.       DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00,
  3645.      1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
  3646.       DATA INLIM           /      150            /
  3647.       DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
  3648. C***FIRST EXECUTABLE STATEMENT  BESJ
  3649.       NZ = 0
  3650.       KT = 1
  3651.       NS=0
  3652. C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
  3653. C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
  3654.       TA = R1MACH(3)
  3655.       TOL = MAX(TA,1.0E-15)
  3656.       I1 = I1MACH(11) + 1
  3657.       I2 = I1MACH(12)
  3658.       TB = R1MACH(5)
  3659.       ELIM1 = -2.303E0*(I2*TB+3.0E0)
  3660.       RTOL=1.0E0/TOL
  3661.       SLIM=R1MACH(1)*1.0E+3*RTOL
  3662. C     TOLLN = -LN(TOL)
  3663.       TOLLN = 2.303E0*TB*I1
  3664.       TOLLN = MIN(TOLLN,34.5388E0)
  3665.       IF (N-1) 720, 10, 20
  3666.    10 KT = 2
  3667.    20 NN = N
  3668.       IF (X) 730, 30, 80
  3669.    30 IF (ALPHA) 710, 40, 50
  3670.    40 Y(1) = 1.0E0
  3671.       IF (N.EQ.1) RETURN
  3672.       I1 = 2
  3673.       GO TO 60
  3674.    50 I1 = 1
  3675.    60 DO 70 I=I1,N
  3676.         Y(I) = 0.0E0
  3677.    70 CONTINUE
  3678.       RETURN
  3679.    80 CONTINUE
  3680.       IF (ALPHA.LT.0.0E0) GO TO 710
  3681. C
  3682.       IALP = INT(ALPHA)
  3683.       FNI = IALP + N - 1
  3684.       FNF = ALPHA - IALP
  3685.       DFN = FNI + FNF
  3686.       FNU = DFN
  3687.       XO2 = X*0.5E0
  3688.       SXO2 = XO2*XO2
  3689. C
  3690. C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
  3691. C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
  3692. C     APPLIED.
  3693. C
  3694.       IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
  3695.       TA = MAX(20.0E0,FNU)
  3696.       IF (X.GT.TA) GO TO 120
  3697.       IF (X.GT.12.0E0) GO TO 110
  3698.       XO2L = LOG(XO2)
  3699.       NS = INT(SXO2-FNU) + 1
  3700.       GO TO 100
  3701.    90 FN = FNU
  3702.       FNP1 = FN + 1.0E0
  3703.       XO2L = LOG(XO2)
  3704.       IS = KT
  3705.       IF (X.LE.0.50E0) GO TO 330
  3706.       NS = 0
  3707.   100 FNI = FNI + NS
  3708.       DFN = FNI + FNF
  3709.       FN = DFN
  3710.       FNP1 = FN + 1.0E0
  3711.       IS = KT
  3712.       IF (N-1+NS.GT.0) IS = 3
  3713.       GO TO 330
  3714.   110 ANS = MAX(36.0E0-FNU,0.0E0)
  3715.       NS = INT(ANS)
  3716.       FNI = FNI + NS
  3717.       DFN = FNI + FNF
  3718.       FN = DFN
  3719.       IS = KT
  3720.       IF (N-1+NS.GT.0) IS = 3
  3721.       GO TO 130
  3722.   120 CONTINUE
  3723.       RTX = SQRT(X)
  3724.       TAU = RTWO*RTX
  3725.       TA = TAU + FNULIM(KT)
  3726.       IF (FNU.LE.TA) GO TO 480
  3727.       FN = FNU
  3728.       IS = KT
  3729. C
  3730. C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
  3731. C
  3732.   130 CONTINUE
  3733.       I1 = ABS(3-IS)
  3734.       I1 = MAX(I1,1)
  3735.       FLGJY = 1.0E0
  3736.       CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
  3737.       IF(IFLW.NE.0) GO TO 380
  3738.       GO TO (320, 450, 620), IS
  3739.   310 TEMP(1) = TEMP(3)
  3740.       KT = 1
  3741.   320 IS = 2
  3742.       FNI = FNI - 1.0E0
  3743.       DFN = FNI + FNF
  3744.       FN = DFN
  3745.       IF(I1.EQ.2) GO TO 450
  3746.       GO TO 130
  3747. C
  3748. C     SERIES FOR (X/2)**2.LE.NU+1
  3749. C
  3750.   330 CONTINUE
  3751.       GLN = ALNGAM(FNP1)
  3752.       ARG = FN*XO2L - GLN
  3753.       IF (ARG.LT.(-ELIM1)) GO TO 400
  3754.       EARG = EXP(ARG)
  3755.   340 CONTINUE
  3756.       S = 1.0E0
  3757.       IF (X.LT.TOL) GO TO 360
  3758.       AK = 3.0E0
  3759.       T2 = 1.0E0
  3760.       T = 1.0E0
  3761.       S1 = FN
  3762.       DO 350 K=1,17
  3763.         S2 = T2 + S1
  3764.         T = -T*SXO2/S2
  3765.         S = S + T
  3766.         IF (ABS(T).LT.TOL) GO TO 360
  3767.         T2 = T2 + AK
  3768.         AK = AK + 2.0E0
  3769.         S1 = S1 + FN
  3770.   350 CONTINUE
  3771.   360 CONTINUE
  3772.       TEMP(IS) = S*EARG
  3773.       GO TO (370, 450, 610), IS
  3774.   370 EARG = EARG*FN/XO2
  3775.       FNI = FNI - 1.0E0
  3776.       DFN = FNI + FNF
  3777.       FN = DFN
  3778.       IS = 2
  3779.       GO TO 340
  3780. C
  3781. C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
  3782. C     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE
  3783. C     LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED.
  3784. C
  3785.   380 Y(NN) = 0.0E0
  3786.       NN = NN - 1
  3787.       FNI = FNI - 1.0E0
  3788.       DFN = FNI + FNF
  3789.       FN = DFN
  3790.       IF (NN-1) 440, 390, 130
  3791.   390 KT = 2
  3792.       IS = 2
  3793.       GO TO 130
  3794.   400 Y(NN) = 0.0E0
  3795.       NN = NN - 1
  3796.       FNP1 = FN
  3797.       FNI = FNI - 1.0E0
  3798.       DFN = FNI + FNF
  3799.       FN = DFN
  3800.       IF (NN-1) 440, 410, 420
  3801.   410 KT = 2
  3802.       IS = 2
  3803.   420 IF (SXO2.LE.FNP1) GO TO 430
  3804.       GO TO 130
  3805.   430 ARG = ARG - XO2L + LOG(FNP1)
  3806.       IF (ARG.LT.(-ELIM1)) GO TO 400
  3807.       GO TO 330
  3808.   440 NZ = N - NN
  3809.       RETURN
  3810. C
  3811. C     BACKWARD RECURSION SECTION
  3812. C
  3813.   450 CONTINUE
  3814.       IF(NS.NE.0) GO TO 451
  3815.       NZ = N - NN
  3816.       IF (KT.EQ.2) GO TO 470
  3817. C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
  3818.       Y(NN) = TEMP(1)
  3819.       Y(NN-1) = TEMP(2)
  3820.       IF (NN.EQ.2) RETURN
  3821.   451 CONTINUE
  3822.       TRX = 2.0E0/X
  3823.       DTM = FNI
  3824.       TM = (DTM+FNF)*TRX
  3825.       AK=1.0E0
  3826.       TA=TEMP(1)
  3827.       TB=TEMP(2)
  3828.       IF(ABS(TA).GT.SLIM) GO TO 455
  3829.       TA=TA*RTOL
  3830.       TB=TB*RTOL
  3831.       AK=TOL
  3832.   455 CONTINUE
  3833.       KK=2
  3834.       IN=NS-1
  3835.       IF(IN.EQ.0) GO TO 690
  3836.       IF(NS.NE.0) GO TO 670
  3837.       K=NN-2
  3838.       DO 460 I=3,NN
  3839.         S=TB
  3840.         TB=TM*TB-TA
  3841.         TA=S
  3842.         Y(K)=TB*AK
  3843.         K=K-1
  3844.         DTM = DTM - 1.0E0
  3845.         TM = (DTM+FNF)*TRX
  3846.   460 CONTINUE
  3847.       RETURN
  3848.   470 Y(1) = TEMP(2)
  3849.       RETURN
  3850. C
  3851. C     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
  3852. C     OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER
  3853. C     OF THE SEQUENCE IS ALSO IN THE REGION.
  3854. C
  3855.   480 CONTINUE
  3856.       IN = INT(ALPHA-TAU+2.0E0)
  3857.       IF (IN.LE.0) GO TO 490
  3858.       IDALP = IALP - IN - 1
  3859.       KT = 1
  3860.       GO TO 500
  3861.   490 CONTINUE
  3862.       IDALP = IALP
  3863.       IN = 0
  3864.   500 IS = KT
  3865.       FIDAL = IDALP
  3866.       DALPHA = FIDAL + FNF
  3867.       ARG = X - PIDT*DALPHA - PDF
  3868.       SA = SIN(ARG)
  3869.       SB = COS(ARG)
  3870.       COEF = RTTP/RTX
  3871.       ETX = 8.0E0*X
  3872.   510 CONTINUE
  3873.       DTM = FIDAL + FIDAL
  3874.       DTM = DTM*DTM
  3875.       TM = 0.0E0
  3876.       IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520
  3877.       TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  3878.   520 CONTINUE
  3879.       TRX = DTM - 1.0E0
  3880.       T2 = (TRX+TM)/ETX
  3881.       S2 = T2
  3882.       RELB = TOL*ABS(T2)
  3883.       T1 = ETX
  3884.       S1 = 1.0E0
  3885.       FN = 1.0E0
  3886.       AK = 8.0E0
  3887.       DO 530 K=1,13
  3888.         T1 = T1 + ETX
  3889.         FN = FN + AK
  3890.         TRX = DTM - FN
  3891.         AP = TRX + TM
  3892.         T2 = -T2*AP/T1
  3893.         S1 = S1 + T2
  3894.         T1 = T1 + ETX
  3895.         AK = AK + 8.0E0
  3896.         FN = FN + AK
  3897.         TRX = DTM - FN
  3898.         AP = TRX + TM
  3899.         T2 = T2*AP/T1
  3900.         S2 = S2 + T2
  3901.         IF (ABS(T2).LE.RELB) GO TO 540
  3902.         AK = AK + 8.0E0
  3903.   530 CONTINUE
  3904.   540 TEMP(IS) = COEF*(S1*SB-S2*SA)
  3905.       IF(IS.EQ.2) GO TO 560
  3906.       FIDAL = FIDAL + 1.0E0
  3907.       DALPHA = FIDAL + FNF
  3908.       IS = 2
  3909.       TB = SA
  3910.       SA = -SB
  3911.       SB = TB
  3912.       GO TO 510
  3913. C
  3914. C     FORWARD RECURSION SECTION
  3915. C
  3916.   560 IF (KT.EQ.2) GO TO 470
  3917.       S1 = TEMP(1)
  3918.       S2 = TEMP(2)
  3919.       TX = 2.0E0/X
  3920.       TM = DALPHA*TX
  3921.       IF (IN.EQ.0) GO TO 580
  3922. C
  3923. C     FORWARD RECUR TO INDEX ALPHA
  3924. C
  3925.       DO 570 I=1,IN
  3926.         S = S2
  3927.         S2 = TM*S2 - S1
  3928.         TM = TM + TX
  3929.         S1 = S
  3930.   570 CONTINUE
  3931.       IF (NN.EQ.1) GO TO 600
  3932.       S = S2
  3933.       S2 = TM*S2 - S1
  3934.       TM = TM + TX
  3935.       S1 = S
  3936.   580 CONTINUE
  3937. C
  3938. C     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
  3939. C
  3940.       Y(1) = S1
  3941.       Y(2) = S2
  3942.       IF (NN.EQ.2) RETURN
  3943.       DO 590 I=3,NN
  3944.         Y(I) = TM*Y(I-1) - Y(I-2)
  3945.         TM = TM + TX
  3946.   590 CONTINUE
  3947.       RETURN
  3948.   600 Y(1) = S2
  3949.       RETURN
  3950. C
  3951. C     BACKWARD RECURSION WITH NORMALIZATION BY
  3952. C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
  3953. C
  3954.   610 CONTINUE
  3955. C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
  3956.       AKM = MAX(3.0E0-FN,0.0E0)
  3957.       KM = INT(AKM)
  3958.       TFN = FN + KM
  3959.       TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
  3960.       TA = XO2L - TA
  3961.       TB = -(1.0E0-1.5E0/TFN)/TFN
  3962.       AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
  3963.       IN = KM + INT(AKM)
  3964.       GO TO 660
  3965.   620 CONTINUE
  3966. C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
  3967.       GLN = WK(3) + WK(2)
  3968.       IF (WK(6).GT.30.0E0) GO TO 640
  3969.       RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
  3970.       RZDEN = PP(1) + PP(2)*WK(6)
  3971.       TA = RZDEN/RDEN
  3972.       IF (WK(1).LT.0.10E0) GO TO 630
  3973.       TB = GLN/WK(5)
  3974.       GO TO 650
  3975.   630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1))
  3976.      1 /WK(7)
  3977.       GO TO 650
  3978.   640 CONTINUE
  3979.       TA = 0.5E0*TOLLN/WK(4)
  3980.       TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
  3981.       IF (WK(1).LT.0.10E0) GO TO 630
  3982.       TB = GLN/WK(5)
  3983.   650 IN = INT(TA/TB+1.5E0)
  3984.       IF (IN.GT.INLIM) GO TO 310
  3985.   660 CONTINUE
  3986.       DTM = FNI + IN
  3987.       TRX = 2.0E0/X
  3988.       TM = (DTM+FNF)*TRX
  3989.       TA = 0.0E0
  3990.       TB = TOL
  3991.       KK = 1
  3992.       AK=1.0E0
  3993.   670 CONTINUE
  3994. C
  3995. C     BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO
  3996. C     UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL)
  3997. C
  3998.       DO 680 I=1,IN
  3999.         S = TB
  4000.         TB = TM*TB - TA
  4001.         TA = S
  4002.         DTM = DTM - 1.0E0
  4003.         TM = (DTM+FNF)*TRX
  4004.   680 CONTINUE
  4005. C     NORMALIZATION
  4006.       IF (KK.NE.1) GO TO 690
  4007.       S=TEMP(3)
  4008.       SA=TA/TB
  4009.       TA=S
  4010.       TB=S
  4011.       IF(ABS(S).GT.SLIM) GO TO 685
  4012.       TA=TA*RTOL
  4013.       TB=TB*RTOL
  4014.       AK=TOL
  4015.   685 CONTINUE
  4016.       TA=TA*SA
  4017.       KK = 2
  4018.       IN = NS
  4019.       IF (NS.NE.0) GO TO 670
  4020.   690 Y(NN) = TB*AK
  4021.       NZ = N - NN
  4022.       IF (NN.EQ.1) RETURN
  4023.       K = NN - 1
  4024.       S=TB
  4025.       TB = TM*TB - TA
  4026.       TA=S
  4027.       Y(K)=TB*AK
  4028.       IF (NN.EQ.2) RETURN
  4029.       DTM = DTM - 1.0E0
  4030.       TM = (DTM+FNF)*TRX
  4031.       K=NN-2
  4032. C
  4033. C     BACKWARD RECUR INDEXED
  4034. C
  4035.       DO 700 I=3,NN
  4036.         S=TB
  4037.         TB = TM*TB - TA
  4038.         TA=S
  4039.         Y(K)=TB*AK
  4040.         DTM = DTM - 1.0E0
  4041.         TM = (DTM+FNF)*TRX
  4042.         K = K - 1
  4043.   700 CONTINUE
  4044.       RETURN
  4045. C
  4046. C
  4047. C
  4048.   710 CONTINUE
  4049.       CALL XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.',
  4050.      +   2, 1)
  4051.       RETURN
  4052.   720 CONTINUE
  4053.       CALL XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1)
  4054.       RETURN
  4055.   730 CONTINUE
  4056.       CALL XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1)
  4057.       RETURN
  4058.       END
  4059. *DECK BESJ0
  4060.       FUNCTION BESJ0 (X)
  4061. C***BEGIN PROLOGUE  BESJ0
  4062. C***PURPOSE  Compute the Bessel function of the first kind of order
  4063. C            zero.
  4064. C***LIBRARY   SLATEC (FNLIB)
  4065. C***CATEGORY  C10A1
  4066. C***TYPE      SINGLE PRECISION (BESJ0-S, DBESJ0-D)
  4067. C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO,
  4068. C             SPECIAL FUNCTIONS
  4069. C***AUTHOR  Fullerton, W., (LANL)
  4070. C***DESCRIPTION
  4071. C
  4072. C BESJ0(X) calculates the Bessel function of the first kind of
  4073. C order zero for real argument X.
  4074. C
  4075. C Series for BJ0        on the interval  0.          to  1.60000D+01
  4076. C                                        with weighted error   7.47E-18
  4077. C                                         log weighted error  17.13
  4078. C                               significant figures required  16.98
  4079. C                                    decimal places required  17.68
  4080. C
  4081. C Series for BM0        on the interval  0.          to  6.25000D-02
  4082. C                                        with weighted error   4.98E-17
  4083. C                                         log weighted error  16.30
  4084. C                               significant figures required  14.97
  4085. C                                    decimal places required  16.96
  4086. C
  4087. C Series for BTH0       on the interval  0.          to  6.25000D-02
  4088. C                                        with weighted error   3.67E-17
  4089. C                                         log weighted error  16.44
  4090. C                               significant figures required  15.53
  4091. C                                    decimal places required  17.13
  4092. C
  4093. C***REFERENCES  (NONE)
  4094. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  4095. C***REVISION HISTORY  (YYMMDD)
  4096. C   770401  DATE WRITTEN
  4097. C   890210  REVISION DATE from Version 3.2
  4098. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4099. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4100. C   900326  Removed duplicate information from DESCRIPTION section.
  4101. C           (WRB)
  4102. C***END PROLOGUE  BESJ0
  4103.       DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24)
  4104.       LOGICAL FIRST
  4105.       SAVE BJ0CS, BM0CS, BTH0CS, PI4, NTJ0, NTM0, NTTH0, XSML, XMAX,
  4106.      1   FIRST
  4107.       DATA BJ0CS( 1) /    .1002541619 68939137E0 /
  4108.       DATA BJ0CS( 2) /   -.6652230077 64405132E0 /
  4109.       DATA BJ0CS( 3) /    .2489837034 98281314E0 /
  4110.       DATA BJ0CS( 4) /   -.0332527231 700357697E0 /
  4111.       DATA BJ0CS( 5) /    .0023114179 304694015E0 /
  4112.       DATA BJ0CS( 6) /   -.0000991127 741995080E0 /
  4113.       DATA BJ0CS( 7) /    .0000028916 708643998E0 /
  4114.       DATA BJ0CS( 8) /   -.0000000612 108586630E0 /
  4115.       DATA BJ0CS( 9) /    .0000000009 838650793E0 /
  4116.       DATA BJ0CS(10) /   -.0000000000 124235515E0 /
  4117.       DATA BJ0CS(11) /    .0000000000 001265433E0 /
  4118.       DATA BJ0CS(12) /   -.0000000000 000010619E0 /
  4119.       DATA BJ0CS(13) /    .0000000000 000000074E0 /
  4120.       DATA BM0CS( 1) /    .0928496163 7381644E0 /
  4121.       DATA BM0CS( 2) /   -.0014298770 7403484E0 /
  4122.       DATA BM0CS( 3) /    .0000283057 9271257E0 /
  4123.       DATA BM0CS( 4) /   -.0000014330 0611424E0 /
  4124.       DATA BM0CS( 5) /    .0000001202 8628046E0 /
  4125.       DATA BM0CS( 6) /   -.0000000139 7113013E0 /
  4126.       DATA BM0CS( 7) /    .0000000020 4076188E0 /
  4127.       DATA BM0CS( 8) /   -.0000000003 5399669E0 /
  4128.       DATA BM0CS( 9) /    .0000000000 7024759E0 /
  4129.       DATA BM0CS(10) /   -.0000000000 1554107E0 /
  4130.       DATA BM0CS(11) /    .0000000000 0376226E0 /
  4131.       DATA BM0CS(12) /   -.0000000000 0098282E0 /
  4132.       DATA BM0CS(13) /    .0000000000 0027408E0 /
  4133.       DATA BM0CS(14) /   -.0000000000 0008091E0 /
  4134.       DATA BM0CS(15) /    .0000000000 0002511E0 /
  4135.       DATA BM0CS(16) /   -.0000000000 0000814E0 /
  4136.       DATA BM0CS(17) /    .0000000000 0000275E0 /
  4137.       DATA BM0CS(18) /   -.0000000000 0000096E0 /
  4138.       DATA BM0CS(19) /    .0000000000 0000034E0 /
  4139.       DATA BM0CS(20) /   -.0000000000 0000012E0 /
  4140.       DATA BM0CS(21) /    .0000000000 0000004E0 /
  4141.       DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
  4142.       DATA BTH0CS( 2) /    .0017370983 07508963E0 /
  4143.       DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
  4144.       DATA BTH0CS( 4) /    .0000043680 50165742E0 /
  4145.       DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
  4146.       DATA BTH0CS( 6) /    .0000000621 97400101E0 /
  4147.       DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
  4148.       DATA BTH0CS( 8) /    .0000000019 79526776E0 /
  4149.       DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
  4150.       DATA BTH0CS(10) /    .0000000001 02035840E0 /
  4151.       DATA BTH0CS(11) /   -.0000000000 26363898E0 /
  4152.       DATA BTH0CS(12) /    .0000000000 07297935E0 /
  4153.       DATA BTH0CS(13) /   -.0000000000 02144188E0 /
  4154.       DATA BTH0CS(14) /    .0000000000 00663693E0 /
  4155.       DATA BTH0CS(15) /   -.0000000000 00215126E0 /
  4156.       DATA BTH0CS(16) /    .0000000000 00072659E0 /
  4157.       DATA BTH0CS(17) /   -.0000000000 00025465E0 /
  4158.       DATA BTH0CS(18) /    .0000000000 00009229E0 /
  4159.       DATA BTH0CS(19) /   -.0000000000 00003448E0 /
  4160.       DATA BTH0CS(20) /    .0000000000 00001325E0 /
  4161.       DATA BTH0CS(21) /   -.0000000000 00000522E0 /
  4162.       DATA BTH0CS(22) /    .0000000000 00000210E0 /
  4163.       DATA BTH0CS(23) /   -.0000000000 00000087E0 /
  4164.       DATA BTH0CS(24) /    .0000000000 00000036E0 /
  4165.       DATA PI4 / 0.7853981633 9744831E0 /
  4166.       DATA FIRST /.TRUE./
  4167. C***FIRST EXECUTABLE STATEMENT  BESJ0
  4168.       IF (FIRST) THEN
  4169.          NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3))
  4170.          NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
  4171.          NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
  4172. C
  4173.          XSML = SQRT (8.0*R1MACH(3))
  4174.          XMAX = 1.0/R1MACH(4)
  4175.       ENDIF
  4176.       FIRST = .FALSE.
  4177. C
  4178.       Y = ABS(X)
  4179.       IF (Y.GT.4.0) GO TO 20
  4180. C
  4181.       BESJ0 = 1.0
  4182.       IF (Y.GT.XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0)
  4183.       RETURN
  4184. C
  4185.  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ0',
  4186.      +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 1, 2)
  4187. C
  4188.       Z = 32.0/Y**2 - 1.0
  4189.       AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y)
  4190.       THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y
  4191.       BESJ0 = AMPL * COS (THETA)
  4192. C
  4193.       RETURN
  4194.       END
  4195. *DECK BESJ1
  4196.       FUNCTION BESJ1 (X)
  4197. C***BEGIN PROLOGUE  BESJ1
  4198. C***PURPOSE  Compute the Bessel function of the first kind of order one.
  4199. C***LIBRARY   SLATEC (FNLIB)
  4200. C***CATEGORY  C10A1
  4201. C***TYPE      SINGLE PRECISION (BESJ1-S, DBESJ1-D)
  4202. C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
  4203. C             SPECIAL FUNCTIONS
  4204. C***AUTHOR  Fullerton, W., (LANL)
  4205. C***DESCRIPTION
  4206. C
  4207. C BESJ1(X) calculates the Bessel function of the first kind of
  4208. C order one for real argument X.
  4209. C
  4210. C Series for BJ1        on the interval  0.          to  1.60000D+01
  4211. C                                        with weighted error   4.48E-17
  4212. C                                         log weighted error  16.35
  4213. C                               significant figures required  15.77
  4214. C                                    decimal places required  16.89
  4215. C
  4216. C Series for BM1        on the interval  0.          to  6.25000D-02
  4217. C                                        with weighted error   5.61E-17
  4218. C                                         log weighted error  16.25
  4219. C                               significant figures required  14.97
  4220. C                                    decimal places required  16.91
  4221. C
  4222. C Series for BTH1       on the interval  0.          to  6.25000D-02
  4223. C                                        with weighted error   4.10E-17
  4224. C                                         log weighted error  16.39
  4225. C                               significant figures required  15.96
  4226. C                                    decimal places required  17.08
  4227. C
  4228. C***REFERENCES  (NONE)
  4229. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  4230. C***REVISION HISTORY  (YYMMDD)
  4231. C   780601  DATE WRITTEN
  4232. C   890210  REVISION DATE from Version 3.2
  4233. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4234. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4235. C   900326  Removed duplicate information from DESCRIPTION section.
  4236. C           (WRB)
  4237. C***END PROLOGUE  BESJ1
  4238.       DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24)
  4239.       LOGICAL FIRST
  4240.       SAVE BJ1CS, BM1CS, BTH1CS, PI4, NTJ1, NTM1, NTTH1,
  4241.      1 XSML, XMIN, XMAX, FIRST
  4242.       DATA BJ1CS( 1) /   -.1172614151 3332787E0 /
  4243.       DATA BJ1CS( 2) /   -.2536152183 0790640E0 /
  4244.       DATA BJ1CS( 3) /    .0501270809 84469569E0 /
  4245.       DATA BJ1CS( 4) /   -.0046315148 09625081E0 /
  4246.       DATA BJ1CS( 5) /    .0002479962 29415914E0 /
  4247.       DATA BJ1CS( 6) /   -.0000086789 48686278E0 /
  4248.       DATA BJ1CS( 7) /    .0000002142 93917143E0 /
  4249.       DATA BJ1CS( 8) /   -.0000000039 36093079E0 /
  4250.       DATA BJ1CS( 9) /    .0000000000 55911823E0 /
  4251.       DATA BJ1CS(10) /   -.0000000000 00632761E0 /
  4252.       DATA BJ1CS(11) /    .0000000000 00005840E0 /
  4253.       DATA BJ1CS(12) /   -.0000000000 00000044E0 /
  4254.       DATA BM1CS( 1) /    .1047362510 931285E0 /
  4255.       DATA BM1CS( 2) /    .0044244389 3702345E0 /
  4256.       DATA BM1CS( 3) /   -.0000566163 9504035E0 /
  4257.       DATA BM1CS( 4) /    .0000023134 9417339E0 /
  4258.       DATA BM1CS( 5) /   -.0000001737 7182007E0 /
  4259.       DATA BM1CS( 6) /    .0000000189 3209930E0 /
  4260.       DATA BM1CS( 7) /   -.0000000026 5416023E0 /
  4261.       DATA BM1CS( 8) /    .0000000004 4740209E0 /
  4262.       DATA BM1CS( 9) /   -.0000000000 8691795E0 /
  4263.       DATA BM1CS(10) /    .0000000000 1891492E0 /
  4264.       DATA BM1CS(11) /   -.0000000000 0451884E0 /
  4265.       DATA BM1CS(12) /    .0000000000 0116765E0 /
  4266.       DATA BM1CS(13) /   -.0000000000 0032265E0 /
  4267.       DATA BM1CS(14) /    .0000000000 0009450E0 /
  4268.       DATA BM1CS(15) /   -.0000000000 0002913E0 /
  4269.       DATA BM1CS(16) /    .0000000000 0000939E0 /
  4270.       DATA BM1CS(17) /   -.0000000000 0000315E0 /
  4271.       DATA BM1CS(18) /    .0000000000 0000109E0 /
  4272.       DATA BM1CS(19) /   -.0000000000 0000039E0 /
  4273.       DATA BM1CS(20) /    .0000000000 0000014E0 /
  4274.       DATA BM1CS(21) /   -.0000000000 0000005E0 /
  4275.       DATA BTH1CS( 1) /    .7406014102 6313850E0 /
  4276.       DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
  4277.       DATA BTH1CS( 3) /    .0001198185 10964326E0 /
  4278.       DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
  4279.       DATA BTH1CS( 5) /    .0000006554 95621447E0 /
  4280.       DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
  4281.       DATA BTH1CS( 7) /    .0000000133 76886564E0 /
  4282.       DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
  4283.       DATA BTH1CS( 9) /    .0000000005 29495100E0 /
  4284.       DATA BTH1CS(10) /   -.0000000001 24135944E0 /
  4285.       DATA BTH1CS(11) /    .0000000000 31656485E0 /
  4286.       DATA BTH1CS(12) /   -.0000000000 08668640E0 /
  4287.       DATA BTH1CS(13) /    .0000000000 02523758E0 /
  4288.       DATA BTH1CS(14) /   -.0000000000 00775085E0 /
  4289.       DATA BTH1CS(15) /    .0000000000 00249527E0 /
  4290.       DATA BTH1CS(16) /   -.0000000000 00083773E0 /
  4291.       DATA BTH1CS(17) /    .0000000000 00029205E0 /
  4292.       DATA BTH1CS(18) /   -.0000000000 00010534E0 /
  4293.       DATA BTH1CS(19) /    .0000000000 00003919E0 /
  4294.       DATA BTH1CS(20) /   -.0000000000 00001500E0 /
  4295.       DATA BTH1CS(21) /    .0000000000 00000589E0 /
  4296.       DATA BTH1CS(22) /   -.0000000000 00000237E0 /
  4297.       DATA BTH1CS(23) /    .0000000000 00000097E0 /
  4298.       DATA BTH1CS(24) /   -.0000000000 00000040E0 /
  4299.       DATA PI4 / 0.7853981633 9744831E0 /
  4300.       DATA FIRST /.TRUE./
  4301. C***FIRST EXECUTABLE STATEMENT  BESJ1
  4302.       IF (FIRST) THEN
  4303.          NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3))
  4304.          NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
  4305.          NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
  4306. C
  4307.          XSML = SQRT (8.0*R1MACH(3))
  4308.          XMIN = 2.0*R1MACH(1)
  4309.          XMAX = 1.0/R1MACH(4)
  4310.       ENDIF
  4311.       FIRST = .FALSE.
  4312. C
  4313.       Y = ABS(X)
  4314.       IF (Y.GT.4.0) GO TO 20
  4315. C
  4316.       BESJ1 = 0.
  4317.       IF (Y.EQ.0.0) RETURN
  4318.       IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESJ1',
  4319.      +   'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
  4320.       IF (Y.GT.XMIN) BESJ1 = 0.5*X
  4321.       IF (Y.GT.XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1))
  4322.       RETURN
  4323. C
  4324.  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ1',
  4325.      +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 2, 2)
  4326.       Z = 32.0/Y**2 - 1.0
  4327.       AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y)
  4328.       THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y
  4329.       BESJ1 = SIGN (AMPL, X) * COS (THETA)
  4330. C
  4331.       RETURN
  4332.       END
  4333. *DECK BESK
  4334.       SUBROUTINE BESK (X, FNU, KODE, N, Y, NZ)
  4335. C***BEGIN PROLOGUE  BESK
  4336. C***PURPOSE  Implement forward recursion on the three term recursion
  4337. C            relation for a sequence of non-negative order Bessel
  4338. C            functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions
  4339. C            EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
  4340. C            X and non-negative orders FNU.
  4341. C***LIBRARY   SLATEC
  4342. C***CATEGORY  C10B3
  4343. C***TYPE      SINGLE PRECISION (BESK-S, DBESK-D)
  4344. C***KEYWORDS  K BESSEL FUNCTION, SPECIAL FUNCTIONS
  4345. C***AUTHOR  Amos, D. E., (SNLA)
  4346. C***DESCRIPTION
  4347. C
  4348. C     Abstract
  4349. C         BESK implements forward recursion on the three term
  4350. C         recursion relation for a sequence of non-negative order Bessel
  4351. C         functions K/sub(FNU+I-1)/(X), or scaled Bessel functions
  4352. C         EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X .GT. 0.0E0 and
  4353. C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
  4354. C         FNU+1 are obtained from BESKNU to start the recursion.  If
  4355. C         FNU .GE. NULIM, the uniform asymptotic expansion is used for
  4356. C         orders FNU and FNU+1 to start the recursion.  NULIM is 35 or
  4357. C         70 depending on whether N=1 or N .GE. 2.  Under and overflow
  4358. C         tests are made on the leading term of the asymptotic expansion
  4359. C         before any extensive computation is done.
  4360. C
  4361. C     Description of Arguments
  4362. C
  4363. C         Input
  4364. C           X      - X .GT. 0.0E0
  4365. C           FNU    - order of the initial K function, FNU .GE. 0.0E0
  4366. C           KODE   - a parameter to indicate the scaling option
  4367. C                    KODE=1 returns Y(I)=       K/sub(FNU+I-1)/(X),
  4368. C                                        I=1,...,N
  4369. C                    KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X),
  4370. C                                        I=1,...,N
  4371. C           N      - number of members in the sequence, N .GE. 1
  4372. C
  4373. C         Output
  4374. C           y      - a vector whose first n components contain values
  4375. C                    for the sequence
  4376. C                    Y(I)=       K/sub(FNU+I-1)/(X), I=1,...,N  or
  4377. C                    Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N
  4378. C                    depending on KODE
  4379. C           NZ     - number of components of Y set to zero due to
  4380. C                    underflow with KODE=1,
  4381. C                    NZ=0   , normal return, computation completed
  4382. C                    NZ .NE. 0, first NZ components of Y set to zero
  4383. C                             due to underflow, Y(I)=0.0E0, I=1,...,NZ
  4384. C
  4385. C     Error Conditions
  4386. C         Improper input arguments - a fatal error
  4387. C         Overflow - a fatal error
  4388. C         Underflow with KODE=1 -  a non-fatal error (NZ .NE. 0)
  4389. C
  4390. C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
  4391. C                 or Large Orders, NPL Mathematical Tables 6, Her
  4392. C                 Majesty's Stationery Office, London, 1962.
  4393. C               N. M. Temme, On the numerical evaluation of the modified
  4394. C                 Bessel function of the third kind, Journal of
  4395. C                 Computational Physics 19, (1975), pp. 324-337.
  4396. C***ROUTINES CALLED  ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU,
  4397. C                    I1MACH, R1MACH, XERMSG
  4398. C***REVISION HISTORY  (YYMMDD)
  4399. C   790201  DATE WRITTEN
  4400. C   890531  Changed all specific intrinsics to generic.  (WRB)
  4401. C   890531  REVISION DATE from Version 3.2
  4402. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4403. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4404. C   900326  Removed duplicate information from DESCRIPTION section.
  4405. C           (WRB)
  4406. C   920501  Reformatted the REFERENCES section.  (WRB)
  4407. C***END PROLOGUE  BESK
  4408. C
  4409.       INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ
  4410.       INTEGER I1MACH
  4411.       REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2,
  4412.      1 T, TM, TRX, W, X, XLIM, Y, ZN
  4413.       REAL BESK0, BESK1, BESK1E, BESK0E, R1MACH
  4414.       DIMENSION W(2), NULIM(2), Y(*)
  4415.       SAVE NULIM
  4416.       DATA NULIM(1),NULIM(2) / 35 , 70 /
  4417. C***FIRST EXECUTABLE STATEMENT  BESK
  4418.       NN = -I1MACH(12)
  4419.       ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
  4420.       XLIM = R1MACH(1)*1.0E+3
  4421.       IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280
  4422.       IF (FNU.LT.0.0E0) GO TO 290
  4423.       IF (X.LE.0.0E0) GO TO 300
  4424.       IF (X.LT.XLIM) GO TO 320
  4425.       IF (N.LT.1) GO TO 310
  4426.       ETX = KODE - 1
  4427. C
  4428. C     ND IS A DUMMY VARIABLE FOR N
  4429. C     GNU IS A DUMMY VARIABLE FOR FNU
  4430. C     NZ = NUMBER OF UNDERFLOWS ON KODE=1
  4431. C
  4432.       ND = N
  4433.       NZ = 0
  4434.       NUD = INT(FNU)
  4435.       DNU = FNU - NUD
  4436.       GNU = FNU
  4437.       NN = MIN(2,ND)
  4438.       FN = FNU + N - 1
  4439.       FNN = FN
  4440.       IF (FN.LT.2.0E0) GO TO 150
  4441. C
  4442. C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
  4443. C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
  4444. C
  4445.       ZN = X/FN
  4446.       IF (ZN.EQ.0.0E0) GO TO 320
  4447.       RTZ = SQRT(1.0E0+ZN*ZN)
  4448.       GLN = LOG((1.0E0+RTZ)/ZN)
  4449.       T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
  4450.       CN = -FN*(T-GLN)
  4451.       IF (CN.GT.ELIM) GO TO 320
  4452.       IF (NUD.LT.NULIM(NN)) GO TO 30
  4453.       IF (NN.EQ.1) GO TO 20
  4454.    10 CONTINUE
  4455. C
  4456. C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
  4457. C     FOR THE FIRST ORDER, FNU.GE.NULIM
  4458. C
  4459.       FN = GNU
  4460.       ZN = X/FN
  4461.       RTZ = SQRT(1.0E0+ZN*ZN)
  4462.       GLN = LOG((1.0E0+RTZ)/ZN)
  4463.       T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
  4464.       CN = -FN*(T-GLN)
  4465.    20 CONTINUE
  4466.       IF (CN.LT.-ELIM) GO TO 230
  4467. C
  4468. C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
  4469. C
  4470.       FLGIK = -1.0E0
  4471.       CALL ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y)
  4472.       IF (NN.EQ.1) GO TO 240
  4473.       TRX = 2.0E0/X
  4474.       TM = (GNU+GNU+2.0E0)/X
  4475.       GO TO 130
  4476. C
  4477.    30 CONTINUE
  4478.       IF (KODE.EQ.2) GO TO 40
  4479. C
  4480. C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X)
  4481. C     FOR ORDER DNU
  4482. C
  4483.       IF (X.GT.ELIM) GO TO 230
  4484.    40 CONTINUE
  4485.       IF (DNU.NE.0.0E0) GO TO 80
  4486.       IF (KODE.EQ.2) GO TO 50
  4487.       S1 = BESK0(X)
  4488.       GO TO 60
  4489.    50 S1 = BESK0E(X)
  4490.    60 CONTINUE
  4491.       IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120
  4492.       IF (KODE.EQ.2) GO TO 70
  4493.       S2 = BESK1(X)
  4494.       GO TO 90
  4495.    70 S2 = BESK1E(X)
  4496.       GO TO 90
  4497.    80 CONTINUE
  4498.       NB = 2
  4499.       IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
  4500.       CALL BESKNU(X, DNU, KODE, NB, W, NZ)
  4501.       S1 = W(1)
  4502.       IF (NB.EQ.1) GO TO 120
  4503.       S2 = W(2)
  4504.    90 CONTINUE
  4505.       TRX = 2.0E0/X
  4506.       TM = (DNU+DNU+2.0E0)/X
  4507. C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
  4508.       IF (ND.EQ.1) NUD = NUD - 1
  4509.       IF (NUD.GT.0) GO TO 100
  4510.       IF (ND.GT.1) GO TO 120
  4511.       S1 = S2
  4512.       GO TO 120
  4513.   100 CONTINUE
  4514.       DO 110 I=1,NUD
  4515.         S = S2
  4516.         S2 = TM*S2 + S1
  4517.         S1 = S
  4518.         TM = TM + TRX
  4519.   110 CONTINUE
  4520.       IF (ND.EQ.1) S1 = S2
  4521.   120 CONTINUE
  4522.       Y(1) = S1
  4523.       IF (ND.EQ.1) GO TO 240
  4524.       Y(2) = S2
  4525.   130 CONTINUE
  4526.       IF (ND.EQ.2) GO TO 240
  4527. C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
  4528.       DO 140 I=3,ND
  4529.         Y(I) = TM*Y(I-1) + Y(I-2)
  4530.         TM = TM + TRX
  4531.   140 CONTINUE
  4532.       GO TO 240
  4533. C
  4534.   150 CONTINUE
  4535. C     UNDERFLOW TEST FOR KODE=1
  4536.       IF (KODE.EQ.2) GO TO 160
  4537.       IF (X.GT.ELIM) GO TO 230
  4538.   160 CONTINUE
  4539. C     OVERFLOW TEST
  4540.       IF (FN.LE.1.0E0) GO TO 170
  4541.       IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 320
  4542.   170 CONTINUE
  4543.       IF (DNU.EQ.0.0E0) GO TO 180
  4544.       CALL BESKNU(X, FNU, KODE, ND, Y, MZ)
  4545.       GO TO 240
  4546.   180 CONTINUE
  4547.       J = NUD
  4548.       IF (J.EQ.1) GO TO 210
  4549.       J = J + 1
  4550.       IF (KODE.EQ.2) GO TO 190
  4551.       Y(J) = BESK0(X)
  4552.       GO TO 200
  4553.   190 Y(J) = BESK0E(X)
  4554.   200 IF (ND.EQ.1) GO TO 240
  4555.       J = J + 1
  4556.   210 IF (KODE.EQ.2) GO TO 220
  4557.       Y(J) = BESK1(X)
  4558.       GO TO 240
  4559.   220 Y(J) = BESK1E(X)
  4560.       GO TO 240
  4561. C
  4562. C     UPDATE PARAMETERS ON UNDERFLOW
  4563. C
  4564.   230 CONTINUE
  4565.       NUD = NUD + 1
  4566.       ND = ND - 1
  4567.       IF (ND.EQ.0) GO TO 240
  4568.       NN = MIN(2,ND)
  4569.       GNU = GNU + 1.0E0
  4570.       IF (FNN.LT.2.0E0) GO TO 230
  4571.       IF (NUD.LT.NULIM(NN)) GO TO 230
  4572.       GO TO 10
  4573.   240 CONTINUE
  4574.       NZ = N - ND
  4575.       IF (NZ.EQ.0) RETURN
  4576.       IF (ND.EQ.0) GO TO 260
  4577.       DO 250 I=1,ND
  4578.         J = N - I + 1
  4579.         K = ND - I + 1
  4580.         Y(J) = Y(K)
  4581.   250 CONTINUE
  4582.   260 CONTINUE
  4583.       DO 270 I=1,NZ
  4584.         Y(I) = 0.0E0
  4585.   270 CONTINUE
  4586.       RETURN
  4587. C
  4588. C
  4589. C
  4590.   280 CONTINUE
  4591.       CALL XERMSG ('SLATEC', 'BESK', 'SCALING OPTION, KODE, NOT 1 OR 2'
  4592.      +   , 2, 1)
  4593.       RETURN
  4594.   290 CONTINUE
  4595.       CALL XERMSG ('SLATEC', 'BESK', 'ORDER, FNU, LESS THAN ZERO', 2,
  4596.      +   1)
  4597.       RETURN
  4598.   300 CONTINUE
  4599.       CALL XERMSG ('SLATEC', 'BESK', 'X LESS THAN OR EQUAL TO ZERO', 2,
  4600.      +   1)
  4601.       RETURN
  4602.   310 CONTINUE
  4603.       CALL XERMSG ('SLATEC', 'BESK', 'N LESS THAN ONE', 2, 1)
  4604.       RETURN
  4605.   320 CONTINUE
  4606.       CALL XERMSG ('SLATEC', 'BESK',
  4607.      +   'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1)
  4608.       RETURN
  4609.       END
  4610. *DECK BESK0
  4611.       FUNCTION BESK0 (X)
  4612. C***BEGIN PROLOGUE  BESK0
  4613. C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
  4614. C            third kind of order zero.
  4615. C***LIBRARY   SLATEC (FNLIB)
  4616. C***CATEGORY  C10B1
  4617. C***TYPE      SINGLE PRECISION (BESK0-S, DBESK0-D)
  4618. C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
  4619. C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
  4620. C             THIRD KIND
  4621. C***AUTHOR  Fullerton, W., (LANL)
  4622. C***DESCRIPTION
  4623. C
  4624. C BESK0(X) calculates the modified (hyperbolic) Bessel function
  4625. C of the third kind of order zero for real argument X .GT. 0.0.
  4626. C
  4627. C Series for BK0        on the interval  0.          to  4.00000D+00
  4628. C                                        with weighted error   3.57E-19
  4629. C                                         log weighted error  18.45
  4630. C                               significant figures required  17.99
  4631. C                                    decimal places required  18.97
  4632. C
  4633. C***REFERENCES  (NONE)
  4634. C***ROUTINES CALLED  BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG
  4635. C***REVISION HISTORY  (YYMMDD)
  4636. C   770401  DATE WRITTEN
  4637. C   890531  Changed all specific intrinsics to generic.  (WRB)
  4638. C   890531  REVISION DATE from Version 3.2
  4639. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4640. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4641. C   900326  Removed duplicate information from DESCRIPTION section.
  4642. C           (WRB)
  4643. C***END PROLOGUE  BESK0
  4644.       DIMENSION BK0CS(11)
  4645.       LOGICAL FIRST
  4646.       SAVE BK0CS, NTK0, XSML, XMAX, FIRST
  4647.       DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
  4648.       DATA BK0CS( 2) /    .3442898999 246284869E0 /
  4649.       DATA BK0CS( 3) /    .0359799365 1536150163E0 /
  4650.       DATA BK0CS( 4) /    .0012646154 1144692592E0 /
  4651.       DATA BK0CS( 5) /    .0000228621 2103119451E0 /
  4652.       DATA BK0CS( 6) /    .0000002534 7910790261E0 /
  4653.       DATA BK0CS( 7) /    .0000000019 0451637722E0 /
  4654.       DATA BK0CS( 8) /    .0000000000 1034969525E0 /
  4655.       DATA BK0CS( 9) /    .0000000000 0004259816E0 /
  4656.       DATA BK0CS(10) /    .0000000000 0000013744E0 /
  4657.       DATA BK0CS(11) /    .0000000000 0000000035E0 /
  4658.       DATA FIRST /.TRUE./
  4659. C***FIRST EXECUTABLE STATEMENT  BESK0
  4660.       IF (FIRST) THEN
  4661.          NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
  4662.          XSML = SQRT (4.0*R1MACH(3))
  4663.          XMAXT = -LOG(R1MACH(1))
  4664.          XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01
  4665.       ENDIF
  4666.       FIRST = .FALSE.
  4667. C
  4668.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0',
  4669.      +   'X IS ZERO OR NEGATIVE', 2, 2)
  4670.       IF (X.GT.2.) GO TO 20
  4671. C
  4672.       Y = 0.
  4673.       IF (X.GT.XSML) Y = X*X
  4674.       BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0)
  4675.       RETURN
  4676. C
  4677.  20   BESK0 = 0.
  4678.       IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK0',
  4679.      +   'X SO BIG K0 UNDERFLOWS', 1, 1)
  4680.       IF (X.GT.XMAX) RETURN
  4681. C
  4682.       BESK0 = EXP(-X) * BESK0E(X)
  4683. C
  4684.       RETURN
  4685.       END
  4686. *DECK BESK0E
  4687.       FUNCTION BESK0E (X)
  4688. C***BEGIN PROLOGUE  BESK0E
  4689. C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
  4690. C            Bessel function of the third kind of order zero.
  4691. C***LIBRARY   SLATEC (FNLIB)
  4692. C***CATEGORY  C10B1
  4693. C***TYPE      SINGLE PRECISION (BESK0E-S, DBSK0E-D)
  4694. C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  4695. C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
  4696. C             THIRD KIND
  4697. C***AUTHOR  Fullerton, W., (LANL)
  4698. C***DESCRIPTION
  4699. C
  4700. C BESK0E(X) computes the exponentially scaled modified (hyperbolic)
  4701. C Bessel function of third kind of order zero for real argument
  4702. C X .GT. 0.0, i.e., EXP(X)*K0(X).
  4703. C
  4704. C Series for BK0        on the interval  0.          to  4.00000D+00
  4705. C                                        with weighted error   3.57E-19
  4706. C                                         log weighted error  18.45
  4707. C                               significant figures required  17.99
  4708. C                                    decimal places required  18.97
  4709. C
  4710. C Series for AK0        on the interval  1.25000D-01 to  5.00000D-01
  4711. C                                        with weighted error   5.34E-17
  4712. C                                         log weighted error  16.27
  4713. C                               significant figures required  14.92
  4714. C                                    decimal places required  16.89
  4715. C
  4716. C Series for AK02       on the interval  0.          to  1.25000D-01
  4717. C                                        with weighted error   2.34E-17
  4718. C                                         log weighted error  16.63
  4719. C                               significant figures required  14.67
  4720. C                                    decimal places required  17.20
  4721. C
  4722. C***REFERENCES  (NONE)
  4723. C***ROUTINES CALLED  BESI0, CSEVL, INITS, R1MACH, XERMSG
  4724. C***REVISION HISTORY  (YYMMDD)
  4725. C   770401  DATE WRITTEN
  4726. C   890531  Changed all specific intrinsics to generic.  (WRB)
  4727. C   890531  REVISION DATE from Version 3.2
  4728. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4729. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4730. C   900326  Removed duplicate information from DESCRIPTION section.
  4731. C           (WRB)
  4732. C***END PROLOGUE  BESK0E
  4733.       DIMENSION BK0CS(11), AK0CS(17), AK02CS(14)
  4734.       LOGICAL FIRST
  4735.       SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST
  4736.       DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
  4737.       DATA BK0CS( 2) /    .3442898999 246284869E0 /
  4738.       DATA BK0CS( 3) /    .0359799365 1536150163E0 /
  4739.       DATA BK0CS( 4) /    .0012646154 1144692592E0 /
  4740.       DATA BK0CS( 5) /    .0000228621 2103119451E0 /
  4741.       DATA BK0CS( 6) /    .0000002534 7910790261E0 /
  4742.       DATA BK0CS( 7) /    .0000000019 0451637722E0 /
  4743.       DATA BK0CS( 8) /    .0000000000 1034969525E0 /
  4744.       DATA BK0CS( 9) /    .0000000000 0004259816E0 /
  4745.       DATA BK0CS(10) /    .0000000000 0000013744E0 /
  4746.       DATA BK0CS(11) /    .0000000000 0000000035E0 /
  4747.       DATA AK0CS( 1) /   -.0764394790 3327941E0 /
  4748.       DATA AK0CS( 2) /   -.0223565260 5699819E0 /
  4749.       DATA AK0CS( 3) /    .0007734181 1546938E0 /
  4750.       DATA AK0CS( 4) /   -.0000428100 6688886E0 /
  4751.       DATA AK0CS( 5) /    .0000030817 0017386E0 /
  4752.       DATA AK0CS( 6) /   -.0000002639 3672220E0 /
  4753.       DATA AK0CS( 7) /    .0000000256 3713036E0 /
  4754.       DATA AK0CS( 8) /   -.0000000027 4270554E0 /
  4755.       DATA AK0CS( 9) /    .0000000003 1694296E0 /
  4756.       DATA AK0CS(10) /   -.0000000000 3902353E0 /
  4757.       DATA AK0CS(11) /    .0000000000 0506804E0 /
  4758.       DATA AK0CS(12) /   -.0000000000 0068895E0 /
  4759.       DATA AK0CS(13) /    .0000000000 0009744E0 /
  4760.       DATA AK0CS(14) /   -.0000000000 0001427E0 /
  4761.       DATA AK0CS(15) /    .0000000000 0000215E0 /
  4762.       DATA AK0CS(16) /   -.0000000000 0000033E0 /
  4763.       DATA AK0CS(17) /    .0000000000 0000005E0 /
  4764.       DATA AK02CS( 1) /   -.0120186982 6307592E0 /
  4765.       DATA AK02CS( 2) /   -.0091748526 9102569E0 /
  4766.       DATA AK02CS( 3) /    .0001444550 9317750E0 /
  4767.       DATA AK02CS( 4) /   -.0000040136 1417543E0 /
  4768.       DATA AK02CS( 5) /    .0000001567 8318108E0 /
  4769.       DATA AK02CS( 6) /   -.0000000077 7011043E0 /
  4770.       DATA AK02CS( 7) /    .0000000004 6111825E0 /
  4771.       DATA AK02CS( 8) /   -.0000000000 3158592E0 /
  4772.       DATA AK02CS( 9) /    .0000000000 0243501E0 /
  4773.       DATA AK02CS(10) /   -.0000000000 0020743E0 /
  4774.       DATA AK02CS(11) /    .0000000000 0001925E0 /
  4775.       DATA AK02CS(12) /   -.0000000000 0000192E0 /
  4776.       DATA AK02CS(13) /    .0000000000 0000020E0 /
  4777.       DATA AK02CS(14) /   -.0000000000 0000002E0 /
  4778.       DATA FIRST /.TRUE./
  4779. C***FIRST EXECUTABLE STATEMENT  BESK0E
  4780.       IF (FIRST) THEN
  4781.          NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
  4782.          NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3))
  4783.          NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3))
  4784.          XSML = SQRT (4.0*R1MACH(3))
  4785.       ENDIF
  4786.       FIRST = .FALSE.
  4787. C
  4788.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0E',
  4789.      +   'X IS ZERO OR NEGATIVE', 2, 2)
  4790.       IF (X.GT.2.) GO TO 20
  4791. C
  4792.       Y = 0.
  4793.       IF (X.GT.XSML) Y = X*X
  4794.       BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X)
  4795.      1  - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) )
  4796.       RETURN
  4797. C
  4798.  20   IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0))
  4799.      1  / SQRT(X)
  4800.       IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02))
  4801.      1  / SQRT(X)
  4802. C
  4803.       RETURN
  4804.       END
  4805. *DECK BESK1
  4806.       FUNCTION BESK1 (X)
  4807. C***BEGIN PROLOGUE  BESK1
  4808. C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
  4809. C            third kind of order one.
  4810. C***LIBRARY   SLATEC (FNLIB)
  4811. C***CATEGORY  C10B1
  4812. C***TYPE      SINGLE PRECISION (BESK1-S, DBESK1-D)
  4813. C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
  4814. C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
  4815. C             THIRD KIND
  4816. C***AUTHOR  Fullerton, W., (LANL)
  4817. C***DESCRIPTION
  4818. C
  4819. C BESK1(X) computes the modified (hyperbolic) Bessel function of third
  4820. C kind of order one for real argument X, where X .GT. 0.
  4821. C
  4822. C Series for BK1        on the interval  0.          to  4.00000D+00
  4823. C                                        with weighted error   7.02E-18
  4824. C                                         log weighted error  17.15
  4825. C                               significant figures required  16.73
  4826. C                                    decimal places required  17.67
  4827. C
  4828. C***REFERENCES  (NONE)
  4829. C***ROUTINES CALLED  BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG
  4830. C***REVISION HISTORY  (YYMMDD)
  4831. C   770401  DATE WRITTEN
  4832. C   890531  Changed all specific intrinsics to generic.  (WRB)
  4833. C   890531  REVISION DATE from Version 3.2
  4834. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4835. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4836. C   900326  Removed duplicate information from DESCRIPTION section.
  4837. C           (WRB)
  4838. C***END PROLOGUE  BESK1
  4839.       DIMENSION BK1CS(11)
  4840.       LOGICAL FIRST
  4841.       SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST
  4842.       DATA BK1CS( 1) /    .0253002273 389477705E0 /
  4843.       DATA BK1CS( 2) /   -.3531559607 76544876E0 /
  4844.       DATA BK1CS( 3) /   -.1226111808 22657148E0 /
  4845.       DATA BK1CS( 4) /   -.0069757238 596398643E0 /
  4846.       DATA BK1CS( 5) /   -.0001730288 957513052E0 /
  4847.       DATA BK1CS( 6) /   -.0000024334 061415659E0 /
  4848.       DATA BK1CS( 7) /   -.0000000221 338763073E0 /
  4849.       DATA BK1CS( 8) /   -.0000000001 411488392E0 /
  4850.       DATA BK1CS( 9) /   -.0000000000 006666901E0 /
  4851.       DATA BK1CS(10) /   -.0000000000 000024274E0 /
  4852.       DATA BK1CS(11) /   -.0000000000 000000070E0 /
  4853.       DATA FIRST /.TRUE./
  4854. C***FIRST EXECUTABLE STATEMENT  BESK1
  4855.       IF (FIRST) THEN
  4856.          NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
  4857.          XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
  4858.          XSML = SQRT (4.0*R1MACH(3))
  4859.          XMAXT = -LOG(R1MACH(1))
  4860.          XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5)
  4861.       ENDIF
  4862.       FIRST = .FALSE.
  4863. C
  4864.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1',
  4865.      +   'X IS ZERO OR NEGATIVE', 2, 2)
  4866.       IF (X.GT.2.0) GO TO 20
  4867. C
  4868.       IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1',
  4869.      +   'X SO SMALL K1 OVERFLOWS', 3, 2)
  4870.       Y = 0.
  4871.       IF (X.GT.XSML) Y = X*X
  4872.       BESK1 = LOG(0.5*X)*BESI1(X) +
  4873.      1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X
  4874.       RETURN
  4875. C
  4876.  20   BESK1 = 0.
  4877.       IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK1',
  4878.      +   'X SO BIG K1 UNDERFLOWS', 1, 1)
  4879.       IF (X.GT.XMAX) RETURN
  4880. C
  4881.       BESK1 = EXP(-X) * BESK1E(X)
  4882. C
  4883.       RETURN
  4884.       END
  4885. *DECK BESK1E
  4886.       FUNCTION BESK1E (X)
  4887. C***BEGIN PROLOGUE  BESK1E
  4888. C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
  4889. C            Bessel function of the third kind of order one.
  4890. C***LIBRARY   SLATEC (FNLIB)
  4891. C***CATEGORY  C10B1
  4892. C***TYPE      SINGLE PRECISION (BESK1E-S, DBSK1E-D)
  4893. C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  4894. C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
  4895. C             THIRD KIND
  4896. C***AUTHOR  Fullerton, W., (LANL)
  4897. C***DESCRIPTION
  4898. C
  4899. C BESK1E(X) computes the exponentially scaled modified (hyperbolic)
  4900. C Bessel function of third kind of order one for real argument
  4901. C X .GT. 0.0, i.e., EXP(X)*K1(X).
  4902. C
  4903. C Series for BK1        on the interval  0.          to  4.00000D+00
  4904. C                                        with weighted error   7.02E-18
  4905. C                                         log weighted error  17.15
  4906. C                               significant figures required  16.73
  4907. C                                    decimal places required  17.67
  4908. C
  4909. C Series for AK1        on the interval  1.25000D-01 to  5.00000D-01
  4910. C                                        with weighted error   6.06E-17
  4911. C                                         log weighted error  16.22
  4912. C                               significant figures required  15.41
  4913. C                                    decimal places required  16.83
  4914. C
  4915. C Series for AK12       on the interval  0.          to  1.25000D-01
  4916. C                                        with weighted error   2.58E-17
  4917. C                                         log weighted error  16.59
  4918. C                               significant figures required  15.22
  4919. C                                    decimal places required  17.16
  4920. C
  4921. C***REFERENCES  (NONE)
  4922. C***ROUTINES CALLED  BESI1, CSEVL, INITS, R1MACH, XERMSG
  4923. C***REVISION HISTORY  (YYMMDD)
  4924. C   770401  DATE WRITTEN
  4925. C   890531  Changed all specific intrinsics to generic.  (WRB)
  4926. C   890531  REVISION DATE from Version 3.2
  4927. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  4928. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  4929. C   900326  Removed duplicate information from DESCRIPTION section.
  4930. C           (WRB)
  4931. C***END PROLOGUE  BESK1E
  4932.       DIMENSION BK1CS(11), AK1CS(17), AK12CS(14)
  4933.       LOGICAL FIRST
  4934.       SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML,
  4935.      1 FIRST
  4936.       DATA BK1CS( 1) /    .0253002273 389477705E0 /
  4937.       DATA BK1CS( 2) /   -.3531559607 76544876E0 /
  4938.       DATA BK1CS( 3) /   -.1226111808 22657148E0 /
  4939.       DATA BK1CS( 4) /   -.0069757238 596398643E0 /
  4940.       DATA BK1CS( 5) /   -.0001730288 957513052E0 /
  4941.       DATA BK1CS( 6) /   -.0000024334 061415659E0 /
  4942.       DATA BK1CS( 7) /   -.0000000221 338763073E0 /
  4943.       DATA BK1CS( 8) /   -.0000000001 411488392E0 /
  4944.       DATA BK1CS( 9) /   -.0000000000 006666901E0 /
  4945.       DATA BK1CS(10) /   -.0000000000 000024274E0 /
  4946.       DATA BK1CS(11) /   -.0000000000 000000070E0 /
  4947.       DATA AK1CS( 1) /    .2744313406 973883E0 /
  4948.       DATA AK1CS( 2) /    .0757198995 3199368E0 /
  4949.       DATA AK1CS( 3) /   -.0014410515 5647540E0 /
  4950.       DATA AK1CS( 4) /    .0000665011 6955125E0 /
  4951.       DATA AK1CS( 5) /   -.0000043699 8470952E0 /
  4952.       DATA AK1CS( 6) /    .0000003540 2774997E0 /
  4953.       DATA AK1CS( 7) /   -.0000000331 1163779E0 /
  4954.       DATA AK1CS( 8) /    .0000000034 4597758E0 /
  4955.       DATA AK1CS( 9) /   -.0000000003 8989323E0 /
  4956.       DATA AK1CS(10) /    .0000000000 4720819E0 /
  4957.       DATA AK1CS(11) /   -.0000000000 0604783E0 /
  4958.       DATA AK1CS(12) /    .0000000000 0081284E0 /
  4959.       DATA AK1CS(13) /   -.0000000000 0011386E0 /
  4960.       DATA AK1CS(14) /    .0000000000 0001654E0 /
  4961.       DATA AK1CS(15) /   -.0000000000 0000248E0 /
  4962.       DATA AK1CS(16) /    .0000000000 0000038E0 /
  4963.       DATA AK1CS(17) /   -.0000000000 0000006E0 /
  4964.       DATA AK12CS( 1) /    .0637930834 3739001E0 /
  4965.       DATA AK12CS( 2) /    .0283288781 3049721E0 /
  4966.       DATA AK12CS( 3) /   -.0002475370 6739052E0 /
  4967.       DATA AK12CS( 4) /    .0000057719 7245160E0 /
  4968.       DATA AK12CS( 5) /   -.0000002068 9392195E0 /
  4969.       DATA AK12CS( 6) /    .0000000097 3998344E0 /
  4970.       DATA AK12CS( 7) /   -.0000000005 5853361E0 /
  4971.       DATA AK12CS( 8) /    .0000000000 3732996E0 /
  4972.       DATA AK12CS( 9) /   -.0000000000 0282505E0 /
  4973.       DATA AK12CS(10) /    .0000000000 0023720E0 /
  4974.       DATA AK12CS(11) /   -.0000000000 0002176E0 /
  4975.       DATA AK12CS(12) /    .0000000000 0000215E0 /
  4976.       DATA AK12CS(13) /   -.0000000000 0000022E0 /
  4977.       DATA AK12CS(14) /    .0000000000 0000002E0 /
  4978.       DATA FIRST /.TRUE./
  4979. C***FIRST EXECUTABLE STATEMENT  BESK1E
  4980.       IF (FIRST) THEN
  4981.          NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
  4982.          NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3))
  4983.          NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3))
  4984. C
  4985.          XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
  4986.          XSML = SQRT (4.0*R1MACH(3))
  4987.       ENDIF
  4988.       FIRST = .FALSE.
  4989. C
  4990.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1E',
  4991.      +   'X IS ZERO OR NEGATIVE', 2, 2)
  4992.       IF (X.GT.2.0) GO TO 20
  4993. C
  4994.       IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1E',
  4995.      +   'X SO SMALL K1 OVERFLOWS', 3, 2)
  4996.       Y = 0.
  4997.       IF (X.GT.XSML) Y = X*X
  4998.       BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) +
  4999.      1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X )
  5000.       RETURN
  5001. C
  5002.  20   IF (X.LE.8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1))
  5003.      1  / SQRT(X)
  5004.       IF (X.GT.8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12))
  5005.      1  / SQRT(X)
  5006. C
  5007.       RETURN
  5008.       END
  5009. *DECK BESKES
  5010.       SUBROUTINE BESKES (XNU, X, NIN, BKE)
  5011. C***BEGIN PROLOGUE  BESKES
  5012. C***PURPOSE  Compute a sequence of exponentially scaled modified Bessel
  5013. C            functions of the third kind of fractional order.
  5014. C***LIBRARY   SLATEC (FNLIB)
  5015. C***CATEGORY  C10B3
  5016. C***TYPE      SINGLE PRECISION (BESKES-S, DBSKES-D)
  5017. C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER,
  5018. C             MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS,
  5019. C             SPECIAL FUNCTIONS, THIRD KIND
  5020. C***AUTHOR  Fullerton, W., (LANL)
  5021. C***DESCRIPTION
  5022. C
  5023. C BESKES computes a sequence of exponentially scaled
  5024. C (i.e., multipled by EXP(X)) modified Bessel
  5025. C functions of the third kind of order XNU + I at X, where X .GT. 0,
  5026. C XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive
  5027. C and I = 0, -1, ... , NIN + 1, if NIN is negative.  On return, the
  5028. C vector BKE(.) contains the results at X for order starting at XNU.
  5029. C
  5030. C***REFERENCES  (NONE)
  5031. C***ROUTINES CALLED  R1MACH, R9KNUS, XERMSG
  5032. C***REVISION HISTORY  (YYMMDD)
  5033. C   770601  DATE WRITTEN
  5034. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5035. C   890911  Removed unnecessary intrinsics.  (WRB)
  5036. C   890911  REVISION DATE from Version 3.2
  5037. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5038. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5039. C   900326  Removed duplicate information from DESCRIPTION section.
  5040. C           (WRB)
  5041. C***END PROLOGUE  BESKES
  5042.       DIMENSION BKE(*)
  5043.       SAVE ALNBIG
  5044.       DATA ALNBIG / 0. /
  5045. C***FIRST EXECUTABLE STATEMENT  BESKES
  5046.       IF (ALNBIG.EQ.0.) ALNBIG = LOG (R1MACH(2))
  5047. C
  5048.       V = ABS(XNU)
  5049.       N = ABS(NIN)
  5050. C
  5051.       IF (V .GE. 1.) CALL XERMSG ('SLATEC', 'BESKES',
  5052.      +   'ABS(XNU) MUST BE LT 1', 2, 2)
  5053.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESKES', 'X IS LE 0', 3,
  5054.      +   2)
  5055.       IF (N .EQ. 0) CALL XERMSG ('SLATEC', 'BESKES',
  5056.      +   'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2)
  5057. C
  5058.       CALL R9KNUS (V, X, BKE(1), BKNU1, ISWTCH)
  5059.       IF (N.EQ.1) RETURN
  5060. C
  5061.       VINCR = SIGN (1.0, REAL(NIN))
  5062.       DIRECT = VINCR
  5063.       IF (XNU.NE.0.) DIRECT = VINCR*SIGN(1.0,XNU)
  5064.       IF (ISWTCH .EQ. 1 .AND. DIRECT .GT. 0.) CALL XERMSG ('SLATEC',
  5065.      +   'BESKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2)
  5066.       BKE(2) = BKNU1
  5067. C
  5068.       IF (DIRECT.LT.0.) CALL R9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1,
  5069.      1  ISWTCH)
  5070.       IF (N.EQ.2) RETURN
  5071. C
  5072.       VEND = ABS(XNU+NIN) - 1.0
  5073.       IF ((VEND-0.5)*LOG(VEND)+0.27-VEND*(LOG(X)-.694) .GT. ALNBIG)
  5074.      1CALL XERMSG ( 'SLATEC', 'BESKES',
  5075.      2'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU OVERFLOWS',
  5076.      35, 2)
  5077. C
  5078.       V = XNU
  5079.       DO 10 I=3,N
  5080.         V = V + VINCR
  5081.         BKE(I) = 2.0*V*BKE(I-1)/X + BKE(I-2)
  5082.  10   CONTINUE
  5083. C
  5084.       RETURN
  5085.       END
  5086. *DECK BESKNU
  5087.       SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ)
  5088. C***BEGIN PROLOGUE  BESKNU
  5089. C***SUBSIDIARY
  5090. C***PURPOSE  Subsidiary to BESK
  5091. C***LIBRARY   SLATEC
  5092. C***TYPE      SINGLE PRECISION (BESKNU-S, DBSKNU-D)
  5093. C***AUTHOR  Amos, D. E., (SNLA)
  5094. C***DESCRIPTION
  5095. C
  5096. C     Abstract
  5097. C         BESKNU computes N member sequences of K Bessel functions
  5098. C         K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
  5099. C         positive X. Equations of the references are implemented on
  5100. C         small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X).
  5101. C         Forward recursion with the three term recursion relation
  5102. C         generates higher orders FNU+I-1, I=1,...,N. The parameter
  5103. C         KODE permits K/SUB(FNU+I-1)/(X) values or scaled values
  5104. C         EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned.
  5105. C
  5106. C         To start the recursion FNU is normalized to the interval
  5107. C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
  5108. C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
  5109. C         K Bessel function in terms of the confluent hypergeometric
  5110. C         function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2.
  5111. C         For X.GT.X2, the asymptotic expansion for large X is used.
  5112. C         When FNU is a half odd integer, a special formula for
  5113. C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
  5114. C
  5115. C         BESKNU assumes that a significant digit SINH(X) function is
  5116. C         available.
  5117. C
  5118. C     Description of Arguments
  5119. C
  5120. C         Input
  5121. C           X      - X.GT.0.0E0
  5122. C           FNU    - Order of initial K function, FNU.GE.0.0E0
  5123. C           N      - Number of members of the sequence, N.GE.1
  5124. C           KODE   - A parameter to indicate the scaling option
  5125. C                    KODE= 1  returns
  5126. C                             Y(I)=       K/SUB(FNU+I-1)/(X)
  5127. C                                  I=1,...,N
  5128. C                        = 2  returns
  5129. C                             Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X)
  5130. C                                  I=1,...,N
  5131. C
  5132. C         Output
  5133. C           Y      - A vector whose first N components contain values
  5134. C                    for the sequence
  5135. C                    Y(I)=       K/SUB(FNU+I-1)/(X), I=1,...,N or
  5136. C                    Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N
  5137. C                    depending on KODE
  5138. C           NZ     - Number of components set to zero due to
  5139. C                    underflow,
  5140. C                    NZ= 0   , Normal return
  5141. C                    NZ.NE.0 , First NZ components of Y set to zero
  5142. C                              due to underflow, Y(I)=0.0E0,I=1,...,NZ
  5143. C
  5144. C     Error Conditions
  5145. C         Improper input arguments - a fatal error
  5146. C         Overflow - a fatal error
  5147. C         Underflow with KODE=1 - a non-fatal error (NZ.NE.0)
  5148. C
  5149. C***SEE ALSO  BESK
  5150. C***REFERENCES  N. M. Temme, On the numerical evaluation of the modified
  5151. C                 Bessel function of the third kind, Journal of
  5152. C                 Computational Physics 19, (1975), pp. 324-337.
  5153. C***ROUTINES CALLED  GAMMA, I1MACH, R1MACH, XERMSG
  5154. C***REVISION HISTORY  (YYMMDD)
  5155. C   790201  DATE WRITTEN
  5156. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5157. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5158. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5159. C   900326  Removed duplicate information from DESCRIPTION section.
  5160. C           (WRB)
  5161. C   900328  Added TYPE section.  (WRB)
  5162. C   900727  Added EXTERNAL statement.  (WRB)
  5163. C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
  5164. C   920501  Reformatted the REFERENCES section.  (WRB)
  5165. C***END PROLOGUE  BESKNU
  5166. C
  5167.       INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ
  5168.       INTEGER I1MACH
  5169.       REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM,
  5170.      1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI,
  5171.      2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1,
  5172.      3 T2, X, X1, X2, Y
  5173.       REAL GAMMA, R1MACH
  5174.       DIMENSION A(160), B(160), Y(*), CC(8)
  5175.       EXTERNAL GAMMA
  5176.       SAVE X1, X2, PI, RTHPI, CC
  5177.       DATA X1, X2 / 2.0E0, 17.0E0 /
  5178.       DATA PI,RTHPI        / 3.14159265358979E+00, 1.25331413731550E+00/
  5179.       DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
  5180.      1                     / 5.77215664901533E-01,-4.20026350340952E-02,
  5181.      2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
  5182.      3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
  5183. C***FIRST EXECUTABLE STATEMENT  BESKNU
  5184.       KK = -I1MACH(12)
  5185.       ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0)
  5186.       AK = R1MACH(3)
  5187.       TOL = MAX(AK,1.0E-15)
  5188.       IF (X.LE.0.0E0) GO TO 350
  5189.       IF (FNU.LT.0.0E0) GO TO 360
  5190.       IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370
  5191.       IF (N.LT.1) GO TO 380
  5192.       NZ = 0
  5193.       IFLAG = 0
  5194.       KODED = KODE
  5195.       RX = 2.0E0/X
  5196.       INU = INT(FNU+0.5E0)
  5197.       DNU = FNU - INU
  5198.       IF (ABS(DNU).EQ.0.5E0) GO TO 120
  5199.       DNU2 = 0.0E0
  5200.       IF (ABS(DNU).LT.TOL) GO TO 10
  5201.       DNU2 = DNU*DNU
  5202.    10 CONTINUE
  5203.       IF (X.GT.X1) GO TO 120
  5204. C
  5205. C     SERIES FOR X.LE.X1
  5206. C
  5207.       A1 = 1.0E0 - DNU
  5208.       A2 = 1.0E0 + DNU
  5209.       T1 = 1.0E0/GAMMA(A1)
  5210.       T2 = 1.0E0/GAMMA(A2)
  5211.       IF (ABS(DNU).GT.0.1E0) GO TO 40
  5212. C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
  5213.       S = CC(1)
  5214.       AK = 1.0E0
  5215.       DO 20 K=2,8
  5216.         AK = AK*DNU2
  5217.         TM = CC(K)*AK
  5218.         S = S + TM
  5219.         IF (ABS(TM).LT.TOL) GO TO 30
  5220.    20 CONTINUE
  5221.    30 G1 = -S
  5222.       GO TO 50
  5223.    40 CONTINUE
  5224.       G1 = (T1-T2)/(DNU+DNU)
  5225.    50 CONTINUE
  5226.       G2 = (T1+T2)*0.5E0
  5227.       SMU = 1.0E0
  5228.       FC = 1.0E0
  5229.       FLRX = LOG(RX)
  5230.       FMU = DNU*FLRX
  5231.       IF (DNU.EQ.0.0E0) GO TO 60
  5232.       FC = DNU*PI
  5233.       FC = FC/SIN(FC)
  5234.       IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
  5235.    60 CONTINUE
  5236.       F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
  5237.       FC = EXP(FMU)
  5238.       P = 0.5E0*FC/T2
  5239.       Q = 0.5E0/(FC*T1)
  5240.       AK = 1.0E0
  5241.       CK = 1.0E0
  5242.       BK = 1.0E0
  5243.       S1 = F
  5244.       S2 = P
  5245.       IF (INU.GT.0 .OR. N.GT.1) GO TO 90
  5246.       IF (X.LT.TOL) GO TO 80
  5247.       CX = X*X*0.25E0
  5248.    70 CONTINUE
  5249.       F = (AK*F+P+Q)/(BK-DNU2)
  5250.       P = P/(AK-DNU)
  5251.       Q = Q/(AK+DNU)
  5252.       CK = CK*CX/AK
  5253.       T1 = CK*F
  5254.       S1 = S1 + T1
  5255.       BK = BK + AK + AK + 1.0E0
  5256.       AK = AK + 1.0E0
  5257.       S = ABS(T1)/(1.0E0+ABS(S1))
  5258.       IF (S.GT.TOL) GO TO 70
  5259.    80 CONTINUE
  5260.       Y(1) = S1
  5261.       IF (KODED.EQ.1) RETURN
  5262.       Y(1) = S1*EXP(X)
  5263.       RETURN
  5264.    90 CONTINUE
  5265.       IF (X.LT.TOL) GO TO 110
  5266.       CX = X*X*0.25E0
  5267.   100 CONTINUE
  5268.       F = (AK*F+P+Q)/(BK-DNU2)
  5269.       P = P/(AK-DNU)
  5270.       Q = Q/(AK+DNU)
  5271.       CK = CK*CX/AK
  5272.       T1 = CK*F
  5273.       S1 = S1 + T1
  5274.       T2 = CK*(P-AK*F)
  5275.       S2 = S2 + T2
  5276.       BK = BK + AK + AK + 1.0E0
  5277.       AK = AK + 1.0E0
  5278.       S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
  5279.       IF (S.GT.TOL) GO TO 100
  5280.   110 CONTINUE
  5281.       S2 = S2*RX
  5282.       IF (KODED.EQ.1) GO TO 170
  5283.       F = EXP(X)
  5284.       S1 = S1*F
  5285.       S2 = S2*F
  5286.       GO TO 170
  5287.   120 CONTINUE
  5288.       COEF = RTHPI/SQRT(X)
  5289.       IF (KODED.EQ.2) GO TO 130
  5290.       IF (X.GT.ELIM) GO TO 330
  5291.       COEF = COEF*EXP(-X)
  5292.   130 CONTINUE
  5293.       IF (ABS(DNU).EQ.0.5E0) GO TO 340
  5294.       IF (X.GT.X2) GO TO 280
  5295. C
  5296. C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
  5297. C
  5298.       ETEST = COS(PI*DNU)/(PI*X*TOL)
  5299.       FKS = 1.0E0
  5300.       FHS = 0.25E0
  5301.       FK = 0.0E0
  5302.       CK = X + X + 2.0E0
  5303.       P1 = 0.0E0
  5304.       P2 = 1.0E0
  5305.       K = 0
  5306.   140 CONTINUE
  5307.       K = K + 1
  5308.       FK = FK + 1.0E0
  5309.       AK = (FHS-DNU2)/(FKS+FK)
  5310.       BK = CK/(FK+1.0E0)
  5311.       PT = P2
  5312.       P2 = BK*P2 - AK*P1
  5313.       P1 = PT
  5314.       A(K) = AK
  5315.       B(K) = BK
  5316.       CK = CK + 2.0E0
  5317.       FKS = FKS + FK + FK + 1.0E0
  5318.       FHS = FHS + FK + FK
  5319.       IF (ETEST.GT.FK*P1) GO TO 140
  5320.       KK = K
  5321.       S = 1.0E0
  5322.       P1 = 0.0E0
  5323.       P2 = 1.0E0
  5324.       DO 150 I=1,K
  5325.         PT = P2
  5326.         P2 = (B(KK)*P2-P1)/A(KK)
  5327.         P1 = PT
  5328.         S = S + P2
  5329.         KK = KK - 1
  5330.   150 CONTINUE
  5331.       S1 = COEF*(P2/S)
  5332.       IF (INU.GT.0 .OR. N.GT.1) GO TO 160
  5333.       GO TO 200
  5334.   160 CONTINUE
  5335.       S2 = S1*(X+DNU+0.5E0-P1/P2)/X
  5336. C
  5337. C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
  5338. C
  5339.   170 CONTINUE
  5340.       CK = (DNU+DNU+2.0E0)/X
  5341.       IF (N.EQ.1) INU = INU - 1
  5342.       IF (INU.GT.0) GO TO 180
  5343.       IF (N.GT.1) GO TO 200
  5344.       S1 = S2
  5345.       GO TO 200
  5346.   180 CONTINUE
  5347.       DO 190 I=1,INU
  5348.         ST = S2
  5349.         S2 = CK*S2 + S1
  5350.         S1 = ST
  5351.         CK = CK + RX
  5352.   190 CONTINUE
  5353.       IF (N.EQ.1) S1 = S2
  5354.   200 CONTINUE
  5355.       IF (IFLAG.EQ.1) GO TO 220
  5356.       Y(1) = S1
  5357.       IF (N.EQ.1) RETURN
  5358.       Y(2) = S2
  5359.       IF (N.EQ.2) RETURN
  5360.       DO 210 I=3,N
  5361.         Y(I) = CK*Y(I-1) + Y(I-2)
  5362.         CK = CK + RX
  5363.   210 CONTINUE
  5364.       RETURN
  5365. C     IFLAG=1 CASES
  5366.   220 CONTINUE
  5367.       S = -X + LOG(S1)
  5368.       Y(1) = 0.0E0
  5369.       NZ = 1
  5370.       IF (S.LT.-ELIM) GO TO 230
  5371.       Y(1) = EXP(S)
  5372.       NZ = 0
  5373.   230 CONTINUE
  5374.       IF (N.EQ.1) RETURN
  5375.       S = -X + LOG(S2)
  5376.       Y(2) = 0.0E0
  5377.       NZ = NZ + 1
  5378.       IF (S.LT.-ELIM) GO TO 240
  5379.       NZ = NZ - 1
  5380.       Y(2) = EXP(S)
  5381.   240 CONTINUE
  5382.       IF (N.EQ.2) RETURN
  5383.       KK = 2
  5384.       IF (NZ.LT.2) GO TO 260
  5385.       DO 250 I=3,N
  5386.         KK = I
  5387.         ST = S2
  5388.         S2 = CK*S2 + S1
  5389.         S1 = ST
  5390.         CK = CK + RX
  5391.         S = -X + LOG(S2)
  5392.         NZ = NZ + 1
  5393.         Y(I) = 0.0E0
  5394.         IF (S.LT.-ELIM) GO TO 250
  5395.         Y(I) = EXP(S)
  5396.         NZ = NZ - 1
  5397.         GO TO 260
  5398.   250 CONTINUE
  5399.       RETURN
  5400.   260 CONTINUE
  5401.       IF (KK.EQ.N) RETURN
  5402.       S2 = S2*CK + S1
  5403.       CK = CK + RX
  5404.       KK = KK + 1
  5405.       Y(KK) = EXP(-X+LOG(S2))
  5406.       IF (KK.EQ.N) RETURN
  5407.       KK = KK + 1
  5408.       DO 270 I=KK,N
  5409.         Y(I) = CK*Y(I-1) + Y(I-2)
  5410.         CK = CK + RX
  5411.   270 CONTINUE
  5412.       RETURN
  5413. C
  5414. C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
  5415. C
  5416. C     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
  5417. C     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
  5418. C     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
  5419. C     RECURSION
  5420.   280 CONTINUE
  5421.       NN = 2
  5422.       IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
  5423.       DNU2 = DNU + DNU
  5424.       FMU = 0.0E0
  5425.       IF (ABS(DNU2).LT.TOL) GO TO 290
  5426.       FMU = DNU2*DNU2
  5427.   290 CONTINUE
  5428.       EX = X*8.0E0
  5429.       S2 = 0.0E0
  5430.       DO 320 K=1,NN
  5431.         S1 = S2
  5432.         S = 1.0E0
  5433.         AK = 0.0E0
  5434.         CK = 1.0E0
  5435.         SQK = 1.0E0
  5436.         DK = EX
  5437.         DO 300 J=1,30
  5438.           CK = CK*(FMU-SQK)/DK
  5439.           S = S + CK
  5440.           DK = DK + EX
  5441.           AK = AK + 8.0E0
  5442.           SQK = SQK + AK
  5443.           IF (ABS(CK).LT.TOL) GO TO 310
  5444.   300   CONTINUE
  5445.   310   S2 = S*COEF
  5446.         FMU = FMU + 8.0E0*DNU + 4.0E0
  5447.   320 CONTINUE
  5448.       IF (NN.GT.1) GO TO 170
  5449.       S1 = S2
  5450.       GO TO 200
  5451.   330 CONTINUE
  5452.       KODED = 2
  5453.       IFLAG = 1
  5454.       GO TO 120
  5455. C
  5456. C     FNU=HALF ODD INTEGER CASE
  5457. C
  5458.   340 CONTINUE
  5459.       S1 = COEF
  5460.       S2 = COEF
  5461.       GO TO 170
  5462. C
  5463. C
  5464.   350 CALL XERMSG ('SLATEC', 'BESKNU', 'X NOT GREATER THAN ZERO', 2, 1)
  5465.       RETURN
  5466.   360 CALL XERMSG ('SLATEC', 'BESKNU', 'FNU NOT ZERO OR POSITIVE', 2,
  5467.      +   1)
  5468.       RETURN
  5469.   370 CALL XERMSG ('SLATEC', 'BESKNU', 'KODE NOT 1 OR 2', 2, 1)
  5470.       RETURN
  5471.   380 CALL XERMSG ('SLATEC', 'BESKNU', 'N NOT GREATER THAN 0', 2, 1)
  5472.       RETURN
  5473.       END
  5474. *DECK BESKS
  5475.       SUBROUTINE BESKS (XNU, X, NIN, BK)
  5476. C***BEGIN PROLOGUE  BESKS
  5477. C***PURPOSE  Compute a sequence of modified Bessel functions of the
  5478. C            third kind of fractional order.
  5479. C***LIBRARY   SLATEC (FNLIB)
  5480. C***CATEGORY  C10B3
  5481. C***TYPE      SINGLE PRECISION (BESKS-S, DBESKS-D)
  5482. C***KEYWORDS  FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION,
  5483. C             SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS,
  5484. C             THIRD KIND
  5485. C***AUTHOR  Fullerton, W., (LANL)
  5486. C***DESCRIPTION
  5487. C
  5488. C BESKS computes a sequence of modified Bessel functions of the third
  5489. C kind of order XNU + I at X, where X .GT. 0, XNU lies in (-1,1),
  5490. C and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... ,
  5491. C NIN + 1, if NIN is negative.  On return, the vector BK(.) Contains
  5492. C the results at X for order starting at XNU.
  5493. C
  5494. C***REFERENCES  (NONE)
  5495. C***ROUTINES CALLED  BESKES, R1MACH, XERMSG
  5496. C***REVISION HISTORY  (YYMMDD)
  5497. C   770601  DATE WRITTEN
  5498. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5499. C   890531  REVISION DATE from Version 3.2
  5500. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5501. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5502. C   900326  Removed duplicate information from DESCRIPTION section.
  5503. C           (WRB)
  5504. C***END PROLOGUE  BESKS
  5505.       DIMENSION BK(*)
  5506.       SAVE XMAX
  5507.       DATA XMAX / 0.0 /
  5508. C***FIRST EXECUTABLE STATEMENT  BESKS
  5509.       IF (XMAX.EQ.0.0) XMAX = -LOG (R1MACH(1))
  5510. C
  5511.       IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESKS',
  5512.      +   'X SO BIG BESSEL K UNDERFLOWS', 1, 2)
  5513. C
  5514.       CALL BESKES (XNU, X, NIN, BK)
  5515. C
  5516.       EXPXI = EXP (-X)
  5517.       N = ABS (NIN)
  5518.       DO 20 I=1,N
  5519.         BK(I) = EXPXI * BK(I)
  5520.  20   CONTINUE
  5521. C
  5522.       RETURN
  5523.       END
  5524. *DECK BESY
  5525.       SUBROUTINE BESY (X, FNU, N, Y)
  5526. C***BEGIN PROLOGUE  BESY
  5527. C***PURPOSE  Implement forward recursion on the three term recursion
  5528. C            relation for a sequence of non-negative order Bessel
  5529. C            functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
  5530. C            X and non-negative orders FNU.
  5531. C***LIBRARY   SLATEC
  5532. C***CATEGORY  C10A3
  5533. C***TYPE      SINGLE PRECISION (BESY-S, DBESY-D)
  5534. C***KEYWORDS  SPECIAL FUNCTIONS, Y BESSEL FUNCTION
  5535. C***AUTHOR  Amos, D. E., (SNLA)
  5536. C***DESCRIPTION
  5537. C
  5538. C     Abstract
  5539. C         BESY implements forward recursion on the three term
  5540. C         recursion relation for a sequence of non-negative order Bessel
  5541. C         functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0E0 and
  5542. C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
  5543. C         FNU+1 are obtained from BESYNU which computes by a power
  5544. C         series for X .LE. 2, the K Bessel function of an imaginary
  5545. C         argument for 2 .LT. X .LE. 20 and the asymptotic expansion for
  5546. C         X .GT. 20.
  5547. C
  5548. C         If FNU .GE. NULIM, the uniform asymptotic expansion is coded
  5549. C         in ASYJY for orders FNU and FNU+1 to start the recursion.
  5550. C         NULIM is 70 or 100 depending on whether N=1 or N .GE. 2.  An
  5551. C         overflow test is made on the leading term of the asymptotic
  5552. C         expansion before any extensive computation is done.
  5553. C
  5554. C     Description of Arguments
  5555. C
  5556. C         Input
  5557. C           X      - X .GT. 0.0E0
  5558. C           FNU    - order of the initial Y function, FNU .GE. 0.0E0
  5559. C           N      - number of members in the sequence, N .GE. 1
  5560. C
  5561. C         Output
  5562. C           Y      - a vector whose first N components contain values
  5563. C                    for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N.
  5564. C
  5565. C     Error Conditions
  5566. C         Improper input arguments - a fatal error
  5567. C         Overflow - a fatal error
  5568. C
  5569. C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
  5570. C                 or Large Orders, NPL Mathematical Tables 6, Her
  5571. C                 Majesty's Stationery Office, London, 1962.
  5572. C               N. M. Temme, On the numerical evaluation of the modified
  5573. C                 Bessel function of the third kind, Journal of
  5574. C                 Computational Physics 19, (1975), pp. 324-337.
  5575. C               N. M. Temme, On the numerical evaluation of the ordinary
  5576. C                 Bessel function of the second kind, Journal of
  5577. C                 Computational Physics 21, (1976), pp. 343-350.
  5578. C***ROUTINES CALLED  ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH,
  5579. C                    XERMSG, YAIRY
  5580. C***REVISION HISTORY  (YYMMDD)
  5581. C   800501  DATE WRITTEN
  5582. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5583. C   890531  REVISION DATE from Version 3.2
  5584. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5585. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5586. C   900326  Removed duplicate information from DESCRIPTION section.
  5587. C           (WRB)
  5588. C   920501  Reformatted the REFERENCES section.  (WRB)
  5589. C***END PROLOGUE  BESY
  5590. C
  5591.       EXTERNAL YAIRY
  5592.       INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM
  5593.       INTEGER I1MACH
  5594.       REAL       AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX,
  5595.      1           W,WK,W2N,X,XLIM,XXN,Y
  5596.       REAL BESY0, BESY1, R1MACH
  5597.       DIMENSION W(2), NULIM(2), Y(*), WK(7)
  5598.       SAVE NULIM
  5599.       DATA NULIM(1),NULIM(2) / 70 , 100 /
  5600. C***FIRST EXECUTABLE STATEMENT  BESY
  5601.       NN = -I1MACH(12)
  5602.       ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
  5603.       XLIM = R1MACH(1)*1.0E+3
  5604.       IF (FNU.LT.0.0E0) GO TO 140
  5605.       IF (X.LE.0.0E0) GO TO 150
  5606.       IF (X.LT.XLIM) GO TO 170
  5607.       IF (N.LT.1) GO TO 160
  5608. C
  5609. C     ND IS A DUMMY VARIABLE FOR N
  5610. C
  5611.       ND = N
  5612.       NUD = INT(FNU)
  5613.       DNU = FNU - NUD
  5614.       NN = MIN(2,ND)
  5615.       FN = FNU + N - 1
  5616.       IF (FN.LT.2.0E0) GO TO 100
  5617. C
  5618. C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
  5619. C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
  5620. C
  5621.       XXN = X/FN
  5622.       W2N = 1.0E0-XXN*XXN
  5623.       IF(W2N.LE.0.0E0) GO TO 10
  5624.       RAN = SQRT(W2N)
  5625.       AZN = LOG((1.0E0+RAN)/XXN) - RAN
  5626.       CN = FN*AZN
  5627.       IF(CN.GT.ELIM) GO TO 170
  5628.    10 CONTINUE
  5629.       IF (NUD.LT.NULIM(NN)) GO TO 20
  5630. C
  5631. C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
  5632. C
  5633.       FLGJY = -1.0E0
  5634.       CALL ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW)
  5635.       IF(IFLW.NE.0) GO TO 170
  5636.       IF (NN.EQ.1) RETURN
  5637.       TRX = 2.0E0/X
  5638.       TM = (FNU+FNU+2.0E0)/X
  5639.       GO TO 80
  5640. C
  5641.    20 CONTINUE
  5642.       IF (DNU.NE.0.0E0) GO TO 30
  5643.       S1 = BESY0(X)
  5644.       IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70
  5645.       S2 = BESY1(X)
  5646.       GO TO 40
  5647.    30 CONTINUE
  5648.       NB = 2
  5649.       IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
  5650.       CALL BESYNU(X, DNU, NB, W)
  5651.       S1 = W(1)
  5652.       IF (NB.EQ.1) GO TO 70
  5653.       S2 = W(2)
  5654.    40 CONTINUE
  5655.       TRX = 2.0E0/X
  5656.       TM = (DNU+DNU+2.0E0)/X
  5657. C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
  5658.       IF (ND.EQ.1) NUD = NUD - 1
  5659.       IF (NUD.GT.0) GO TO 50
  5660.       IF (ND.GT.1) GO TO 70
  5661.       S1 = S2
  5662.       GO TO 70
  5663.    50 CONTINUE
  5664.       DO 60 I=1,NUD
  5665.         S = S2
  5666.         S2 = TM*S2 - S1
  5667.         S1 = S
  5668.         TM = TM + TRX
  5669.    60 CONTINUE
  5670.       IF (ND.EQ.1) S1 = S2
  5671.    70 CONTINUE
  5672.       Y(1) = S1
  5673.       IF (ND.EQ.1) RETURN
  5674.       Y(2) = S2
  5675.    80 CONTINUE
  5676.       IF (ND.EQ.2) RETURN
  5677. C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
  5678.       DO 90 I=3,ND
  5679.         Y(I) = TM*Y(I-1) - Y(I-2)
  5680.         TM = TM + TRX
  5681.    90 CONTINUE
  5682.       RETURN
  5683. C
  5684.   100 CONTINUE
  5685. C     OVERFLOW TEST
  5686.       IF (FN.LE.1.0E0) GO TO 110
  5687.       IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 170
  5688.   110 CONTINUE
  5689.       IF (DNU.EQ.0.0E0) GO TO 120
  5690.       CALL BESYNU(X, FNU, ND, Y)
  5691.       RETURN
  5692.   120 CONTINUE
  5693.       J = NUD
  5694.       IF (J.EQ.1) GO TO 130
  5695.       J = J + 1
  5696.       Y(J) = BESY0(X)
  5697.       IF (ND.EQ.1) RETURN
  5698.       J = J + 1
  5699.   130 CONTINUE
  5700.       Y(J) = BESY1(X)
  5701.       IF (ND.EQ.1) RETURN
  5702.       TRX = 2.0E0/X
  5703.       TM = TRX
  5704.       GO TO 80
  5705. C
  5706. C
  5707. C
  5708.   140 CONTINUE
  5709.       CALL XERMSG ('SLATEC', 'BESY', 'ORDER, FNU, LESS THAN ZERO', 2,
  5710.      +   1)
  5711.       RETURN
  5712.   150 CONTINUE
  5713.       CALL XERMSG ('SLATEC', 'BESY', 'X LESS THAN OR EQUAL TO ZERO', 2,
  5714.      +   1)
  5715.       RETURN
  5716.   160 CONTINUE
  5717.       CALL XERMSG ('SLATEC', 'BESY', 'N LESS THAN ONE', 2, 1)
  5718.       RETURN
  5719.   170 CONTINUE
  5720.       CALL XERMSG ('SLATEC', 'BESY',
  5721.      +   'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1)
  5722.       RETURN
  5723.       END
  5724. *DECK BESY0
  5725.       FUNCTION BESY0 (X)
  5726. C***BEGIN PROLOGUE  BESY0
  5727. C***PURPOSE  Compute the Bessel function of the second kind of order
  5728. C            zero.
  5729. C***LIBRARY   SLATEC (FNLIB)
  5730. C***CATEGORY  C10A1
  5731. C***TYPE      SINGLE PRECISION (BESY0-S, DBESY0-D)
  5732. C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND,
  5733. C             SPECIAL FUNCTIONS
  5734. C***AUTHOR  Fullerton, W., (LANL)
  5735. C***DESCRIPTION
  5736. C
  5737. C BESY0(X) calculates the Bessel function of the second kind
  5738. C of order zero for real argument X.
  5739. C
  5740. C Series for BY0        on the interval  0.          to  1.60000D+01
  5741. C                                        with weighted error   1.20E-17
  5742. C                                         log weighted error  16.92
  5743. C                               significant figures required  16.15
  5744. C                                    decimal places required  17.48
  5745. C
  5746. C Series for BM0        on the interval  0.          to  6.25000D-02
  5747. C                                        with weighted error   4.98E-17
  5748. C                                         log weighted error  16.30
  5749. C                               significant figures required  14.97
  5750. C                                    decimal places required  16.96
  5751. C
  5752. C Series for BTH0       on the interval  0.          to  6.25000D-02
  5753. C                                        with weighted error   3.67E-17
  5754. C                                         log weighted error  16.44
  5755. C                               significant figures required  15.53
  5756. C                                    decimal places required  17.13
  5757. C
  5758. C***REFERENCES  (NONE)
  5759. C***ROUTINES CALLED  BESJ0, CSEVL, INITS, R1MACH, XERMSG
  5760. C***REVISION HISTORY  (YYMMDD)
  5761. C   770401  DATE WRITTEN
  5762. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5763. C   890531  REVISION DATE from Version 3.2
  5764. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5765. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5766. C   900326  Removed duplicate information from DESCRIPTION section.
  5767. C           (WRB)
  5768. C***END PROLOGUE  BESY0
  5769.       DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24)
  5770.       LOGICAL FIRST
  5771.       SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4,
  5772.      1 NTY0, NTM0, NTTH0, XSML, XMAX, FIRST
  5773.       DATA BY0CS( 1) /   -.0112778393 92865573E0 /
  5774.       DATA BY0CS( 2) /   -.1283452375 6042035E0 /
  5775.       DATA BY0CS( 3) /   -.1043788479 9794249E0 /
  5776.       DATA BY0CS( 4) /    .0236627491 83969695E0 /
  5777.       DATA BY0CS( 5) /   -.0020903916 47700486E0 /
  5778.       DATA BY0CS( 6) /    .0001039754 53939057E0 /
  5779.       DATA BY0CS( 7) /   -.0000033697 47162423E0 /
  5780.       DATA BY0CS( 8) /    .0000000772 93842676E0 /
  5781.       DATA BY0CS( 9) /   -.0000000013 24976772E0 /
  5782.       DATA BY0CS(10) /    .0000000000 17648232E0 /
  5783.       DATA BY0CS(11) /   -.0000000000 00188105E0 /
  5784.       DATA BY0CS(12) /    .0000000000 00001641E0 /
  5785.       DATA BY0CS(13) /   -.0000000000 00000011E0 /
  5786.       DATA BM0CS( 1) /    .0928496163 7381644E0 /
  5787.       DATA BM0CS( 2) /   -.0014298770 7403484E0 /
  5788.       DATA BM0CS( 3) /    .0000283057 9271257E0 /
  5789.       DATA BM0CS( 4) /   -.0000014330 0611424E0 /
  5790.       DATA BM0CS( 5) /    .0000001202 8628046E0 /
  5791.       DATA BM0CS( 6) /   -.0000000139 7113013E0 /
  5792.       DATA BM0CS( 7) /    .0000000020 4076188E0 /
  5793.       DATA BM0CS( 8) /   -.0000000003 5399669E0 /
  5794.       DATA BM0CS( 9) /    .0000000000 7024759E0 /
  5795.       DATA BM0CS(10) /   -.0000000000 1554107E0 /
  5796.       DATA BM0CS(11) /    .0000000000 0376226E0 /
  5797.       DATA BM0CS(12) /   -.0000000000 0098282E0 /
  5798.       DATA BM0CS(13) /    .0000000000 0027408E0 /
  5799.       DATA BM0CS(14) /   -.0000000000 0008091E0 /
  5800.       DATA BM0CS(15) /    .0000000000 0002511E0 /
  5801.       DATA BM0CS(16) /   -.0000000000 0000814E0 /
  5802.       DATA BM0CS(17) /    .0000000000 0000275E0 /
  5803.       DATA BM0CS(18) /   -.0000000000 0000096E0 /
  5804.       DATA BM0CS(19) /    .0000000000 0000034E0 /
  5805.       DATA BM0CS(20) /   -.0000000000 0000012E0 /
  5806.       DATA BM0CS(21) /    .0000000000 0000004E0 /
  5807.       DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
  5808.       DATA BTH0CS( 2) /    .0017370983 07508963E0 /
  5809.       DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
  5810.       DATA BTH0CS( 4) /    .0000043680 50165742E0 /
  5811.       DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
  5812.       DATA BTH0CS( 6) /    .0000000621 97400101E0 /
  5813.       DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
  5814.       DATA BTH0CS( 8) /    .0000000019 79526776E0 /
  5815.       DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
  5816.       DATA BTH0CS(10) /    .0000000001 02035840E0 /
  5817.       DATA BTH0CS(11) /   -.0000000000 26363898E0 /
  5818.       DATA BTH0CS(12) /    .0000000000 07297935E0 /
  5819.       DATA BTH0CS(13) /   -.0000000000 02144188E0 /
  5820.       DATA BTH0CS(14) /    .0000000000 00663693E0 /
  5821.       DATA BTH0CS(15) /   -.0000000000 00215126E0 /
  5822.       DATA BTH0CS(16) /    .0000000000 00072659E0 /
  5823.       DATA BTH0CS(17) /   -.0000000000 00025465E0 /
  5824.       DATA BTH0CS(18) /    .0000000000 00009229E0 /
  5825.       DATA BTH0CS(19) /   -.0000000000 00003448E0 /
  5826.       DATA BTH0CS(20) /    .0000000000 00001325E0 /
  5827.       DATA BTH0CS(21) /   -.0000000000 00000522E0 /
  5828.       DATA BTH0CS(22) /    .0000000000 00000210E0 /
  5829.       DATA BTH0CS(23) /   -.0000000000 00000087E0 /
  5830.       DATA BTH0CS(24) /    .0000000000 00000036E0 /
  5831.       DATA TWODPI / 0.6366197723 6758134E0 /
  5832.       DATA PI4 / 0.7853981633 9744831E0 /
  5833.       DATA FIRST /.TRUE./
  5834. C***FIRST EXECUTABLE STATEMENT  BESY0
  5835.       IF (FIRST) THEN
  5836.          NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3))
  5837.          NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
  5838.          NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
  5839. C
  5840.          XSML = SQRT (4.0*R1MACH(3))
  5841.          XMAX = 1.0/R1MACH(4)
  5842.       ENDIF
  5843.       FIRST = .FALSE.
  5844. C
  5845.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY0',
  5846.      +   'X IS ZERO OR NEGATIVE', 1, 2)
  5847.       IF (X.GT.4.0) GO TO 20
  5848. C
  5849.       Y = 0.
  5850.       IF (X.GT.XSML) Y = X*X
  5851.       BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1.,
  5852.      1  BY0CS, NTY0)
  5853.       RETURN
  5854. C
  5855.  20   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY0',
  5856.      +   'NO PRECISION BECAUSE X IS BIG', 2, 2)
  5857. C
  5858.       Z = 32.0/X**2 - 1.0
  5859.       AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X)
  5860.       THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X
  5861.       BESY0 = AMPL * SIN (THETA)
  5862. C
  5863.       RETURN
  5864.       END
  5865. *DECK BESY1
  5866.       FUNCTION BESY1 (X)
  5867. C***BEGIN PROLOGUE  BESY1
  5868. C***PURPOSE  Compute the Bessel function of the second kind of order
  5869. C            one.
  5870. C***LIBRARY   SLATEC (FNLIB)
  5871. C***CATEGORY  C10A1
  5872. C***TYPE      SINGLE PRECISION (BESY1-S, DBESY1-D)
  5873. C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND,
  5874. C             SPECIAL FUNCTIONS
  5875. C***AUTHOR  Fullerton, W., (LANL)
  5876. C***DESCRIPTION
  5877. C
  5878. C BESY1(X) calculates the Bessel function of the second kind of
  5879. C order one for real argument X.
  5880. C
  5881. C Series for BY1        on the interval  0.          to  1.60000D+01
  5882. C                                        with weighted error   1.87E-18
  5883. C                                         log weighted error  17.73
  5884. C                               significant figures required  17.83
  5885. C                                    decimal places required  18.30
  5886. C
  5887. C Series for BM1        on the interval  0.          to  6.25000D-02
  5888. C                                        with weighted error   5.61E-17
  5889. C                                         log weighted error  16.25
  5890. C                               significant figures required  14.97
  5891. C                                    decimal places required  16.91
  5892. C
  5893. C Series for BTH1       on the interval  0.          to  6.25000D-02
  5894. C                                        with weighted error   4.10E-17
  5895. C                                         log weighted error  16.39
  5896. C                               significant figures required  15.96
  5897. C                                    decimal places required  17.08
  5898. C
  5899. C***REFERENCES  (NONE)
  5900. C***ROUTINES CALLED  BESJ1, CSEVL, INITS, R1MACH, XERMSG
  5901. C***REVISION HISTORY  (YYMMDD)
  5902. C   770401  DATE WRITTEN
  5903. C   890531  Changed all specific intrinsics to generic.  (WRB)
  5904. C   890531  REVISION DATE from Version 3.2
  5905. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  5906. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  5907. C   900326  Removed duplicate information from DESCRIPTION section.
  5908. C           (WRB)
  5909. C***END PROLOGUE  BESY1
  5910.       DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24)
  5911.       LOGICAL FIRST
  5912.       SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4,
  5913.      1 NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST
  5914.       DATA BY1CS( 1) /    .0320804710 0611908629E0 /
  5915.       DATA BY1CS( 2) /   1.2627078974 33500450E0 /
  5916.       DATA BY1CS( 3) /    .0064999618 9992317500E0 /
  5917.       DATA BY1CS( 4) /   -.0893616452 8860504117E0 /
  5918.       DATA BY1CS( 5) /    .0132508812 2175709545E0 /
  5919.       DATA BY1CS( 6) /   -.0008979059 1196483523E0 /
  5920.       DATA BY1CS( 7) /    .0000364736 1487958306E0 /
  5921.       DATA BY1CS( 8) /   -.0000010013 7438166600E0 /
  5922.       DATA BY1CS( 9) /    .0000000199 4539657390E0 /
  5923.       DATA BY1CS(10) /   -.0000000003 0230656018E0 /
  5924.       DATA BY1CS(11) /    .0000000000 0360987815E0 /
  5925.       DATA BY1CS(12) /   -.0000000000 0003487488E0 /
  5926.       DATA BY1CS(13) /    .0000000000 0000027838E0 /
  5927.       DATA BY1CS(14) /   -.0000000000 0000000186E0 /
  5928.       DATA BM1CS( 1) /    .1047362510 931285E0 /
  5929.       DATA BM1CS( 2) /    .0044244389 3702345E0 /
  5930.       DATA BM1CS( 3) /   -.0000566163 9504035E0 /
  5931.       DATA BM1CS( 4) /    .0000023134 9417339E0 /
  5932.       DATA BM1CS( 5) /   -.0000001737 7182007E0 /
  5933.       DATA BM1CS( 6) /    .0000000189 3209930E0 /
  5934.       DATA BM1CS( 7) /   -.0000000026 5416023E0 /
  5935.       DATA BM1CS( 8) /    .0000000004 4740209E0 /
  5936.       DATA BM1CS( 9) /   -.0000000000 8691795E0 /
  5937.       DATA BM1CS(10) /    .0000000000 1891492E0 /
  5938.       DATA BM1CS(11) /   -.0000000000 0451884E0 /
  5939.       DATA BM1CS(12) /    .0000000000 0116765E0 /
  5940.       DATA BM1CS(13) /   -.0000000000 0032265E0 /
  5941.       DATA BM1CS(14) /    .0000000000 0009450E0 /
  5942.       DATA BM1CS(15) /   -.0000000000 0002913E0 /
  5943.       DATA BM1CS(16) /    .0000000000 0000939E0 /
  5944.       DATA BM1CS(17) /   -.0000000000 0000315E0 /
  5945.       DATA BM1CS(18) /    .0000000000 0000109E0 /
  5946.       DATA BM1CS(19) /   -.0000000000 0000039E0 /
  5947.       DATA BM1CS(20) /    .0000000000 0000014E0 /
  5948.       DATA BM1CS(21) /   -.0000000000 0000005E0 /
  5949.       DATA BTH1CS( 1) /    .7406014102 6313850E0 /
  5950.       DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
  5951.       DATA BTH1CS( 3) /    .0001198185 10964326E0 /
  5952.       DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
  5953.       DATA BTH1CS( 5) /    .0000006554 95621447E0 /
  5954.       DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
  5955.       DATA BTH1CS( 7) /    .0000000133 76886564E0 /
  5956.       DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
  5957.       DATA BTH1CS( 9) /    .0000000005 29495100E0 /
  5958.       DATA BTH1CS(10) /   -.0000000001 24135944E0 /
  5959.       DATA BTH1CS(11) /    .0000000000 31656485E0 /
  5960.       DATA BTH1CS(12) /   -.0000000000 08668640E0 /
  5961.       DATA BTH1CS(13) /    .0000000000 02523758E0 /
  5962.       DATA BTH1CS(14) /   -.0000000000 00775085E0 /
  5963.       DATA BTH1CS(15) /    .0000000000 00249527E0 /
  5964.       DATA BTH1CS(16) /   -.0000000000 00083773E0 /
  5965.       DATA BTH1CS(17) /    .0000000000 00029205E0 /
  5966.       DATA BTH1CS(18) /   -.0000000000 00010534E0 /
  5967.       DATA BTH1CS(19) /    .0000000000 00003919E0 /
  5968.       DATA BTH1CS(20) /   -.0000000000 00001500E0 /
  5969.       DATA BTH1CS(21) /    .0000000000 00000589E0 /
  5970.       DATA BTH1CS(22) /   -.0000000000 00000237E0 /
  5971.       DATA BTH1CS(23) /    .0000000000 00000097E0 /
  5972.       DATA BTH1CS(24) /   -.0000000000 00000040E0 /
  5973.       DATA TWODPI / 0.6366197723 6758134E0 /
  5974.       DATA PI4 / 0.7853981633 9744831E0 /
  5975.       DATA FIRST /.TRUE./
  5976. C***FIRST EXECUTABLE STATEMENT  BESY1
  5977.       IF (FIRST) THEN
  5978.          NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3))
  5979.          NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
  5980.          NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
  5981. C
  5982.          XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01)
  5983.          XSML = SQRT (4.0*R1MACH(3))
  5984.          XMAX = 1.0/R1MACH(4)
  5985.       ENDIF
  5986.       FIRST = .FALSE.
  5987. C
  5988.       IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY1',
  5989.      +   'X IS ZERO OR NEGATIVE', 1, 2)
  5990.       IF (X.GT.4.0) GO TO 20
  5991. C
  5992.       IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESY1',
  5993.      +   'X SO SMALL Y1 OVERFLOWS', 3, 2)
  5994.       Y = 0.
  5995.       IF (X.GT.XSML) Y = X*X
  5996.       BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) +
  5997.      1  (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X
  5998.       RETURN
  5999. C
  6000.  20   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY1',
  6001.      +   'NO PRECISION BECAUSE X IS BIG', 2, 2)
  6002. C
  6003.       Z = 32.0/X**2 - 1.0
  6004.       AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X)
  6005.       THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X
  6006.       BESY1 = AMPL * SIN (THETA)
  6007. C
  6008.       RETURN
  6009.       END
  6010. *DECK BESYNU
  6011.       SUBROUTINE BESYNU (X, FNU, N, Y)
  6012. C***BEGIN PROLOGUE  BESYNU
  6013. C***SUBSIDIARY
  6014. C***PURPOSE  Subsidiary to BESY
  6015. C***LIBRARY   SLATEC
  6016. C***TYPE      SINGLE PRECISION (BESYNU-S, DBSYNU-D)
  6017. C***AUTHOR  Amos, D. E., (SNLA)
  6018. C***DESCRIPTION
  6019. C
  6020. C     Abstract
  6021. C         BESYNU computes N member sequences of Y Bessel functions
  6022. C         Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
  6023. C         positive X. Equations of the references are implemented on
  6024. C         small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X).
  6025. C         Forward recursion with the three term recursion relation
  6026. C         generates higher orders FNU+I-1, I=1,...,N.
  6027. C
  6028. C         To start the recursion FNU is normalized to the interval
  6029. C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
  6030. C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
  6031. C         K Bessel function in terms of the confluent hypergeometric
  6032. C         function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X
  6033. C         Here I is the complex number SQRT(-1.).
  6034. C         For X.GT.X2, the asymptotic expansion for large X is used.
  6035. C         When FNU is a half odd integer, a special formula for
  6036. C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
  6037. C
  6038. C         BESYNU assumes that a significant digit SINH(X) function is
  6039. C         available.
  6040. C
  6041. C     Description of Arguments
  6042. C
  6043. C         Input
  6044. C           X      - X.GT.0.0E0
  6045. C           FNU    - Order of initial Y function, FNU.GE.0.0E0
  6046. C           N      - Number of members of the sequence, N.GE.1
  6047. C
  6048. C         Output
  6049. C           Y      - A vector whose first N components contain values
  6050. C                    for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N.
  6051. C
  6052. C     Error Conditions
  6053. C         Improper input arguments - a fatal error
  6054. C         Overflow - a fatal error
  6055. C
  6056. C***SEE ALSO  BESY
  6057. C***REFERENCES  N. M. Temme, On the numerical evaluation of the ordinary
  6058. C                 Bessel function of the second kind, Journal of
  6059. C                 Computational Physics 21, (1976), pp. 343-350.
  6060. C               N. M. Temme, On the numerical evaluation of the modified
  6061. C                 Bessel function of the third kind, Journal of
  6062. C                 Computational Physics 19, (1975), pp. 324-337.
  6063. C***ROUTINES CALLED  GAMMA, R1MACH, XERMSG
  6064. C***REVISION HISTORY  (YYMMDD)
  6065. C   800501  DATE WRITTEN
  6066. C   890531  Changed all specific intrinsics to generic.  (WRB)
  6067. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6068. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  6069. C   900326  Removed duplicate information from DESCRIPTION section.
  6070. C           (WRB)
  6071. C   900328  Added TYPE section.  (WRB)
  6072. C   900727  Added EXTERNAL statement.  (WRB)
  6073. C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
  6074. C   920501  Reformatted the REFERENCES section.  (WRB)
  6075. C***END PROLOGUE  BESYNU
  6076. C
  6077.       INTEGER I, INU, J, K, KK, N, NN
  6078.       REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT,
  6079.      1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS,
  6080.      2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q,
  6081.      3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S,
  6082.      4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y
  6083.       DIMENSION A(120), RB(120), CB(120), Y(*), CC(8)
  6084.       REAL GAMMA, R1MACH
  6085.       EXTERNAL GAMMA
  6086.       SAVE X1, X2, PI, RTHPI, HPI, CC
  6087.       DATA X1, X2 / 3.0E0, 20.0E0 /
  6088.       DATA PI,RTHPI        / 3.14159265358979E+00, 7.97884560802865E-01/
  6089.       DATA HPI             / 1.57079632679490E+00/
  6090.       DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
  6091.      1                     / 5.77215664901533E-01,-4.20026350340952E-02,
  6092.      2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
  6093.      3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
  6094. C***FIRST EXECUTABLE STATEMENT  BESYNU
  6095.       AK = R1MACH(3)
  6096.       TOL = MAX(AK,1.0E-15)
  6097.       IF (X.LE.0.0E0) GO TO 270
  6098.       IF (FNU.LT.0.0E0) GO TO 280
  6099.       IF (N.LT.1) GO TO 290
  6100.       RX = 2.0E0/X
  6101.       INU = INT(FNU+0.5E0)
  6102.       DNU = FNU - INU
  6103.       IF (ABS(DNU).EQ.0.5E0) GO TO 260
  6104.       DNU2 = 0.0E0
  6105.       IF (ABS(DNU).LT.TOL) GO TO 10
  6106.       DNU2 = DNU*DNU
  6107.    10 CONTINUE
  6108.       IF (X.GT.X1) GO TO 120
  6109. C
  6110. C     SERIES FOR X.LE.X1
  6111. C
  6112.       A1 = 1.0E0 - DNU
  6113.       A2 = 1.0E0 + DNU
  6114.       T1 = 1.0E0/GAMMA(A1)
  6115.       T2 = 1.0E0/GAMMA(A2)
  6116.       IF (ABS(DNU).GT.0.1E0) GO TO 40
  6117. C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
  6118.       S = CC(1)
  6119.       AK = 1.0E0
  6120.       DO 20 K=2,8
  6121.         AK = AK*DNU2
  6122.         TM = CC(K)*AK
  6123.         S = S + TM
  6124.         IF (ABS(TM).LT.TOL) GO TO 30
  6125.    20 CONTINUE
  6126.    30 G1 = -(S+S)
  6127.       GO TO 50
  6128.    40 CONTINUE
  6129.       G1 = (T1-T2)/DNU
  6130.    50 CONTINUE
  6131.       G2 = T1 + T2
  6132.       SMU = 1.0E0
  6133.       FC = 1.0E0/PI
  6134.       FLRX = LOG(RX)
  6135.       FMU = DNU*FLRX
  6136.       TM = 0.0E0
  6137.       IF (DNU.EQ.0.0E0) GO TO 60
  6138.       TM = SIN(DNU*HPI)/DNU
  6139.       TM = (DNU+DNU)*TM*TM
  6140.       FC = DNU/SIN(DNU*PI)
  6141.       IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
  6142.    60 CONTINUE
  6143.       F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
  6144.       FX = EXP(FMU)
  6145.       P = FC*T1*FX
  6146.       Q = FC*T2/FX
  6147.       G = F + TM*Q
  6148.       AK = 1.0E0
  6149.       CK = 1.0E0
  6150.       BK = 1.0E0
  6151.       S1 = G
  6152.       S2 = P
  6153.       IF (INU.GT.0 .OR. N.GT.1) GO TO 90
  6154.       IF (X.LT.TOL) GO TO 80
  6155.       CX = X*X*0.25E0
  6156.    70 CONTINUE
  6157.       F = (AK*F+P+Q)/(BK-DNU2)
  6158.       P = P/(AK-DNU)
  6159.       Q = Q/(AK+DNU)
  6160.       G = F + TM*Q
  6161.       CK = -CK*CX/AK
  6162.       T1 = CK*G
  6163.       S1 = S1 + T1
  6164.       BK = BK + AK + AK + 1.0E0
  6165.       AK = AK + 1.0E0
  6166.       S = ABS(T1)/(1.0E0+ABS(S1))
  6167.       IF (S.GT.TOL) GO TO 70
  6168.    80 CONTINUE
  6169.       Y(1) = -S1
  6170.       RETURN
  6171.    90 CONTINUE
  6172.       IF (X.LT.TOL) GO TO 110
  6173.       CX = X*X*0.25E0
  6174.   100 CONTINUE
  6175.       F = (AK*F+P+Q)/(BK-DNU2)
  6176.       P = P/(AK-DNU)
  6177.       Q = Q/(AK+DNU)
  6178.       G = F + TM*Q
  6179.       CK = -CK*CX/AK
  6180.       T1 = CK*G
  6181.       S1 = S1 + T1
  6182.       T2 = CK*(P-AK*G)
  6183.       S2 = S2 + T2
  6184.       BK = BK + AK + AK + 1.0E0
  6185.       AK = AK + 1.0E0
  6186.       S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
  6187.       IF (S.GT.TOL) GO TO 100
  6188.   110 CONTINUE
  6189.       S2 = -S2*RX
  6190.       S1 = -S1
  6191.       GO TO 160
  6192.   120 CONTINUE
  6193.       COEF = RTHPI/SQRT(X)
  6194.       IF (X.GT.X2) GO TO 210
  6195. C
  6196. C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
  6197. C
  6198.       ETEST = COS(PI*DNU)/(PI*X*TOL)
  6199.       FKS = 1.0E0
  6200.       FHS = 0.25E0
  6201.       FK = 0.0E0
  6202.       RCK = 2.0E0
  6203.       CCK = X + X
  6204.       RP1 = 0.0E0
  6205.       CP1 = 0.0E0
  6206.       RP2 = 1.0E0
  6207.       CP2 = 0.0E0
  6208.       K = 0
  6209.   130 CONTINUE
  6210.       K = K + 1
  6211.       FK = FK + 1.0E0
  6212.       AK = (FHS-DNU2)/(FKS+FK)
  6213.       PT = FK + 1.0E0
  6214.       RBK = RCK/PT
  6215.       CBK = CCK/PT
  6216.       RPT = RP2
  6217.       CPT = CP2
  6218.       RP2 = RBK*RPT - CBK*CPT - AK*RP1
  6219.       CP2 = CBK*RPT + RBK*CPT - AK*CP1
  6220.       RP1 = RPT
  6221.       CP1 = CPT
  6222.       RB(K) = RBK
  6223.       CB(K) = CBK
  6224.       A(K) = AK
  6225.       RCK = RCK + 2.0E0
  6226.       FKS = FKS + FK + FK + 1.0E0
  6227.       FHS = FHS + FK + FK
  6228.       PT = MAX(ABS(RP1),ABS(CP1))
  6229.       FC = (RP1/PT)**2 + (CP1/PT)**2
  6230.       PT = PT*SQRT(FC)*FK
  6231.       IF (ETEST.GT.PT) GO TO 130
  6232.       KK = K
  6233.       RS = 1.0E0
  6234.       CS = 0.0E0
  6235.       RP1 = 0.0E0
  6236.       CP1 = 0.0E0
  6237.       RP2 = 1.0E0
  6238.       CP2 = 0.0E0
  6239.       DO 140 I=1,K
  6240.         RPT = RP2
  6241.         CPT = CP2
  6242.         RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK)
  6243.         CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK)
  6244.         RP1 = RPT
  6245.         CP1 = CPT
  6246.         RS = RS + RP2
  6247.         CS = CS + CP2
  6248.         KK = KK - 1
  6249.   140 CONTINUE
  6250.       PT = MAX(ABS(RS),ABS(CS))
  6251.       FC = (RS/PT)**2 + (CS/PT)**2
  6252.       PT = PT*SQRT(FC)
  6253.       RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT
  6254.       CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT
  6255.       FC = HPI*(DNU-0.5E0) - X
  6256.       P = COS(FC)
  6257.       Q = SIN(FC)
  6258.       S1 = (CS1*Q-RS1*P)*COEF
  6259.       IF (INU.GT.0 .OR. N.GT.1) GO TO 150
  6260.       Y(1) = S1
  6261.       RETURN
  6262.   150 CONTINUE
  6263.       PT = MAX(ABS(RP2),ABS(CP2))
  6264.       FC = (RP2/PT)**2 + (CP2/PT)**2
  6265.       PT = PT*SQRT(FC)
  6266.       RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT
  6267.       CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT
  6268.       CS2 = CS1*CPT - RS1*RPT
  6269.       RS2 = RPT*CS1 + RS1*CPT
  6270.       S2 = (RS2*Q+CS2*P)*COEF/X
  6271. C
  6272. C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
  6273. C
  6274.   160 CONTINUE
  6275.       CK = (DNU+DNU+2.0E0)/X
  6276.       IF (N.EQ.1) INU = INU - 1
  6277.       IF (INU.GT.0) GO TO 170
  6278.       IF (N.GT.1) GO TO 190
  6279.       S1 = S2
  6280.       GO TO 190
  6281.   170 CONTINUE
  6282.       DO 180 I=1,INU
  6283.         ST = S2
  6284.         S2 = CK*S2 - S1
  6285.         S1 = ST
  6286.         CK = CK + RX
  6287.   180 CONTINUE
  6288.       IF (N.EQ.1) S1 = S2
  6289.   190 CONTINUE
  6290.       Y(1) = S1
  6291.       IF (N.EQ.1) RETURN
  6292.       Y(2) = S2
  6293.       IF (N.EQ.2) RETURN
  6294.       DO 200 I=3,N
  6295.         Y(I) = CK*Y(I-1) - Y(I-2)
  6296.         CK = CK + RX
  6297.   200 CONTINUE
  6298.       RETURN
  6299. C
  6300. C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
  6301. C
  6302.   210 CONTINUE
  6303.       NN = 2
  6304.       IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
  6305.       DNU2 = DNU + DNU
  6306.       FMU = 0.0E0
  6307.       IF (ABS(DNU2).LT.TOL) GO TO 220
  6308.       FMU = DNU2*DNU2
  6309.   220 CONTINUE
  6310.       ARG = X - HPI*(DNU+0.5E0)
  6311.       SA = SIN(ARG)
  6312.       SB = COS(ARG)
  6313.       ETX = 8.0E0*X
  6314.       DO 250 K=1,NN
  6315.         S1 = S2
  6316.         T2 = (FMU-1.0E0)/ETX
  6317.         SS = T2
  6318.         RELB = TOL*ABS(T2)
  6319.         T1 = ETX
  6320.         S = 1.0E0
  6321.         FN = 1.0E0
  6322.         AK = 0.0E0
  6323.         DO 230 J=1,13
  6324.           T1 = T1 + ETX
  6325.           AK = AK + 8.0E0
  6326.           FN = FN + AK
  6327.           T2 = -T2*(FMU-FN)/T1
  6328.           S = S + T2
  6329.           T1 = T1 + ETX
  6330.           AK = AK + 8.0E0
  6331.           FN = FN + AK
  6332.           T2 = T2*(FMU-FN)/T1
  6333.           SS = SS + T2
  6334.           IF (ABS(T2).LE.RELB) GO TO 240
  6335.   230   CONTINUE
  6336.   240   S2 = COEF*(S*SA+SS*SB)
  6337.         FMU = FMU + 8.0E0*DNU + 4.0E0
  6338.         TB = SA
  6339.         SA = -SB
  6340.         SB = TB
  6341.   250 CONTINUE
  6342.       IF (NN.GT.1) GO TO 160
  6343.       S1 = S2
  6344.       GO TO 190
  6345. C
  6346. C     FNU=HALF ODD INTEGER CASE
  6347. C
  6348.   260 CONTINUE
  6349.       COEF = RTHPI/SQRT(X)
  6350.       S1 = COEF*SIN(X)
  6351.       S2 = -COEF*COS(X)
  6352.       GO TO 160
  6353. C
  6354. C
  6355.   270 CALL XERMSG ('SLATEC', 'BESYNU', 'X NOT GREATER THAN ZERO', 2, 1)
  6356.       RETURN
  6357.   280 CALL XERMSG ('SLATEC', 'BESYNU', 'FNU NOT ZERO OR POSITIVE', 2,
  6358.      +   1)
  6359.       RETURN
  6360.   290 CALL XERMSG ('SLATEC', 'BESYNU', 'N NOT GREATER THAN 0', 2, 1)
  6361.       RETURN
  6362.       END
  6363. *DECK BETA
  6364.       FUNCTION BETA (A, B)
  6365. C***BEGIN PROLOGUE  BETA
  6366. C***PURPOSE  Compute the complete Beta function.
  6367. C***LIBRARY   SLATEC (FNLIB)
  6368. C***CATEGORY  C7B
  6369. C***TYPE      SINGLE PRECISION (BETA-S, DBETA-D, CBETA-C)
  6370. C***KEYWORDS  COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS
  6371. C***AUTHOR  Fullerton, W., (LANL)
  6372. C***DESCRIPTION
  6373. C
  6374. C BETA computes the complete beta function.
  6375. C
  6376. C Input Parameters:
  6377. C       A   real and positive
  6378. C       B   real and positive
  6379. C
  6380. C***REFERENCES  (NONE)
  6381. C***ROUTINES CALLED  ALBETA, GAMLIM, GAMMA, R1MACH, XERMSG
  6382. C***REVISION HISTORY  (YYMMDD)
  6383. C   770601  DATE WRITTEN
  6384. C   890531  Changed all specific intrinsics to generic.  (WRB)
  6385. C   890531  REVISION DATE from Version 3.2
  6386. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6387. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  6388. C   900326  Removed duplicate information from DESCRIPTION section.
  6389. C           (WRB)
  6390. C   900727  Added EXTERNAL statement.  (WRB)
  6391. C***END PROLOGUE  BETA
  6392.       EXTERNAL GAMMA
  6393.       SAVE XMAX, ALNSML
  6394.       DATA XMAX, ALNSML /0., 0./
  6395. C***FIRST EXECUTABLE STATEMENT  BETA
  6396.       IF (ALNSML.NE.0.0) GO TO 10
  6397.       CALL GAMLIM (XMIN, XMAX)
  6398.       ALNSML = LOG(R1MACH(1))
  6399. C
  6400.  10   IF (A .LE. 0. .OR. B .LE. 0.) CALL XERMSG ('SLATEC', 'BETA',
  6401.      +   'BOTH ARGUMENTS MUST BE GT 0', 2, 2)
  6402. C
  6403.       IF (A+B.LT.XMAX) BETA = GAMMA(A) * GAMMA(B) / GAMMA(A+B)
  6404.       IF (A+B.LT.XMAX) RETURN
  6405. C
  6406.       BETA = ALBETA (A, B)
  6407.       IF (BETA .LT. ALNSML) CALL XERMSG ('SLATEC', 'BETA',
  6408.      +   'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 2)
  6409. C
  6410.       BETA = EXP (BETA)
  6411. C
  6412.       RETURN
  6413.       END
  6414. *DECK BETAI
  6415.       REAL FUNCTION BETAI (X, PIN, QIN)
  6416. C***BEGIN PROLOGUE  BETAI
  6417. C***PURPOSE  Calculate the incomplete Beta function.
  6418. C***LIBRARY   SLATEC (FNLIB)
  6419. C***CATEGORY  C7F
  6420. C***TYPE      SINGLE PRECISION (BETAI-S, DBETAI-D)
  6421. C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
  6422. C***AUTHOR  Fullerton, W., (LANL)
  6423. C***DESCRIPTION
  6424. C
  6425. C   BETAI calculates the REAL incomplete beta function.
  6426. C
  6427. C   The incomplete beta function ratio is the probability that a
  6428. C   random variable from a beta distribution having parameters PIN and
  6429. C   QIN will be less than or equal to X.
  6430. C
  6431. C     -- Input Arguments -- All arguments are REAL.
  6432. C   X      upper limit of integration.  X must be in (0,1) inclusive.
  6433. C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
  6434. C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
  6435. C
  6436. C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
  6437. C                 179, Communications of the ACM 17, 3 (March 1974),
  6438. C                 pp. 156.
  6439. C***ROUTINES CALLED  ALBETA, R1MACH, XERMSG
  6440. C***REVISION HISTORY  (YYMMDD)
  6441. C   770401  DATE WRITTEN
  6442. C   890531  Changed all specific intrinsics to generic.  (WRB)
  6443. C   890531  REVISION DATE from Version 3.2
  6444. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6445. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  6446. C   900326  Removed duplicate information from DESCRIPTION section.
  6447. C           (WRB)
  6448. C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
  6449. C***END PROLOGUE  BETAI
  6450.       LOGICAL FIRST
  6451.       SAVE EPS, ALNEPS, SML, ALNSML, FIRST
  6452.       DATA FIRST /.TRUE./
  6453. C***FIRST EXECUTABLE STATEMENT  BETAI
  6454.       IF (FIRST) THEN
  6455.          EPS = R1MACH(3)
  6456.          ALNEPS = LOG(EPS)
  6457.          SML = R1MACH(1)
  6458.          ALNSML = LOG(SML)
  6459.       ENDIF
  6460.       FIRST = .FALSE.
  6461. C
  6462.       IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI',
  6463.      +   'X IS NOT IN THE RANGE (0,1)', 1, 2)
  6464.       IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI',
  6465.      +   'P AND/OR Q IS LE ZERO', 2, 2)
  6466. C
  6467.       Y = X
  6468.       P = PIN
  6469.       Q = QIN
  6470.       IF (Q.LE.P .AND. X.LT.0.8) GO TO 20
  6471.       IF (X.LT.0.2) GO TO 20
  6472.       Y = 1.0 - Y
  6473.       P = QIN
  6474.       Q = PIN
  6475. C
  6476.  20   IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80
  6477. C
  6478. C EVALUATE THE INFINITE SUM FIRST.
  6479. C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I)
  6480. C
  6481.       PS = Q - AINT(Q)
  6482.       IF (PS.EQ.0.) PS = 1.0
  6483.       XB = P*LOG(Y) -  ALBETA(PS, P) - LOG(P)
  6484.       BETAI = 0.0
  6485.       IF (XB.LT.ALNSML) GO TO 40
  6486. C
  6487.       BETAI = EXP (XB)
  6488.       TERM = BETAI*P
  6489.       IF (PS.EQ.1.0) GO TO 40
  6490. C
  6491.       N = MAX (ALNEPS/LOG(Y), 4.0E0)
  6492.       DO 30 I=1,N
  6493.         TERM = TERM*(I-PS)*Y/I
  6494.         BETAI = BETAI + TERM/(P+I)
  6495.  30   CONTINUE
  6496. C
  6497. C NOW EVALUATE THE FINITE SUM, MAYBE.
  6498. C
  6499.  40   IF (Q.LE.1.0) GO TO 70
  6500. C
  6501.       XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q)
  6502.       IB = MAX (XB/ALNSML, 0.0E0)
  6503.       TERM = EXP (XB - IB*ALNSML)
  6504.       C = 1.0/(1.0-Y)
  6505.       P1 = Q*C/(P+Q-1.)
  6506. C
  6507.       FINSUM = 0.0
  6508.       N = Q
  6509.       IF (Q.EQ.REAL(N)) N = N - 1
  6510.       DO 50 I=1,N
  6511.         IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
  6512.         TERM = (Q-I+1)*C*TERM/(P+Q-I)
  6513. C
  6514.         IF (TERM.GT.1.0) IB = IB - 1
  6515.         IF (TERM.GT.1.0) TERM = TERM*SML
  6516. C
  6517.         IF (IB.EQ.0) FINSUM = FINSUM + TERM
  6518.  50   CONTINUE
  6519. C
  6520.  60   BETAI = BETAI + FINSUM
  6521.  70   IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
  6522.       BETAI = MAX (MIN (BETAI, 1.0), 0.0)
  6523.       RETURN
  6524. C
  6525.  80   BETAI = 0.0
  6526.       XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q)
  6527.       IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB)
  6528.       IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
  6529.       RETURN
  6530. C
  6531.       END
  6532. *DECK BFQAD
  6533.       SUBROUTINE BFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR,
  6534.      +   WORK)
  6535. C***BEGIN PROLOGUE  BFQAD
  6536. C***PURPOSE  Compute the integral of a product of a function and a
  6537. C            derivative of a B-spline.
  6538. C***LIBRARY   SLATEC
  6539. C***CATEGORY  H2A2A1, E3, K6
  6540. C***TYPE      SINGLE PRECISION (BFQAD-S, DBFQAD-D)
  6541. C***KEYWORDS  INTEGRAL OF B-SPLINE, QUADRATURE
  6542. C***AUTHOR  Amos, D. E., (SNLA)
  6543. C***DESCRIPTION
  6544. C
  6545. C     Abstract
  6546. C         BFQAD computes the integral on (X1,X2) of a product of a
  6547. C         function F and the ID-th derivative of a K-th order B-spline,
  6548. C         using the B-representation (T,BCOEF,N,K).  (X1,X2) must be
  6549. C         a subinterval of T(K) .LE. X .le. T(N+1).  An integration
  6550. C         routine BSGQ8 (a modification
  6551. C         of GAUS8), integrates the product on sub-
  6552. C         intervals of (X1,X2) formed by included (distinct) knots.
  6553. C
  6554. C     Description of Arguments
  6555. C         Input
  6556. C           F      - external function of one argument for the
  6557. C                    integrand BF(X)=F(X)*BVALU(T,BCOEF,N,K,ID,X,INBV,
  6558. C                    WORK)
  6559. C           T      - knot array of length N+K
  6560. C           BCOEF  - coefficient array of length N
  6561. C           N      - length of coefficient array
  6562. C           K      - order of B-spline, K .GE. 1
  6563. C           ID     - order of the spline derivative, 0 .LE. ID .LE. K-1
  6564. C                    ID=0 gives the spline function
  6565. C           X1,X2  - end points of quadrature interval in
  6566. C                    T(K) .LE. X .LE. T(N+1)
  6567. C           TOL    - desired accuracy for the quadrature, suggest
  6568. C                    10.*STOL .LT. TOL .LE. 0.1 where STOL is the single
  6569. C                    precision unit roundoff for the machine = R1MACH(4)
  6570. C
  6571. C         Output
  6572. C           QUAD   - integral of BF(X) on (X1,X2)
  6573. C           IERR   - a status code
  6574. C                    IERR=1  normal return
  6575. C                         2  some quadrature on (X1,X2) does not meet
  6576. C                            the requested tolerance.
  6577. C           WORK   - work vector of length 3*K
  6578. C
  6579. C     Error Conditions
  6580. C         X1 or X2 not in T(K) .LE. X .LE. T(N+1) is a fatal error.
  6581. C         TOL not greater than the single precision unit roundoff or
  6582. C         less than 0.1 is a fatal error.
  6583. C         Some quadrature fails to meet the requested tolerance.
  6584. C
  6585. C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
  6586. C                 B-splines, Report SAND79-1825, Sandia Laboratories,
  6587. C                 December 1979.
  6588. C***ROUTINES CALLED  BSGQ8, INTRV, R1MACH, XERMSG
  6589. C***REVISION HISTORY  (YYMMDD)
  6590. C   800901  DATE WRITTEN
  6591. C   890531  Changed all specific intrinsics to generic.  (WRB)
  6592. C   890531  REVISION DATE from Version 3.2
  6593. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6594. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  6595. C   900326  Removed duplicate information from DESCRIPTION section.
  6596. C           (WRB)
  6597. C   920501  Reformatted the REFERENCES section.  (WRB)
  6598. C***END PROLOGUE  BFQAD
  6599. C
  6600. C
  6601.       INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1
  6602.       REAL A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, X1,
  6603.      1 X2
  6604.       REAL R1MACH, F
  6605.       DIMENSION T(*), BCOEF(*), WORK(*)
  6606.       EXTERNAL F
  6607. C***FIRST EXECUTABLE STATEMENT  BFQAD
  6608.       IERR = 1
  6609.       QUAD = 0.0E0
  6610.       IF(K.LT.1) GO TO 100
  6611.       IF(N.LT.K) GO TO 105
  6612.       IF(ID.LT.0 .OR. ID.GE.K) GO TO 110
  6613.       WTOL = R1MACH(4)
  6614.       IF (TOL.LT.WTOL .OR. TOL.GT.0.1E0) GO TO 30
  6615.       AA = MIN(X1,X2)
  6616.       BB = MAX(X1,X2)
  6617.       IF (AA.LT.T(K)) GO TO 20
  6618.       NP1 = N + 1
  6619.       IF (BB.GT.T(NP1)) GO TO 20
  6620.       IF (AA.EQ.BB) RETURN
  6621.       NPK = N + K
  6622. C
  6623.       ILO = 1
  6624.       CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
  6625.       CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
  6626.       IF (IL2.GE.NP1) IL2 = N
  6627.       INBV = 1
  6628.       Q = 0.0E0
  6629.       DO 10 LEFT=IL1,IL2
  6630.         TA = T(LEFT)
  6631.         TB = T(LEFT+1)
  6632.         IF (TA.EQ.TB) GO TO 10
  6633.         A = MAX(AA,TA)
  6634.         B = MIN(BB,TB)
  6635.         CALL BSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK)
  6636.         IF (IFLG.GT.1) IERR = 2
  6637.         Q = Q + ANS
  6638.    10 CONTINUE
  6639.       IF (X1.GT.X2) Q = -Q
  6640.       QUAD = Q
  6641.       RETURN
  6642. C
  6643. C
  6644.    20 CONTINUE
  6645.       CALL XERMSG ('SLATEC', 'BFQAD',
  6646.      +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
  6647.       RETURN
  6648.    30 CONTINUE
  6649.       CALL XERMSG ('SLATEC', 'BFQAD',
  6650.      +   'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' //
  6651.      +   'GREATER THAN 0.1', 2, 1)
  6652.       RETURN
  6653.   100 CONTINUE
  6654.       CALL XERMSG ('SLATEC', 'BFQAD', 'K DOES NOT SATISFY K.GE.1', 2,
  6655.      +   1)
  6656.       RETURN
  6657.   105 CONTINUE
  6658.       CALL XERMSG ('SLATEC', 'BFQAD', 'N DOES NOT SATISFY N.GE.K', 2,
  6659.      +   1)
  6660.       RETURN
  6661.   110 CONTINUE
  6662.       CALL XERMSG ('SLATEC', 'BFQAD',
  6663.      +   'ID DOES NOT SATISFY 0 .LE. ID .LT. K', 2, 1)
  6664.       RETURN
  6665.       END
  6666. *DECK BI
  6667.       FUNCTION BI (X)
  6668. C***BEGIN PROLOGUE  BI
  6669. C***PURPOSE  Evaluate the Bairy function (the Airy function of the
  6670. C            second kind).
  6671. C***LIBRARY   SLATEC (FNLIB)
  6672. C***CATEGORY  C10D
  6673. C***TYPE      SINGLE PRECISION (BI-S, DBI-D)
  6674. C***KEYWORDS  BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
  6675. C***AUTHOR  Fullerton, W., (LANL)
  6676. C***DESCRIPTION
  6677. C
  6678. C BI(X) calculates the Airy function of the second kind for real
  6679. C argument X.
  6680. C
  6681. C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
  6682. C                                        with weighted error   1.88E-19
  6683. C                                         log weighted error  18.72
  6684. C                               significant figures required  17.74
  6685. C                                    decimal places required  19.20
  6686. C
  6687. C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
  6688. C                                        with weighted error   2.61E-17
  6689. C                                         log weighted error  16.58
  6690. C                               significant figures required  15.17
  6691. C                                    decimal places required  17.03
  6692. C
  6693. C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
  6694. C                                        with weighted error   1.11E-17
  6695. C                                         log weighted error  16.95
  6696. C                        approx significant figures required  16.5
  6697. C                                    decimal places required  17.45
  6698. C
  6699. C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
  6700. C                                        with weighted error   1.19E-18
  6701. C                                         log weighted error  17.92
  6702. C                        approx significant figures required  17.2
  6703. C                                    decimal places required  18.42
  6704. C
  6705. C***REFERENCES  (NONE)
  6706. C***ROUTINES CALLED  BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
  6707. C***REVISION HISTORY  (YYMMDD)
  6708. C   770701  DATE WRITTEN
  6709. C   890531  Changed all specific intrinsics to generic.  (WRB)
  6710. C   890531  REVISION DATE from Version 3.2
  6711. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6712. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  6713. C   900326  Removed duplicate information from DESCRIPTION section.
  6714. C           (WRB)
  6715. C***END PROLOGUE  BI
  6716.       DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10)
  6717.       LOGICAL FIRST
  6718.       SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2,
  6719.      1 NBIG2, X3SML, XMAX, FIRST
  6720.       DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
  6721.       DATA BIFCS( 2) /    .1025233583 424944561E0 /
  6722.       DATA BIFCS( 3) /    .0017083092 5073815165E0 /
  6723.       DATA BIFCS( 4) /    .0000118625 4546774468E0 /
  6724.       DATA BIFCS( 5) /    .0000000449 3290701779E0 /
  6725.       DATA BIFCS( 6) /    .0000000001 0698207143E0 /
  6726.       DATA BIFCS( 7) /    .0000000000 0017480643E0 /
  6727.       DATA BIFCS( 8) /    .0000000000 0000020810E0 /
  6728.       DATA BIFCS( 9) /    .0000000000 0000000018E0 /
  6729.       DATA BIGCS( 1) /    .0224662232 4857452E0 /
  6730.       DATA BIGCS( 2) /    .0373647754 5301955E0 /
  6731.       DATA BIGCS( 3) /    .0004447621 8957212E0 /
  6732.       DATA BIGCS( 4) /    .0000024708 0756363E0 /
  6733.       DATA BIGCS( 5) /    .0000000079 1913533E0 /
  6734.       DATA BIGCS( 6) /    .0000000000 1649807E0 /
  6735.       DATA BIGCS( 7) /    .0000000000 0002411E0 /
  6736.       DATA BIGCS( 8) /    .0000000000 0000002E0 /
  6737.       DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
  6738.       DATA BIF2CS( 2) /    .4786249778 63005538E0 /
  6739.       DATA BIF2CS( 3) /    .0251552119 604330118E0 /
  6740.       DATA BIF2CS( 4) /    .0005820693 885232645E0 /
  6741.       DATA BIF2CS( 5) /    .0000074997 659644377E0 /
  6742.       DATA BIF2CS( 6) /    .0000000613 460287034E0 /
  6743.       DATA BIF2CS( 7) /    .0000000003 462753885E0 /
  6744.       DATA BIF2CS( 8) /    .0000000000 014288910E0 /
  6745.       DATA BIF2CS( 9) /    .0000000000 000044962E0 /
  6746.       DATA BIF2CS(10) /    .0000000000 000000111E0 /
  6747.       DATA BIG2CS( 1) /    .0333056621 45514340E0 /
  6748.       DATA BIG2CS( 2) /    .1613092151 23197068E0 /
  6749.       DATA BIG2CS( 3) /    .0063190073 096134286E0 /
  6750.       DATA BIG2CS( 4) /    .0001187904 568162517E0 /
  6751.       DATA BIG2CS( 5) /    .0000013045 345886200E0 /
  6752.       DATA BIG2CS( 6) /    .0000000093 741259955E0 /
  6753.       DATA BIG2CS( 7) /    .0000000000 474580188E0 /
  6754.       DATA BIG2CS( 8) /    .0000000000 001783107E0 /
  6755.       DATA BIG2CS( 9) /    .0000000000 000005167E0 /
  6756.       DATA BIG2CS(10) /    .0000000000 000000011E0 /
  6757.       DATA FIRST /.TRUE./
  6758. C***FIRST EXECUTABLE STATEMENT  BI
  6759.       IF (FIRST) THEN
  6760.          ETA = 0.1*R1MACH(3)
  6761.          NBIF  = INITS (BIFCS , 9, ETA)
  6762.          NBIG  = INITS (BIGCS , 8, ETA)
  6763.          NBIF2 = INITS (BIF2CS, 10, ETA)
  6764.          NBIG2 = INITS (BIG2CS, 10, ETA)
  6765. C
  6766.          X3SML = ETA**0.3333
  6767.          XMAX = (1.5*LOG(R1MACH(2)))**0.6666
  6768.       ENDIF
  6769.       FIRST = .FALSE.
  6770. C
  6771.       IF (X.GE.(-1.0)) GO TO 20
  6772.       CALL R9AIMP (X, XM, THETA)
  6773.       BI = XM * SIN(THETA)
  6774.       RETURN
  6775. C
  6776.  20   IF (X.GT.1.0) GO TO 30
  6777.       Z = 0.0
  6778.       IF (ABS(X).GT.X3SML) Z = X**3
  6779.       BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
  6780.      1  CSEVL (Z, BIGCS, NBIG))
  6781.       RETURN
  6782. C
  6783.  30   IF (X.GT.2.0) GO TO 40
  6784.       Z = (2.0*X**3 - 9.0) / 7.0
  6785.       BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 +
  6786.      1  CSEVL (Z, BIG2CS, NBIG2))
  6787.       RETURN
  6788. C
  6789.  40   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BI',
  6790.      +   'X SO BIG THAT BI OVERFLOWS', 1, 2)
  6791. C
  6792.       BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0)
  6793.       RETURN
  6794. C
  6795.       END
  6796. *DECK BIE
  6797.       FUNCTION BIE (X)
  6798. C***BEGIN PROLOGUE  BIE
  6799. C***PURPOSE  Calculate the Bairy function for a negative argument and an
  6800. C            exponentially scaled Bairy function for a non-negative
  6801. C            argument.
  6802. C***LIBRARY   SLATEC (FNLIB)
  6803. C***CATEGORY  C10D
  6804. C***TYPE      SINGLE PRECISION (BIE-S, DBIE-D)
  6805. C***KEYWORDS  BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB,
  6806. C             SPECIAL FUNCTIONS
  6807. C***AUTHOR  Fullerton, W., (LANL)
  6808. C***DESCRIPTION
  6809. C
  6810. C Evaluate BI(X) for X .LE. 0  and  BI(X)*EXP(ZETA)  where
  6811. C ZETA = 2/3 * X**(3/2)  for X .GE. 0.0
  6812. C
  6813. C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
  6814. C                                        with weighted error   1.88E-19
  6815. C                                         log weighted error  18.72
  6816. C                               significant figures required  17.74
  6817. C                                    decimal places required  19.20
  6818. C
  6819. C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
  6820. C                                        with weighted error   2.61E-17
  6821. C                                         log weighted error  16.58
  6822. C                               significant figures required  15.17
  6823. C                                    decimal places required  17.03
  6824. C
  6825. C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
  6826. C                                        with weighted error   1.11E-17
  6827. C                                         log weighted error  16.95
  6828. C                        approx significant figures required  16.5
  6829. C                                    decimal places required  17.45
  6830. C
  6831. C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
  6832. C                                        with weighted error   1.19E-18
  6833. C                                         log weighted error  17.92
  6834. C                        approx significant figures required  17.2
  6835. C                                    decimal places required  18.42
  6836. C
  6837. C Series for BIP        on the interval  1.25000D-01 to  3.53553D-01
  6838. C                                        with weighted error   1.91E-17
  6839. C                                         log weighted error  16.72
  6840. C                               significant figures required  15.35
  6841. C                                    decimal places required  17.41
  6842. C
  6843. C Series for BIP2       on the interval  0.          to  1.25000D-01
  6844. C                                        with weighted error   1.05E-18
  6845. C                                         log weighted error  17.98
  6846. C                               significant figures required  16.74
  6847. C                                    decimal places required  18.71
  6848. C
  6849. C***REFERENCES  (NONE)
  6850. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
  6851. C***REVISION HISTORY  (YYMMDD)
  6852. C   770701  DATE WRITTEN
  6853. C   890206  REVISION DATE from Version 3.2
  6854. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  6855. C***END PROLOGUE  BIE
  6856.       LOGICAL FIRST
  6857.       DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24),
  6858.      1  BIP2CS(29)
  6859.       SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR,
  6860.      1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST
  6861.       DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
  6862.       DATA BIFCS( 2) /    .1025233583 424944561E0 /
  6863.       DATA BIFCS( 3) /    .0017083092 5073815165E0 /
  6864.       DATA BIFCS( 4) /    .0000118625 4546774468E0 /
  6865.       DATA BIFCS( 5) /    .0000000449 3290701779E0 /
  6866.       DATA BIFCS( 6) /    .0000000001 0698207143E0 /
  6867.       DATA BIFCS( 7) /    .0000000000 0017480643E0 /
  6868.       DATA BIFCS( 8) /    .0000000000 0000020810E0 /
  6869.       DATA BIFCS( 9) /    .0000000000 0000000018E0 /
  6870.       DATA BIGCS( 1) /    .0224662232 4857452E0 /
  6871.       DATA BIGCS( 2) /    .0373647754 5301955E0 /
  6872.       DATA BIGCS( 3) /    .0004447621 8957212E0 /
  6873.       DATA BIGCS( 4) /    .0000024708 0756363E0 /
  6874.       DATA BIGCS( 5) /    .0000000079 1913533E0 /
  6875.       DATA BIGCS( 6) /    .0000000000 1649807E0 /
  6876.       DATA BIGCS( 7) /    .0000000000 0002411E0 /
  6877.       DATA BIGCS( 8) /    .0000000000 0000002E0 /
  6878.       DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
  6879.       DATA BIF2CS( 2) /    .4786249778 63005538E0 /
  6880.       DATA BIF2CS( 3) /    .0251552119 604330118E0 /
  6881.       DATA BIF2CS( 4) /    .0005820693 885232645E0 /
  6882.       DATA BIF2CS( 5) /    .0000074997 659644377E0 /
  6883.       DATA BIF2CS( 6) /    .0000000613 460287034E0 /
  6884.       DATA BIF2CS( 7) /    .0000000003 462753885E0 /
  6885.       DATA BIF2CS( 8) /    .0000000000 014288910E0 /
  6886.       DATA BIF2CS( 9) /    .0000000000 000044962E0 /
  6887.       DATA BIF2CS(10) /    .0000000000 000000111E0 /
  6888.       DATA BIG2CS( 1) /    .0333056621 45514340E0 /
  6889.       DATA BIG2CS( 2) /    .1613092151 23197068E0 /
  6890.       DATA BIG2CS( 3) /    .0063190073 096134286E0 /
  6891.       DATA BIG2CS( 4) /    .0001187904 568162517E0 /
  6892.       DATA BIG2CS( 5) /    .0000013045 345886200E0 /
  6893.       DATA BIG2CS( 6) /    .0000000093 741259955E0 /
  6894.       DATA BIG2CS( 7) /    .0000000000 474580188E0 /
  6895.       DATA BIG2CS( 8) /    .0000000000 001783107E0 /
  6896.       DATA BIG2CS( 9) /    .0000000000 000005167E0 /
  6897.       DATA BIG2CS(10) /    .0000000000 000000011E0 /
  6898.       DATA BIPCS( 1) /   -.0832204747 7943447E0 /
  6899.       DATA BIPCS( 2) /    .0114611892 7371174E0 /
  6900.       DATA BIPCS( 3) /    .0004289644 0718911E0 /
  6901.       DATA BIPCS( 4) /   -.0001490663 9379950E0 /
  6902.       DATA BIPCS( 5) /   -.0000130765 9726787E0 /
  6903.       DATA BIPCS( 6) /    .0000063275 9839610E0 /
  6904.       DATA BIPCS( 7) /   -.0000004222 6696982E0 /
  6905.       DATA BIPCS( 8) /   -.0000001914 7186298E0 /
  6906.       DATA BIPCS( 9) /    .0000000645 3106284E0 /
  6907.       DATA BIPCS(10) /   -.0000000078 4485467E0 /
  6908.       DATA BIPCS(11) /   -.0000000009 6077216E0 /
  6909.       DATA BIPCS(12) /    .0000000007 0004713E0 /
  6910.       DATA BIPCS(13) /   -.0000000001 7731789E0 /
  6911.       DATA BIPCS(14) /    .0000000000 2272089E0 /
  6912.       DATA BIPCS(15) /    .0000000000 0165404E0 /
  6913.       DATA BIPCS(16) /   -.0000000000 0185171E0 /
  6914.       DATA BIPCS(17) /    .0000000000 0059576E0 /
  6915.       DATA BIPCS(18) /   -.0000000000 0012194E0 /
  6916.       DATA BIPCS(19) /    .0000000000 0001334E0 /
  6917.       DATA BIPCS(20) /    .0000000000 0000172E0 /
  6918.       DATA BIPCS(21) /   -.0000000000 0000145E0 /
  6919.       DATA BIPCS(22) /    .0000000000 0000049E0 /
  6920.       DATA BIPCS(23) /   -.0000000000 0000011E0 /
  6921.       DATA BIPCS(24) /    .0000000000 0000001E0 /
  6922.       DATA BIP2CS( 1) /   -.1135967375 85988679E0 /
  6923.       DATA BIP2CS( 2) /    .0041381473 947881595E0 /
  6924.       DATA BIP2CS( 3) /    .0001353470 622119332E0 /
  6925.       DATA BIP2CS( 4) /    .0000104273 166530153E0 /
  6926.       DATA BIP2CS( 5) /    .0000013474 954767849E0 /
  6927.       DATA BIP2CS( 6) /    .0000001696 537405438E0 /
  6928.       DATA BIP2CS( 7) /   -.0000000100 965008656E0 /
  6929.       DATA BIP2CS( 8) /   -.0000000167 291194937E0 /
  6930.       DATA BIP2CS( 9) /   -.0000000045 815364485E0 /
  6931.       DATA BIP2CS(10) /    .0000000003 736681366E0 /
  6932.       DATA BIP2CS(11) /    .0000000005 766930320E0 /
  6933.       DATA BIP2CS(12) /    .0000000000 621812650E0 /
  6934.       DATA BIP2CS(13) /   -.0000000000 632941202E0 /
  6935.       DATA BIP2CS(14) /   -.0000000000 149150479E0 /
  6936.       DATA BIP2CS(15) /    .0000000000 078896213E0 /
  6937.       DATA BIP2CS(16) /    .0000000000 024960513E0 /
  6938.       DATA BIP2CS(17) /   -.0000000000 012130075E0 /
  6939.       DATA BIP2CS(18) /   -.0000000000 003740493E0 /
  6940.       DATA BIP2CS(19) /    .0000000000 002237727E0 /
  6941.       DATA BIP2CS(20) /    .0000000000 000474902E0 /
  6942.       DATA BIP2CS(21) /   -.0000000000 000452616E0 /
  6943.       DATA BIP2CS(22) /   -.0000000000 000030172E0 /
  6944.       DATA BIP2CS(23) /    .0000000000 000091058E0 /
  6945.       DATA BIP2CS(24) /   -.0000000000 000009814E0 /
  6946.       DATA BIP2CS(25) /   -.0000000000 000016429E0 /
  6947.       DATA BIP2CS(26) /    .0000000000 000005533E0 /
  6948.       DATA BIP2CS(27) /    .0000000000 000002175E0 /
  6949.       DATA BIP2CS(28) /   -.0000000000 000001737E0 /
  6950.       DATA BIP2CS(29) /   -.0000000000 000000010E0 /
  6951.       DATA ATR / 8.750690570 8484345 E0 /
  6952.       DATA BTR / -2.093836321 356054 E0 /
  6953.       DATA FIRST /.TRUE./
  6954. C***FIRST EXECUTABLE STATEMENT  BIE
  6955.       IF (FIRST) THEN
  6956.          ETA = 0.1*R1MACH(3)
  6957.          NBIF = INITS (BIFCS, 9, ETA)
  6958.          NBIG = INITS (BIGCS, 8, ETA)
  6959.          NBIF2 = INITS (BIF2CS, 10, ETA)
  6960.          NBIG2 = INITS (BIG2CS, 10, ETA)
  6961.          NBIP  = INITS (BIPCS , 24, ETA)
  6962.          NBIP2 = INITS (BIP2CS, 29, ETA)
  6963. C
  6964.          X3SML = ETA**0.3333
  6965.          X32SML = 1.3104*X3SML**2
  6966.          XBIG = R1MACH(2)**0.6666
  6967.       ENDIF
  6968.       FIRST = .FALSE.
  6969. C
  6970.       IF (X.GE.(-1.0)) GO TO 20
  6971.       CALL R9AIMP (X, XM, THETA)
  6972.       BIE = XM * SIN(THETA)
  6973.       RETURN
  6974. C
  6975.  20   IF (X.GT.1.0) GO TO 30
  6976.       Z = 0.0
  6977.       IF (ABS(X).GT.X3SML) Z = X**3
  6978.       BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
  6979.      1  CSEVL (Z, BIGCS, NBIG))
  6980.       IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0)
  6981.       RETURN
  6982. C
  6983.  30   IF (X.GT.2.0) GO TO 40
  6984.       Z = (2.0*X**3 - 9.0) / 7.0
  6985.       BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2)
  6986.      1  + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) )
  6987.       RETURN
  6988. C
  6989.  40   IF (X.GT.4.0) GO TO 50
  6990.       SQRTX = SQRT(X)
  6991.       Z = ATR/(X*SQRTX) + BTR
  6992.       BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX)
  6993.       RETURN
  6994. C
  6995.  50   SQRTX = SQRT(X)
  6996.       Z = -1.0
  6997.       IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0
  6998.       BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX)
  6999.       RETURN
  7000. C
  7001.       END
  7002. *DECK BINOM
  7003.       FUNCTION BINOM (N, M)
  7004. C***BEGIN PROLOGUE  BINOM
  7005. C***PURPOSE  Compute the binomial coefficients.
  7006. C***LIBRARY   SLATEC (FNLIB)
  7007. C***CATEGORY  C1
  7008. C***TYPE      SINGLE PRECISION (BINOM-S, DBINOM-D)
  7009. C***KEYWORDS  BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS
  7010. C***AUTHOR  Fullerton, W., (LANL)
  7011. C***DESCRIPTION
  7012. C
  7013. C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!).
  7014. C
  7015. C***REFERENCES  (NONE)
  7016. C***ROUTINES CALLED  ALNREL, R1MACH, R9LGMC, XERMSG
  7017. C***REVISION HISTORY  (YYMMDD)
  7018. C   770701  DATE WRITTEN
  7019. C   890531  Changed all specific intrinsics to generic.  (WRB)
  7020. C   890531  REVISION DATE from Version 3.2
  7021. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  7022. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  7023. C   900326  Removed duplicate information from DESCRIPTION section.
  7024. C           (WRB)
  7025. C***END PROLOGUE  BINOM
  7026.       LOGICAL FIRST
  7027.       SAVE SQ2PIL, BILNMX, FINTMX, FIRST
  7028.       DATA SQ2PIL / 0.9189385332 0467274E0 /
  7029.       DATA FIRST /.TRUE./
  7030. C***FIRST EXECUTABLE STATEMENT  BINOM
  7031.       IF (FIRST) THEN
  7032.          BILNMX = LOG (R1MACH(2))
  7033.          FINTMX = 0.9/R1MACH(3)
  7034.       ENDIF
  7035.       FIRST = .FALSE.
  7036. C
  7037.       IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'BINOM',
  7038.      +   'N OR M LT ZERO', 1, 2)
  7039.       IF (N .LT. M) CALL XERMSG ('SLATEC', 'BINOM', 'N LT M', 2, 2)
  7040. C
  7041.       K = MIN (M, N-M)
  7042.       IF (K.GT.20) GO TO 30
  7043.       IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30
  7044. C
  7045.       BINOM = 1.
  7046.       IF (K.EQ.0) RETURN
  7047. C
  7048.       DO 20 I=1,K
  7049.         BINOM = BINOM * REAL(N-I+1)/I
  7050.  20   CONTINUE
  7051. C
  7052.       IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
  7053.       RETURN
  7054. C
  7055. C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM
  7056.  30   IF (K .LT. 9) CALL XERMSG ('SLATEC', 'BINOM',
  7057.      +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
  7058. C
  7059.       XN = N + 1
  7060.       XK = K + 1
  7061.       XNK = N - K + 1
  7062. C
  7063.       CORR = R9LGMC(XN) - R9LGMC(XK) - R9LGMC(XNK)
  7064.       BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN)
  7065.      1  - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR
  7066. C
  7067.       IF (BINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'BINOM',
  7068.      +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
  7069. C
  7070.       BINOM = EXP (BINOM)
  7071.       IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
  7072. C
  7073.       RETURN
  7074.       END
  7075. *DECK BINT4
  7076.       SUBROUTINE BINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T,
  7077.      +   BCOEF, N, K, W)
  7078. C***BEGIN PROLOGUE  BINT4
  7079. C***PURPOSE  Compute the B-representation of a cubic spline
  7080. C            which interpolates given data.
  7081. C***LIBRARY   SLATEC
  7082. C***CATEGORY  E1A
  7083. C***TYPE      SINGLE PRECISION (BINT4-S, DBINT4-D)
  7084. C***KEYWORDS  B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION
  7085. C***AUTHOR  Amos, D. E., (SNLA)
  7086. C***DESCRIPTION
  7087. C
  7088. C     Abstract
  7089. C         BINT4 computes the B representation (T,BCOEF,N,K) of a
  7090. C         cubic spline (K=4) which interpolates data (X(I)),Y(I))),
  7091. C         I=1,NDATA.  Parameters IBCL, IBCR, FBCL, FBCR allow the
  7092. C         specification of the spline first or second derivative at
  7093. C         both X(1) and X(NDATA).  When this data is not specified
  7094. C         by the problem, it is common practice to use a natural
  7095. C         spline by setting second derivatives at X(1) and X(NDATA)
  7096. C         to zero (IBCL=IBCR=2,FBCL=FBCR=0.0).  The spline is defined on
  7097. C         T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at X(I))
  7098. C         values where N=NDATA+2.  The knots T(1), T(2), T(3) lie to
  7099. C         the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4)
  7100. C         lie to the right of T(N+1)=X(NDATA) in increasing order.  If
  7101. C         no extrapolation outside (X(1),X(NDATA)) is anticipated, the
  7102. C         knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)=
  7103. C         T(N+1)=X(NDATA) can be specified by KNTOPT=1.  KNTOPT=2
  7104. C         selects a knot placement for T(1), T(2), T(3) to make the
  7105. C         first 7 knots symmetric about T(4)=X(1) and similarly for
  7106. C         T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA).  KNTOPT=3
  7107. C         allows the user to make his own selection, in increasing
  7108. C         order, for T(1), T(2), T(3) to the left of X(1) and T(N+2),
  7109. C         T(N+3), T(N+4) to the right of X(NDATA) in the work array
  7110. C         W(1) through W(6).  In any case, the interpolation on
  7111. C         T(4) .LE. X .LE. T(N+1) by using function BVALU is unique
  7112. C         for given boundary conditions.
  7113. C
  7114. C     Description of Arguments
  7115. C         Input
  7116. C           X      - X vector of abscissae of length NDATA, distinct
  7117. C                    and in increasing order
  7118. C           Y      - Y vector of ordinates of length NDATA
  7119. C           NDATA  - number of data points, NDATA .GE. 2
  7120. C           IBCL   - selection parameter for left boundary condition
  7121. C                    IBCL = 1 constrain the first derivative at
  7122. C                             X(1) to FBCL
  7123. C                         = 2 constrain the second derivative at
  7124. C                             X(1) to FBCL
  7125. C           IBCR   - selection parameter for right boundary condition
  7126. C                    IBCR = 1 constrain first derivative at
  7127. C                             X(NDATA) to FBCR
  7128. C                    IBCR = 2 constrain second derivative at
  7129. C                             X(NDATA) to FBCR
  7130. C           FBCL   - left boundary values governed by IBCL
  7131. C           FBCR   - right boundary values governed by IBCR
  7132. C           KNTOPT - knot selection parameter
  7133. C                    KNTOPT = 1 sets knot multiplicity at T(4) and
  7134. C                               T(N+1) to 4
  7135. C                           = 2 sets a symmetric placement of knots
  7136. C                               about T(4) and T(N+1)
  7137. C                           = 3 sets TNP)=WNP) and T(N+1+I)=w(3+I),I=1,3
  7138. C                               where WNP),I=1,6 is supplied by the user
  7139. C           W      - work array of dimension at least 5*(NDATA+2)
  7140. C                    if KNTOPT=3, then W(1),W(2),W(3) are knot values to
  7141. C                    the left of X(1) and W(4),W(5),W(6) are knot
  7142. C                    values to the right of X(NDATA) in increasing
  7143. C                    order to be supplied by the user
  7144. C
  7145. C         Output
  7146. C           T      - knot array of length N+4
  7147. C           BCOEF  - B-spline coefficient array of length N
  7148. C           N      - number of coefficients, N=NDATA+2
  7149. C           K      - order of spline, K=4
  7150. C
  7151. C     Error Conditions
  7152. C         Improper  input is a fatal error
  7153. C         Singular system of equations is a fatal error
  7154. C
  7155. C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
  7156. C                 Report SAND78-1968, Sandia Laboratories, March 1979.
  7157. C               Carl de Boor, Package for calculating with B-splines,
  7158. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  7159. C                 pp. 441-472.
  7160. C               Carl de Boor, A Practical Guide to Splines, Applied
  7161. C                 Mathematics Series 27, Springer-Verlag, New York,
  7162. C                 1978.
  7163. C***ROUTINES CALLED  BNFAC, BNSLV, BSPVD, R1MACH, XERMSG
  7164. C***REVISION HISTORY  (YYMMDD)
  7165. C   800901  DATE WRITTEN
  7166. C   890531  Changed all specific intrinsics to generic.  (WRB)
  7167. C   890531  REVISION DATE from Version 3.2
  7168. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  7169. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  7170. C   900326  Removed duplicate information from DESCRIPTION section.
  7171. C           (WRB)
  7172. C   920501  Reformatted the REFERENCES section.  (WRB)
  7173. C***END PROLOGUE  BINT4
  7174. C
  7175.       INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J,
  7176.      1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW
  7177.       REAL BCOEF,FBCL,FBCR,T, TOL,TXN,TX1,VNIKX,W,WDTOL,WORK,X, XL,
  7178.      1 Y
  7179.       REAL R1MACH
  7180.       DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15)
  7181. C***FIRST EXECUTABLE STATEMENT  BINT4
  7182.       WDTOL = R1MACH(4)
  7183.       TOL = SQRT(WDTOL)
  7184.       IF (NDATA.LT.2) GO TO 200
  7185.       NDM = NDATA - 1
  7186.       DO 10 I=1,NDM
  7187.         IF (X(I).GE.X(I+1)) GO TO 210
  7188.    10 CONTINUE
  7189.       IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220
  7190.       IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230
  7191.       IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240
  7192.       K = 4
  7193.       N = NDATA + 2
  7194.       NP = N + 1
  7195.       DO 20 I=1,NDATA
  7196.         T(I+3) = X(I)
  7197.    20 CONTINUE
  7198.       GO TO (30, 50, 90), KNTOPT
  7199. C     SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA)
  7200.    30 CONTINUE
  7201.       DO 40 I=1,3
  7202.         T(4-I) = X(1)
  7203.         T(NP+I) = X(NDATA)
  7204.    40 CONTINUE
  7205.       GO TO 110
  7206. C     SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS
  7207.    50 CONTINUE
  7208.       IF (NDATA.GT.3) GO TO 70
  7209.       XL = (X(NDATA)-X(1))/3.0E0
  7210.       DO 60 I=1,3
  7211.         T(4-I) = T(5-I) - XL
  7212.         T(NP+I) = T(NP+I-1) + XL
  7213.    60 CONTINUE
  7214.       GO TO 110
  7215.    70 CONTINUE
  7216.       TX1 = X(1) + X(1)
  7217.       TXN = X(NDATA) + X(NDATA)
  7218.       DO 80 I=1,3
  7219.         T(4-I) = TX1 - X(I+1)
  7220.         T(NP+I) = TXN - X(NDATA-I)
  7221.    80 CONTINUE
  7222.       GO TO 110
  7223. C     SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE
  7224. C     SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3
  7225.    90 CONTINUE
  7226.       DO 100 I=1,3
  7227.         T(4-I) = W(4-I,1)
  7228.         JW = MAX(1,I-1)
  7229.         IW = MOD(I+2,5)+1
  7230.         T(NP+I) = W(IW,JW)
  7231.         IF (T(4-I).GT.T(5-I)) GO TO 250
  7232.         IF (T(NP+I).LT.T(NP+I-1)) GO TO 250
  7233.   100 CONTINUE
  7234.   110 CONTINUE
  7235. C
  7236.       DO 130 I=1,5
  7237.         DO 120 J=1,N
  7238.           W(I,J) = 0.0E0
  7239.   120   CONTINUE
  7240.   130 CONTINUE
  7241. C     SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR
  7242. C     RIGHT LIMITS
  7243.       IT = IBCL + 1
  7244.       CALL BSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK)
  7245.       IW = 0
  7246.       IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1
  7247.       DO 140 J=1,3
  7248.         W(J+1,4-J) = VNIKX(4-J,IT)
  7249.         W(J,4-J) = VNIKX(4-J,1)
  7250.   140 CONTINUE
  7251.       BCOEF(1) = Y(1)
  7252.       BCOEF(2) = FBCL
  7253. C     SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1
  7254.       ILEFT = 4
  7255.       IF (NDM.LT.2) GO TO 170
  7256.       DO 160 I=2,NDM
  7257.         ILEFT = ILEFT + 1
  7258.         CALL BSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK)
  7259.         DO 150 J=1,3
  7260.           W(J+1,3+I-J) = VNIKX(4-J,1)
  7261.   150   CONTINUE
  7262.         BCOEF(I+1) = Y(I)
  7263.   160 CONTINUE
  7264. C     SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR
  7265. C     LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1))
  7266.   170 CONTINUE
  7267.       IT = IBCR + 1
  7268.       CALL BSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK)
  7269.       JW = 0
  7270.       IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1
  7271.       DO 180 J=1,3
  7272.         W(J+1,3+NDATA-J) = VNIKX(5-J,IT)
  7273.         W(J+2,3+NDATA-J) = VNIKX(5-J,1)
  7274.   180 CONTINUE
  7275.       BCOEF(N-1) = FBCR
  7276.       BCOEF(N) = Y(NDATA)
  7277. C     SOLVE SYSTEM OF EQUATIONS
  7278.       ILB = 2 - JW
  7279.       IUB = 2 - IW
  7280.       NWROW = 5
  7281.       IWP = IW + 1
  7282.       CALL BNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG)
  7283.       IF (IFLAG.EQ.2) GO TO 190
  7284.       CALL BNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF)
  7285.       RETURN
  7286. C
  7287. C
  7288.   190 CONTINUE
  7289.       CALL XERMSG ('SLATEC', 'BINT4',
  7290.      +   'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1)
  7291.       RETURN
  7292.   200 CONTINUE
  7293.       CALL XERMSG ('SLATEC', 'BINT4', 'NDATA IS LESS THAN 2', 2, 1)
  7294.       RETURN
  7295.   210 CONTINUE
  7296.       CALL XERMSG ('SLATEC', 'BINT4',
  7297.      +   'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1)
  7298.       RETURN
  7299.   220 CONTINUE
  7300.       CALL XERMSG ('SLATEC', 'BINT4', 'IBCL IS NOT 1 OR 2', 2, 1)
  7301.       RETURN
  7302.   230 CONTINUE
  7303.       CALL XERMSG ('SLATEC', 'BINT4', 'IBCR IS NOT 1 OR 2', 2, 1)
  7304.       RETURN
  7305.   240 CONTINUE
  7306.       CALL XERMSG ('SLATEC', 'BINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, 1)
  7307.       RETURN
  7308.   250 CONTINUE
  7309.       CALL XERMSG ('SLATEC', 'BINT4',
  7310.      +   'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1)
  7311.       RETURN
  7312.       END
  7313. *DECK BINTK
  7314.       SUBROUTINE BINTK (X, Y, T, N, K, BCOEF, Q, WORK)
  7315. C***BEGIN PROLOGUE  BINTK
  7316. C***PURPOSE  Compute the B-representation of a spline which interpolates
  7317. C            given data.
  7318. C***LIBRARY   SLATEC
  7319. C***CATEGORY  E1A
  7320. C***TYPE      SINGLE PRECISION (BINTK-S, DBINTK-D)
  7321. C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION
  7322. C***AUTHOR  Amos, D. E., (SNLA)
  7323. C***DESCRIPTION
  7324. C
  7325. C     Written by Carl de Boor and modified by D. E. Amos
  7326. C
  7327. C     Abstract
  7328. C
  7329. C         BINTK is the SPLINT routine of the reference.
  7330. C
  7331. C         BINTK produces the B-spline coefficients, BCOEF, of the
  7332. C         B-spline of order K with knots T(I), I=1,...,N+K, which
  7333. C         takes on the value Y(I) at X(I), I=1,...,N.  The spline or
  7334. C         any of its derivatives can be evaluated by calls to BVALU.
  7335. C         The I-th equation of the linear system A*BCOEF = B for the
  7336. C         coefficients of the interpolant enforces interpolation at
  7337. C         X(I)), I=1,...,N.  Hence, B(I) = Y(I), all I, and A is
  7338. C         a band matrix with 2K-1 bands if A is invertible. The matrix
  7339. C         A is generated row by row and stored, diagonal by diagonal,
  7340. C         in the rows of Q, with the main diagonal going into row K.
  7341. C         The banded system is then solved by a call to BNFAC (which
  7342. C         constructs the triangular factorization for A and stores it
  7343. C         again in Q), followed by a call to BNSLV (which then
  7344. C         obtains the solution BCOEF by substitution). BNFAC does no
  7345. C         pivoting, since the total positivity of the matrix A makes
  7346. C         this unnecessary.  The linear system to be solved is
  7347. C         (theoretically) invertible if and only if
  7348. C                 T(I) .LT. X(I)) .LT. T(I+K),        all I.
  7349. C         Equality is permitted on the left for I=1 and on the right
  7350. C         for I=N when K knots are used at X(1) or X(N).  Otherwise,
  7351. C         violation of this condition is certain to lead to an error.
  7352. C
  7353. C     Description of Arguments
  7354. C         Input
  7355. C           X       - vector of length N containing data point abscissa
  7356. C                     in strictly increasing order.
  7357. C           Y       - corresponding vector of length N containing data
  7358. C                     point ordinates.
  7359. C           T       - knot vector of length N+K
  7360. C                     since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K)
  7361. C                     .GE. X(N), this leaves only N-K knots (not nec-
  7362. C                     essarily X(I)) values) interior to (X(1),X(N))
  7363. C           N       - number of data points, N .GE. K
  7364. C           K       - order of the spline, K .GE. 1
  7365. C
  7366. C         Output
  7367. C           BCOEF   - a vector of length N containing the B-spline
  7368. C                     coefficients
  7369. C           Q       - a work vector of length (2*K-1)*N, containing
  7370. C                     the triangular factorization of the coefficient
  7371. C                     matrix of the linear system being solved.  The
  7372. C                     coefficients for the interpolant of an
  7373. C                     additional data set (X(I)),YY(I)), I=1,...,N
  7374. C                     with the same abscissa can be obtained by loading
  7375. C                     YY into BCOEF and then executing
  7376. C                         CALL BNSLV (Q,2K-1,N,K-1,K-1,BCOEF)
  7377. C           WORK    - work vector of length 2*K
  7378. C
  7379. C     Error Conditions
  7380. C         Improper  input is a fatal error
  7381. C         Singular system of equations is a fatal error
  7382. C
  7383. C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
  7384. C                 Report SAND78-1968, Sandia Laboratories, March 1979.
  7385. C               Carl de Boor, Package for calculating with B-splines,
  7386. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  7387. C                 pp. 441-472.
  7388. C               Carl de Boor, A Practical Guide to Splines, Applied
  7389. C                 Mathematics Series 27, Springer-Verlag, New York,
  7390. C                 1978.
  7391. C***ROUTINES CALLED  BNFAC, BNSLV, BSPVN, XERMSG
  7392. C***REVISION HISTORY  (YYMMDD)
  7393. C   800901  DATE WRITTEN
  7394. C   890531  Changed all specific intrinsics to generic.  (WRB)
  7395. C   890831  Modified array declarations.  (WRB)
  7396. C   890831  REVISION DATE from Version 3.2
  7397. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  7398. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  7399. C   900326  Removed duplicate information from DESCRIPTION section.
  7400. C           (WRB)
  7401. C   920501  Reformatted the REFERENCES section.  (WRB)
  7402. C***END PROLOGUE  BINTK
  7403. C
  7404.       INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT,
  7405.      1 LENQ, NP1
  7406.       REAL BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*)
  7407. C     DIMENSION Q(2*K-1,N), T(N+K)
  7408. C***FIRST EXECUTABLE STATEMENT  BINTK
  7409.       IF(K.LT.1) GO TO 100
  7410.       IF(N.LT.K) GO TO 105
  7411.       JJ = N - 1
  7412.       IF(JJ.EQ.0) GO TO 6
  7413.       DO 5 I=1,JJ
  7414.       IF(X(I).GE.X(I+1)) GO TO 110
  7415.     5 CONTINUE
  7416.     6 CONTINUE
  7417.       NP1 = N + 1
  7418.       KM1 = K - 1
  7419.       KPKM2 = 2*KM1
  7420.       LEFT = K
  7421. C                ZERO OUT ALL ENTRIES OF Q
  7422.       LENQ = N*(K+KM1)
  7423.       DO 10 I=1,LENQ
  7424.         Q(I) = 0.0E0
  7425.    10 CONTINUE
  7426. C
  7427. C  ***   LOOP OVER I TO CONSTRUCT THE  N  INTERPOLATION EQUATIONS
  7428.       DO 50 I=1,N
  7429.         XI = X(I)
  7430.         ILP1MX = MIN(I+K,NP1)
  7431. C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
  7432. C                T(LEFT) .LE. X(I) .LT. T(LEFT+1)
  7433. C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
  7434.         LEFT = MAX(LEFT,I)
  7435.         IF (XI.LT.T(LEFT)) GO TO 80
  7436.    20   IF (XI.LT.T(LEFT+1)) GO TO 30
  7437.         LEFT = LEFT + 1
  7438.         IF (LEFT.LT.ILP1MX) GO TO 20
  7439.         LEFT = LEFT - 1
  7440.         IF (XI.GT.T(LEFT+1)) GO TO 80
  7441. C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE
  7442. C        A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE  K  ENTRIES WITH  J =
  7443. C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
  7444. C        ARE RETURNED, IN  BCOEF (USED FOR TEMP.STORAGE HERE), BY THE
  7445. C        FOLLOWING
  7446.    30   CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK)
  7447. C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO
  7448. C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
  7449. C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J,  IF WE CONSIDER  Q
  7450. C        AS A TWO-DIM. ARRAY , WITH  2*K-1  ROWS (SEE COMMENTS IN
  7451. C        BNFAC). IN THE PRESENT PROGRAM, WE TREAT  Q  AS AN EQUIVALENT
  7452. C        ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON
  7453. C        DIMENSION STATEMENTS) . WE THEREFORE WANT  BCOEF(J) TO GO INTO
  7454. C        ENTRY
  7455. C            I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
  7456. C                   =  I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J
  7457. C        OF  Q .
  7458.         JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1)
  7459.         DO 40 J=1,K
  7460.           JJ = JJ + KPKM2
  7461.           Q(JJ) = BCOEF(J)
  7462.    40   CONTINUE
  7463.    50 CONTINUE
  7464. C
  7465. C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
  7466.       CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG)
  7467.       GO TO (60, 90), IFLAG
  7468. C     *** SOLVE  A*BCOEF = Y  BY BACKSUBSTITUTION
  7469.    60 DO 70 I=1,N
  7470.         BCOEF(I) = Y(I)
  7471.    70 CONTINUE
  7472.       CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF)
  7473.       RETURN
  7474. C
  7475. C
  7476.    80 CONTINUE
  7477.       CALL XERMSG ('SLATEC', 'BINTK',
  7478.      +   'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' //
  7479.      +   'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1)
  7480.       RETURN
  7481.    90 CONTINUE
  7482.       CALL XERMSG ('SLATEC', 'BINTK',
  7483.      +   'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' //
  7484.      +   'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.',
  7485.      +   8, 1)
  7486.       RETURN
  7487.   100 CONTINUE
  7488.       CALL XERMSG ('SLATEC', 'BINTK', 'K DOES NOT SATISFY K.GE.1', 2,
  7489.      +   1)
  7490.       RETURN
  7491.   105 CONTINUE
  7492.       CALL XERMSG ('SLATEC', 'BINTK', 'N DOES NOT SATISFY N.GE.K', 2,
  7493.      +   1)
  7494.       RETURN
  7495.   110 CONTINUE
  7496.       CALL XERMSG ('SLATEC', 'BINTK',
  7497.      +   'X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOME I', 2, 1)
  7498.       RETURN
  7499.       END
  7500. *DECK BISECT
  7501.       SUBROUTINE BISECT (N, EPS1, D, E, E2, LB, UB, MM, M, W, IND, IERR,
  7502.      +   RV4, RV5)
  7503. C***BEGIN PROLOGUE  BISECT
  7504. C***PURPOSE  Compute the eigenvalues of a symmetric tridiagonal matrix
  7505. C            in a given interval using Sturm sequencing.
  7506. C***LIBRARY   SLATEC (EISPACK)
  7507. C***CATEGORY  D4A5, D4C2A
  7508. C***TYPE      SINGLE PRECISION (BISECT-S)
  7509. C***KEYWORDS  EIGENVALUES, EISPACK
  7510. C***AUTHOR  Smith, B. T., et al.
  7511. C***DESCRIPTION
  7512. C
  7513. C     This subroutine is a translation of the bisection technique
  7514. C     in the ALGOL procedure TRISTURM by Peters and Wilkinson.
  7515. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
  7516. C
  7517. C     This subroutine finds those eigenvalues of a TRIDIAGONAL
  7518. C     SYMMETRIC matrix which lie in a specified interval,
  7519. C     using bisection.
  7520. C
  7521. C     On INPUT
  7522. C
  7523. C        N is the order of the matrix.  N is an INTEGER variable.
  7524. C
  7525. C        EPS1 is an absolute error tolerance for the computed
  7526. C          eigenvalues.  If the input EPS1 is non-positive,
  7527. C          it is reset for each submatrix to a default value,
  7528. C          namely, minus the product of the relative machine
  7529. C          precision and the 1-norm of the submatrix.
  7530. C          EPS1 is a REAL variable.
  7531. C
  7532. C        D contains the diagonal elements of the input matrix.
  7533. C          D is a one-dimensional REAL array, dimensioned D(N).
  7534. C
  7535. C        E contains the subdiagonal elements of the input matrix
  7536. C          in its last N-1 positions.  E(1) is arbitrary.
  7537. C          E is a one-dimensional REAL array, dimensioned E(N).
  7538. C
  7539. C        E2 contains the squares of the corresponding elements of E.
  7540. C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
  7541. C          dimensioned E2(N).
  7542. C
  7543. C        LB and UB define the interval to be searched for eigenvalues.
  7544. C          If LB is not less than UB, no eigenvalues will be found.
  7545. C          LB and UB are REAL variables.
  7546. C
  7547. C        MM should be set to an upper bound for the number of
  7548. C          eigenvalues in the interval.  WARNING - If more than
  7549. C          MM eigenvalues are determined to lie in the interval,
  7550. C          an error return is made with no eigenvalues found.
  7551. C          MM is an INTEGER variable.
  7552. C
  7553. C     On OUTPUT
  7554. C
  7555. C        EPS1 is unaltered unless it has been reset to its
  7556. C          (last) default value.
  7557. C
  7558. C        D and E are unaltered.
  7559. C
  7560. C        Elements of E2, corresponding to elements of E regarded
  7561. C          as negligible, have been replaced by zero causing the
  7562. C          matrix to split into a direct sum of submatrices.
  7563. C          E2(1) is also set to zero.
  7564. C
  7565. C        M is the number of eigenvalues determined to lie in (LB,UB).
  7566. C          M is an INTEGER variable.
  7567. C
  7568. C        W contains the M eigenvalues in ascending order.
  7569. C          W is a one-dimensional REAL array, dimensioned W(MM).
  7570. C
  7571. C        IND contains in its first M positions the submatrix indices
  7572. C          associated with the corresponding eigenvalues in W --
  7573. C          1 for eigenvalues belonging to the first submatrix from
  7574. C          the top, 2 for those belonging to the second submatrix, etc.
  7575. C          IND is an one-dimensional INTEGER array, dimensioned IND(MM).
  7576. C
  7577. C        IERR is an INTEGER flag set to
  7578. C          Zero       for normal return,
  7579. C          3*N+1      if M exceeds MM.  In this case, M contains the
  7580. C                     number of eigenvalues determined to lie in
  7581. C                     (LB,UB).
  7582. C
  7583. C        RV4 and RV5 are one-dimensional REAL arrays used for temporary
  7584. C          storage, dimensioned RV4(N) and RV5(N).
  7585. C
  7586. C     The ALGOL procedure STURMCNT contained in TRISTURM
  7587. C     appears in BISECT in-line.
  7588. C
  7589. C     Note that subroutine TQL1 or IMTQL1 is generally faster than
  7590. C     BISECT, if more than N/4 eigenvalues are to be found.
  7591. C
  7592. C     Questions and comments should be directed to B. S. Garbow,
  7593. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  7594. C     ------------------------------------------------------------------
  7595. C
  7596. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  7597. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  7598. C                 system Routines - EISPACK Guide, Springer-Verlag,
  7599. C                 1976.
  7600. C***ROUTINES CALLED  R1MACH
  7601. C***REVISION HISTORY  (YYMMDD)
  7602. C   760101  DATE WRITTEN
  7603. C   890531  Changed all specific intrinsics to generic.  (WRB)
  7604. C   890831  Modified array declarations.  (WRB)
  7605. C   890831  REVISION DATE from Version 3.2
  7606. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  7607. C   920501  Reformatted the REFERENCES section.  (WRB)
  7608. C***END PROLOGUE  BISECT
  7609. C
  7610.       INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
  7611.       REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*)
  7612.       REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2
  7613.       INTEGER IND(*)
  7614.       LOGICAL FIRST
  7615. C
  7616.       SAVE FIRST, MACHEP
  7617.       DATA FIRST /.TRUE./
  7618. C***FIRST EXECUTABLE STATEMENT  BISECT
  7619.       IF (FIRST) THEN
  7620.          MACHEP = R1MACH(4)
  7621.       ENDIF
  7622.       FIRST = .FALSE.
  7623. C
  7624.       IERR = 0
  7625.       TAG = 0
  7626.       T1 = LB
  7627.       T2 = UB
  7628. C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
  7629.       DO 40 I = 1, N
  7630.          IF (I .EQ. 1) GO TO 20
  7631.          S1 = ABS(D(I)) + ABS(D(I-1))
  7632.          S2 = S1 + ABS(E(I))
  7633.          IF (S2 .GT. S1) GO TO 40
  7634.    20    E2(I) = 0.0E0
  7635.    40 CONTINUE
  7636. C     .......... DETERMINE THE NUMBER OF EIGENVALUES
  7637. C                IN THE INTERVAL ..........
  7638.       P = 1
  7639.       Q = N
  7640.       X1 = UB
  7641.       ISTURM = 1
  7642.       GO TO 320
  7643.    60 M = S
  7644.       X1 = LB
  7645.       ISTURM = 2
  7646.       GO TO 320
  7647.    80 M = M - S
  7648.       IF (M .GT. MM) GO TO 980
  7649.       Q = 0
  7650.       R = 0
  7651. C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
  7652. C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  7653.   100 IF (R .EQ. M) GO TO 1001
  7654.       TAG = TAG + 1
  7655.       P = Q + 1
  7656.       XU = D(P)
  7657.       X0 = D(P)
  7658.       U = 0.0E0
  7659. C
  7660.       DO 120 Q = P, N
  7661.          X1 = U
  7662.          U = 0.0E0
  7663.          V = 0.0E0
  7664.          IF (Q .EQ. N) GO TO 110
  7665.          U = ABS(E(Q+1))
  7666.          V = E2(Q+1)
  7667.   110    XU = MIN(D(Q)-(X1+U),XU)
  7668.          X0 = MAX(D(Q)+(X1+U),X0)
  7669.          IF (V .EQ. 0.0E0) GO TO 140
  7670.   120 CONTINUE
  7671. C
  7672.   140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
  7673.       IF (EPS1 .LE. 0.0E0) EPS1 = -X1
  7674.       IF (P .NE. Q) GO TO 180
  7675. C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
  7676.       IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
  7677.       M1 = P
  7678.       M2 = P
  7679.       RV5(P) = D(P)
  7680.       GO TO 900
  7681.   180 X1 = X1 * (Q-P+1)
  7682.       LB = MAX(T1,XU-X1)
  7683.       UB = MIN(T2,X0+X1)
  7684.       X1 = LB
  7685.       ISTURM = 3
  7686.       GO TO 320
  7687.   200 M1 = S + 1
  7688.       X1 = UB
  7689.       ISTURM = 4
  7690.       GO TO 320
  7691.   220 M2 = S
  7692.       IF (M1 .GT. M2) GO TO 940
  7693. C     .......... FIND ROOTS BY BISECTION ..........
  7694.       X0 = UB
  7695.       ISTURM = 5
  7696. C
  7697.       DO 240 I = M1, M2
  7698.          RV5(I) = UB
  7699.          RV4(I) = LB
  7700.   240 CONTINUE
  7701. C     .......... LOOP FOR K-TH EIGENVALUE
  7702. C                FOR K=M2 STEP -1 UNTIL M1 DO --
  7703. C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
  7704.       K = M2
  7705.   250    XU = LB
  7706. C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
  7707.          DO 260 II = M1, K
  7708.             I = M1 + K - II
  7709.             IF (XU .GE. RV4(I)) GO TO 260
  7710.             XU = RV4(I)
  7711.             GO TO 280
  7712.   260    CONTINUE
  7713. C
  7714.   280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
  7715. C     .......... NEXT BISECTION STEP ..........
  7716.   300    X1 = (XU + X0) * 0.5E0
  7717.          S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1))
  7718.          S2 = S1 + ABS(X0 - XU)
  7719.          IF (S2 .EQ. S1) GO TO 420
  7720. C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  7721.   320    S = P - 1
  7722.          U = 1.0E0
  7723. C
  7724.          DO 340 I = P, Q
  7725.             IF (U .NE. 0.0E0) GO TO 325
  7726.             V = ABS(E(I)) / MACHEP
  7727.             IF (E2(I) .EQ. 0.0E0) V = 0.0E0
  7728.             GO TO 330
  7729.   325       V = E2(I) / U
  7730.   330       U = D(I) - X1 - V
  7731.             IF (U .LT. 0.0E0) S = S + 1
  7732.   340    CONTINUE
  7733. C
  7734.          GO TO (60,80,200,220,360), ISTURM
  7735. C     .......... REFINE INTERVALS ..........
  7736.   360    IF (S .GE. K) GO TO 400
  7737.          XU = X1
  7738.          IF (S .GE. M1) GO TO 380
  7739.          RV4(M1) = X1
  7740.          GO TO 300
  7741.   380    RV4(S+1) = X1
  7742.          IF (RV5(S) .GT. X1) RV5(S) = X1
  7743.          GO TO 300
  7744.   400    X0 = X1
  7745.          GO TO 300
  7746. C     .......... K-TH EIGENVALUE FOUND ..........
  7747.   420    RV5(K) = X1
  7748.       K = K - 1
  7749.       IF (K .GE. M1) GO TO 250
  7750. C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
  7751. C                SUBMATRIX ASSOCIATIONS ..........
  7752.   900 S = R
  7753.       R = R + M2 - M1 + 1
  7754.       J = 1
  7755.       K = M1
  7756. C
  7757.       DO 920 L = 1, R
  7758.          IF (J .GT. S) GO TO 910
  7759.          IF (K .GT. M2) GO TO 940
  7760.          IF (RV5(K) .GE. W(L)) GO TO 915
  7761. C
  7762.          DO 905 II = J, S
  7763.             I = L + S - II
  7764.             W(I+1) = W(I)
  7765.             IND(I+1) = IND(I)
  7766.   905    CONTINUE
  7767. C
  7768.   910    W(L) = RV5(K)
  7769.          IND(L) = TAG
  7770.          K = K + 1
  7771.          GO TO 920
  7772.   915    J = J + 1
  7773.   920 CONTINUE
  7774. C
  7775.   940 IF (Q .LT. N) GO TO 100
  7776.       GO TO 1001
  7777. C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
  7778. C                EIGENVALUES IN INTERVAL ..........
  7779.   980 IERR = 3 * N + 1
  7780.  1001 LB = T1
  7781.       UB = T2
  7782.       RETURN
  7783.       END
  7784. *DECK BKIAS
  7785.       SUBROUTINE BKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR)
  7786. C***BEGIN PROLOGUE  BKIAS
  7787. C***SUBSIDIARY
  7788. C***PURPOSE  Subsidiary to BSKIN
  7789. C***LIBRARY   SLATEC
  7790. C***TYPE      SINGLE PRECISION (BKIAS-S, DBKIAS-D)
  7791. C***AUTHOR  Amos, D. E., (SNLA)
  7792. C***DESCRIPTION
  7793. C
  7794. C     BKIAS computes repeated integrals of the K0 Bessel function
  7795. C     by the asymptotic expansion
  7796. C
  7797. C***SEE ALSO  BSKIN
  7798. C***ROUTINES CALLED  BDIFF, GAMRN, HKSEQ, R1MACH
  7799. C***REVISION HISTORY  (YYMMDD)
  7800. C   820601  DATE WRITTEN
  7801. C   890531  Changed all specific intrinsics to generic.  (WRB)
  7802. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  7803. C   900328  Added TYPE section.  (WRB)
  7804. C   910722  Updated AUTHOR section.  (ALS)
  7805. C***END PROLOGUE  BKIAS
  7806.       INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N,
  7807.      * IERR
  7808.       REAL ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, FLN, FM1,
  7809.      * GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, SS, SUMI,
  7810.      * SUMJ, T, TOL, V, W, X, XP, Z
  7811.       REAL GAMRN, R1MACH
  7812.       DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50),
  7813.      * BND(15)
  7814.       SAVE B, BND, HRTPI
  7815. C-----------------------------------------------------------------------
  7816. C             COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15
  7817. C-----------------------------------------------------------------------
  7818.       DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
  7819.      * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
  7820.      * B(20), B(21), B(22), B(23), B(24) /1.00000000000000000E+00,
  7821.      * 1.00000000000000000E+00,-2.00000000000000000E+00,
  7822.      * 1.00000000000000000E+00,-8.00000000000000000E+00,
  7823.      * 6.00000000000000000E+00,1.00000000000000000E+00,
  7824.      * -2.20000000000000000E+01,5.80000000000000000E+01,
  7825.      * -2.40000000000000000E+01,1.00000000000000000E+00,
  7826.      * -5.20000000000000000E+01,3.28000000000000000E+02,
  7827.      * -4.44000000000000000E+02,1.20000000000000000E+02,
  7828.      * 1.00000000000000000E+00,-1.14000000000000000E+02,
  7829.      * 1.45200000000000000E+03,-4.40000000000000000E+03,
  7830.      * 3.70800000000000000E+03,-7.20000000000000000E+02,
  7831.      * 1.00000000000000000E+00,-2.40000000000000000E+02,
  7832.      * 5.61000000000000000E+03/
  7833.       DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32),
  7834.      * B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41),
  7835.      * B(42), B(43), B(44), B(45), B(46), B(47), B(48)
  7836.      * /-3.21200000000000000E+04,5.81400000000000000E+04,
  7837.      * -3.39840000000000000E+04,5.04000000000000000E+03,
  7838.      * 1.00000000000000000E+00,-4.94000000000000000E+02,
  7839.      * 1.99500000000000000E+04,-1.95800000000000000E+05,
  7840.      * 6.44020000000000000E+05,-7.85304000000000000E+05,
  7841.      * 3.41136000000000000E+05,-4.03200000000000000E+04,
  7842.      * 1.00000000000000000E+00,-1.00400000000000000E+03,
  7843.      * 6.72600000000000000E+04,-1.06250000000000000E+06,
  7844.      * 5.76550000000000000E+06,-1.24400640000000000E+07,
  7845.      * 1.10262960000000000E+07,-3.73392000000000000E+06,
  7846.      * 3.62880000000000000E+05,1.00000000000000000E+00,
  7847.      * -2.02600000000000000E+03,2.18848000000000000E+05/
  7848.       DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56),
  7849.      * B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65),
  7850.      * B(66), B(67), B(68), B(69), B(70), B(71), B(72)
  7851.      * /-5.32616000000000000E+06,4.47650000000000000E+07,
  7852.      * -1.55357384000000000E+08,2.38904904000000000E+08,
  7853.      * -1.62186912000000000E+08,4.43390400000000000E+07,
  7854.      * -3.62880000000000000E+06,1.00000000000000000E+00,
  7855.      * -4.07200000000000000E+03,6.95038000000000000E+05,
  7856.      * -2.52439040000000000E+07,3.14369720000000000E+08,
  7857.      * -1.64838430400000000E+09,4.00269508800000000E+09,
  7858.      * -4.64216395200000000E+09,2.50748121600000000E+09,
  7859.      * -5.68356480000000000E+08,3.99168000000000000E+07,
  7860.      * 1.00000000000000000E+00,-8.16600000000000000E+03,
  7861.      * 2.17062600000000000E+06,-1.14876376000000000E+08,
  7862.      * 2.05148277600000000E+09,-1.55489607840000000E+10/
  7863.       DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80),
  7864.      * B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89),
  7865.      * B(90), B(91), B(92), B(93), B(94), B(95), B(96)
  7866.      * /5.60413987840000000E+10,-1.01180433024000000E+11,
  7867.      * 9.21997902240000000E+10,-4.07883018240000000E+10,
  7868.      * 7.82771904000000000E+09,-4.79001600000000000E+08,
  7869.      * 1.00000000000000000E+00,-1.63560000000000000E+04,
  7870.      * 6.69969600000000000E+06,-5.07259276000000000E+08,
  7871.      * 1.26698177760000000E+10,-1.34323420224000000E+11,
  7872.      * 6.87720046384000000E+11,-1.81818864230400000E+12,
  7873.      * 2.54986547342400000E+12,-1.88307966182400000E+12,
  7874.      * 6.97929436800000000E+11,-1.15336085760000000E+11,
  7875.      * 6.22702080000000000E+09,1.00000000000000000E+00,
  7876.      * -3.27380000000000000E+04,2.05079880000000000E+07,
  7877.      * -2.18982980800000000E+09,7.50160522280000000E+10/
  7878.       DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104),
  7879.      * B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112),
  7880.      * B(113), B(114), B(115), B(116), B(117), B(118)
  7881.      * /-1.08467651241600000E+12,7.63483214939200000E+12,
  7882.      * -2.82999100661120000E+13,5.74943734645920000E+13,
  7883.      * -6.47283751398720000E+13,3.96895780558080000E+13,
  7884.      * -1.25509040179200000E+13,1.81099255680000000E+12,
  7885.      * -8.71782912000000000E+10,1.00000000000000000E+00,
  7886.      * -6.55040000000000000E+04,6.24078900000000000E+07,
  7887.      * -9.29252692000000000E+09,4.29826006340000000E+11,
  7888.      * -8.30844432796800000E+12,7.83913848313120000E+13,
  7889.      * -3.94365587815520000E+14,1.11174747256968000E+15,
  7890.      * -1.79717122069056000E+15,1.66642448627145600E+15,
  7891.      * -8.65023253219584000E+14,2.36908271543040000E+14/
  7892.       DATA B(119), B(120) /-3.01963769856000000E+13,
  7893.      * 1.30767436800000000E+12/
  7894. C-----------------------------------------------------------------------
  7895. C             BOUNDS B(M,K) , K=M-3
  7896. C-----------------------------------------------------------------------
  7897.       DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7),
  7898.      * BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14),
  7899.      * BND(15) /1.0E0,1.0E0,1.0E0,1.0E0,3.10E0,5.18E0,11.7E0,29.8E0,
  7900.      * 90.4E0,297.0E0,1070.0E0,4290.0E0,18100.0E0,84700.0E0,408000.0E0/
  7901.       DATA HRTPI /8.86226925452758014E-01/
  7902. C
  7903. C***FIRST EXECUTABLE STATEMENT  BKIAS
  7904.       IERR=0
  7905.       TOL = MAX(R1MACH(4),1.0E-18)
  7906.       FLN = N
  7907.       RZ = 1.0E0/(X+FLN)
  7908.       RZX = X*RZ
  7909.       Z = 0.5E0*(X+FLN)
  7910.       IF (IND.GT.1) GO TO 10
  7911.       GMRN = GAMRN(Z)
  7912.    10 CONTINUE
  7913.       GS = HRTPI*GMRN
  7914.       G1 = GS + GS
  7915.       RG1 = 1.0E0/G1
  7916.       GMRN = (RZ+RZ)/GMRN
  7917.       IF (IND.GT.1) GO TO 70
  7918. C-----------------------------------------------------------------------
  7919. C     EVALUATE ERROR FOR M=MS
  7920. C-----------------------------------------------------------------------
  7921.       HN = 0.5E0*FLN
  7922.       DEN2 = KTRMS + KTRMS + N
  7923.       DEN3 = DEN2 - 2.0E0
  7924.       DEN1 = X + DEN2
  7925.       ERR = RG1*(X+X)/(DEN1-1.0E0)
  7926.       IF (N.EQ.0) GO TO 20
  7927.       RAT = 1.0E0/(FLN*FLN)
  7928.    20 CONTINUE
  7929.       IF (KTRMS.EQ.0) GO TO 30
  7930.       FJ = KTRMS
  7931.       RAT = 0.25E0/(HRTPI*DEN3*SQRT(FJ))
  7932.    30 CONTINUE
  7933.       ERR = ERR*RAT
  7934.       FJ = -3.0E0
  7935.       DO 50 J=1,15
  7936.         IF (J.LE.5) ERR = ERR/DEN1
  7937.         FM1 = MAX(1.0E0,FJ)
  7938.         FJ = FJ + 1.0E0
  7939.         ER = BND(J)*ERR
  7940.         IF (KTRMS.EQ.0) GO TO 40
  7941.         ER = ER/FM1
  7942.         IF (ER.LT.TOL) GO TO 60
  7943.         IF (J.GE.5) ERR = ERR/DEN3
  7944.         GO TO 50
  7945.    40   CONTINUE
  7946.         ER = ER*(1.0E0+HN/FM1)
  7947.         IF (ER.LT.TOL) GO TO 60
  7948.         IF (J.GE.5) ERR = ERR/FLN
  7949.    50 CONTINUE
  7950.       GO TO 200
  7951.    60 CONTINUE
  7952.       MS = J
  7953.    70 CONTINUE
  7954.       MM = MS + MS
  7955.       MP = MM + 1
  7956. C-----------------------------------------------------------------------
  7957. C     H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM
  7958. C-----------------------------------------------------------------------
  7959.       IF (IND.GT.1) GO TO 80
  7960.       CALL HKSEQ(Z, MM, H, IERR)
  7961.       GO TO 100
  7962.    80 CONTINUE
  7963.       RAT = Z/(Z-0.5E0)
  7964.       RXP = RAT
  7965.       DO 90 I=1,MM
  7966.         H(I) = RXP*(1.0E0-H(I))
  7967.         RXP = RXP*RAT
  7968.    90 CONTINUE
  7969.   100 CONTINUE
  7970. C-----------------------------------------------------------------------
  7971. C     SCALED S SEQUENCE
  7972. C-----------------------------------------------------------------------
  7973.       S(1) = 1.0E0
  7974.       FK = 1.0E0
  7975.       DO 120 K=2,MP
  7976.         SS = 0.0E0
  7977.         KM = K - 1
  7978.         I = KM
  7979.         DO 110 J=1,KM
  7980.           SS = SS + S(J)*H(I)
  7981.           I = I - 1
  7982.   110   CONTINUE
  7983.         S(K) = SS/FK
  7984.         FK = FK + 1.0E0
  7985.   120 CONTINUE
  7986. C-----------------------------------------------------------------------
  7987. C     SCALED S-TILDA SEQUENCE
  7988. C-----------------------------------------------------------------------
  7989.       IF (KTRMS.EQ.0) GO TO 160
  7990.       FK = 0.0E0
  7991.       SS = 0.0E0
  7992.       RG1 = RG1/Z
  7993.       DO 130 K=1,KTRMS
  7994.         V(K) = Z/(Z+FK)
  7995.         W(K) = T(K)*V(K)
  7996.         SS = SS + W(K)
  7997.         FK = FK + 1.0E0
  7998.   130 CONTINUE
  7999.       S(1) = S(1) - SS*RG1
  8000.       DO 150 I=2,MP
  8001.         SS = 0.0E0
  8002.         DO 140 K=1,KTRMS
  8003.           W(K) = W(K)*V(K)
  8004.           SS = SS + W(K)
  8005.   140   CONTINUE
  8006.         S(I) = S(I) - SS*RG1
  8007.   150 CONTINUE
  8008.   160 CONTINUE
  8009. C-----------------------------------------------------------------------
  8010. C     SUM ON J
  8011. C-----------------------------------------------------------------------
  8012.       SUMJ = 0.0E0
  8013.       JN = 1
  8014.       RXP = 1.0E0
  8015.       XP(1) = 1.0E0
  8016.       DO 190 J=1,MS
  8017.         JN = JN + J - 1
  8018.         XP(J+1) = XP(J)*RZX
  8019.         RXP = RXP*RZ
  8020. C-----------------------------------------------------------------------
  8021. C     SUM ON I
  8022. C-----------------------------------------------------------------------
  8023.         SUMI = 0.0E0
  8024.         II = JN
  8025.         DO 180 I=1,J
  8026.           JMI = J - I + 1
  8027.           KK = J + I + 1
  8028.           DO 170 K=1,JMI
  8029.             V(K) = S(KK)*XP(K)
  8030.             KK = KK + 1
  8031.   170     CONTINUE
  8032.           CALL BDIFF(JMI, V)
  8033.           SUMI = SUMI + B(II)*V(JMI)*XP(I+1)
  8034.           II = II + 1
  8035.   180   CONTINUE
  8036.         SUMJ = SUMJ + SUMI*RXP
  8037.   190 CONTINUE
  8038.       ANS = GS*(S(1)-SUMJ)
  8039.       RETURN
  8040.   200 CONTINUE
  8041.       IERR=2
  8042.       RETURN
  8043.       END
  8044. *DECK BKISR
  8045.       SUBROUTINE BKISR (X, N, SUM, IERR)
  8046. C***BEGIN PROLOGUE  BKISR
  8047. C***SUBSIDIARY
  8048. C***PURPOSE  Subsidiary to BSKIN
  8049. C***LIBRARY   SLATEC
  8050. C***TYPE      SINGLE PRECISION (BKISR-S, DBKISR-D)
  8051. C***AUTHOR  Amos, D. E., (SNLA)
  8052. C***DESCRIPTION
  8053. C
  8054. C     BKISR computes repeated integrals of the K0 Bessel function
  8055. C     by the series for N=0,1, and 2.
  8056. C
  8057. C***SEE ALSO  BSKIN
  8058. C***ROUTINES CALLED  PSIXN, R1MACH
  8059. C***REVISION HISTORY  (YYMMDD)
  8060. C   820601  DATE WRITTEN
  8061. C   890531  Changed all specific intrinsics to generic.  (WRB)
  8062. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  8063. C   900328  Added TYPE section.  (WRB)
  8064. C   910722  Updated AUTHOR section.  (ALS)
  8065. C***END PROLOGUE  BKISR
  8066.       INTEGER I, IERR, K, KK, KKN, K1, N, NP
  8067.       REAL AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, TKP, TOL,
  8068.      * TRM, X, XLN
  8069.       REAL PSIXN, R1MACH
  8070.       DIMENSION C(2)
  8071.       SAVE C
  8072. C
  8073.       DATA C(1), C(2) /1.57079632679489662E+00,1.0E0/
  8074. C***FIRST EXECUTABLE STATEMENT  BKISR
  8075.       IERR=0
  8076.       TOL = MAX(R1MACH(4),1.0E-18)
  8077.       IF (X.LT.TOL) GO TO 50
  8078.       PR = 1.0E0
  8079.       POL = 0.0E0
  8080.       IF (N.EQ.0) GO TO 20
  8081.       DO 10 I=1,N
  8082.         POL = -POL*X + C(I)
  8083.         PR = PR*X/I
  8084.    10 CONTINUE
  8085.    20 CONTINUE
  8086.       HX = X*0.5E0
  8087.       HXS = HX*HX
  8088.       XLN = LOG(HX)
  8089.       NP = N + 1
  8090.       TKP = 3.0E0
  8091.       FK = 2.0E0
  8092.       FN = N
  8093.       BK = 4.0E0
  8094.       AK = 2.0E0/((FN+1.0E0)*(FN+2.0E0))
  8095.       SUM = AK*(PSIXN(N+3)-PSIXN(3)+PSIXN(2)-XLN)
  8096.       ATOL = SUM*TOL*0.75E0
  8097.       DO 30 K=2,20
  8098.         AK = AK*(HXS/BK)*((TKP+1.0E0)/(TKP+FN+1.0E0))*(TKP/(TKP+FN))
  8099.         K1 = K + 1
  8100.         KK = K1 + K
  8101.         KKN = KK + N
  8102.         TRM = (PSIXN(K1)+PSIXN(KKN)-PSIXN(KK)-XLN)*AK
  8103.         SUM = SUM + TRM
  8104.         IF (ABS(TRM).LE.ATOL) GO TO 40
  8105.         TKP = TKP + 2.0E0
  8106.         BK = BK + TKP
  8107.         FK = FK + 1.0E0
  8108.    30 CONTINUE
  8109.       GO TO 80
  8110.    40 CONTINUE
  8111.       SUM = (SUM*HXS+PSIXN(NP)-XLN)*PR
  8112.       IF (N.EQ.1) SUM = -SUM
  8113.       SUM = POL + SUM
  8114.       RETURN
  8115. C-----------------------------------------------------------------------
  8116. C     SMALL X CASE, X.LT.WORD TOLERANCE
  8117. C-----------------------------------------------------------------------
  8118.    50 CONTINUE
  8119.       IF (N.GT.0) GO TO 60
  8120.       HX = X*0.5E0
  8121.       SUM = PSIXN(1) - LOG(HX)
  8122.       RETURN
  8123.    60 CONTINUE
  8124.       SUM = C(N)
  8125.       RETURN
  8126.    80 CONTINUE
  8127.       IERR=2
  8128.       RETURN
  8129.       END
  8130. *DECK BKSOL
  8131.       SUBROUTINE BKSOL (N, A, X)
  8132. C***BEGIN PROLOGUE  BKSOL
  8133. C***SUBSIDIARY
  8134. C***PURPOSE  Subsidiary to BVSUP
  8135. C***LIBRARY   SLATEC
  8136. C***TYPE      SINGLE PRECISION (BKSOL-S, DBKSOL-D)
  8137. C***AUTHOR  Watts, H. A., (SNLA)
  8138. C***DESCRIPTION
  8139. C
  8140. C **********************************************************************
  8141. C     Solution of an upper triangular linear system by
  8142. C     back-substitution
  8143. C
  8144. C     The matrix A is assumed to be stored in a linear
  8145. C     array proceeding in a row-wise manner. The
  8146. C     vector X contains the given constant vector on input
  8147. C     and contains the solution on return.
  8148. C     The actual diagonal of A is unity while a diagonal
  8149. C     scaling matrix is stored there.
  8150. C **********************************************************************
  8151. C
  8152. C***SEE ALSO  BVSUP
  8153. C***ROUTINES CALLED  SDOT
  8154. C***REVISION HISTORY  (YYMMDD)
  8155. C   750601  DATE WRITTEN
  8156. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  8157. C   900328  Added TYPE section.  (WRB)
  8158. C   910722  Updated AUTHOR section.  (ALS)
  8159. C***END PROLOGUE  BKSOL
  8160. C
  8161.       DIMENSION A(*),X(*)
  8162. C
  8163. C***FIRST EXECUTABLE STATEMENT  BKSOL
  8164.       M=(N*(N+1))/2
  8165.       X(N)=X(N)*A(M)
  8166.       IF (N .EQ. 1) GO TO 20
  8167.       NM1=N-1
  8168.       DO 10 K=1,NM1
  8169.       J=N-K
  8170.       M=M-K-1
  8171.    10 X(J)=X(J)*A(M) - SDOT(K,A(M+1),1,X(J+1),1)
  8172. C
  8173.    20 RETURN
  8174.       END
  8175. *DECK BLKTR1
  8176.       SUBROUTINE BLKTR1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1,
  8177.      +   W2, W3, WD, WW, WU, PRDCT, CPRDCT)
  8178. C***BEGIN PROLOGUE  BLKTR1
  8179. C***SUBSIDIARY
  8180. C***PURPOSE  Subsidiary to BLKTRI
  8181. C***LIBRARY   SLATEC
  8182. C***TYPE      SINGLE PRECISION (BLKTR1-S, CBLKT1-C)
  8183. C***AUTHOR  (UNKNOWN)
  8184. C***DESCRIPTION
  8185. C
  8186. C BLKTR1 solves the linear system set up by BLKTRI.
  8187. C
  8188. C B  contains the roots of all the B polynomials.
  8189. C W1,W2,W3,WD,WW,WU  are all working arrays.
  8190. C PRDCT  is either PRODP or PROD depending on whether the boundary
  8191. C conditions in the M direction are periodic or not.
  8192. C CPRDCT is either CPRODP or CPROD which are the complex versions
  8193. C of PRODP and PROD. These are called in the event that some
  8194. C of the roots of the B sub P polynomial are complex.
  8195. C
  8196. C***SEE ALSO  BLKTRI
  8197. C***ROUTINES CALLED  INDXA, INDXB, INDXC
  8198. C***COMMON BLOCKS    CBLKT
  8199. C***REVISION HISTORY  (YYMMDD)
  8200. C   801001  DATE WRITTEN
  8201. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  8202. C   900402  Added TYPE section.  (WRB)
  8203. C***END PROLOGUE  BLKTR1
  8204. C
  8205.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
  8206.      1                BM(*)      ,CM(*)      ,B(*)       ,W1(*)      ,
  8207.      2                W2(*)      ,W3(*)      ,WD(*)      ,WW(*)      ,
  8208.      3                WU(*)      ,Y(IDIMY,*)
  8209.       COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
  8210.      1                NM         ,NCMPLX     ,IK
  8211. C***FIRST EXECUTABLE STATEMENT  BLKTR1
  8212.       KDO = K-1
  8213.       DO 109 L=1,KDO
  8214.          IR = L-1
  8215.          I2 = 2**IR
  8216.          I1 = I2/2
  8217.          I3 = I2+I1
  8218.          I4 = I2+I2
  8219.          IRM1 = IR-1
  8220.          CALL INDXB (I2,IR,IM2,NM2)
  8221.          CALL INDXB (I1,IRM1,IM3,NM3)
  8222.          CALL INDXB (I3,IRM1,IM1,NM1)
  8223.          CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3,
  8224.      1               M,AM,BM,CM,WD,WW,WU)
  8225.          IF = 2**K
  8226.          DO 108 I=I4,IF,I4
  8227.             IF (I-NM) 101,101,108
  8228.   101       IPI1 = I+I1
  8229.             IPI2 = I+I2
  8230.             IPI3 = I+I3
  8231.             CALL INDXC (I,IR,IDXC,NC)
  8232.             IF (I-IF) 102,108,108
  8233.   102       CALL INDXA (I,IR,IDXA,NA)
  8234.             CALL INDXB (I-I1,IRM1,IM1,NM1)
  8235.             CALL INDXB (IPI2,IR,IP2,NP2)
  8236.             CALL INDXB (IPI1,IRM1,IP1,NP1)
  8237.             CALL INDXB (IPI3,IRM1,IP3,NP3)
  8238.             CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM,
  8239.      1                  BM,CM,WD,WW,WU)
  8240.             IF (IPI2-NM) 105,105,103
  8241.   103       DO 104 J=1,M
  8242.                W3(J) = 0.
  8243.                W2(J) = 0.
  8244.   104       CONTINUE
  8245.             GO TO 106
  8246.   105       CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,
  8247.      1                  Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU)
  8248.             CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM,
  8249.      1                  BM,CM,WD,WW,WU)
  8250.   106       DO 107 J=1,M
  8251.                Y(J,I) = W1(J)+W2(J)+Y(J,I)
  8252.   107       CONTINUE
  8253.   108    CONTINUE
  8254.   109 CONTINUE
  8255.       IF (NPP) 132,110,132
  8256. C
  8257. C     THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD
  8258. C
  8259.   110 IF = 2**K
  8260.       I = IF/2
  8261.       I1 = I/2
  8262.       CALL INDXB (I-I1,K-2,IM1,NM1)
  8263.       CALL INDXB (I+I1,K-2,IP1,NP1)
  8264.       CALL INDXB (I,K-1,IZ,NZ)
  8265.       CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM,
  8266.      1            BM,CM,WD,WW,WU)
  8267.       IZR = I
  8268.       DO 111 J=1,M
  8269.          W2(J) = W1(J)
  8270.   111 CONTINUE
  8271.       DO 113 LL=2,K
  8272.          L = K-LL+1
  8273.          IR = L-1
  8274.          I2 = 2**IR
  8275.          I1 = I2/2
  8276.          I = I2
  8277.          CALL INDXC (I,IR,IDXC,NC)
  8278.          CALL INDXB (I,IR,IZ,NZ)
  8279.          CALL INDXB (I-I1,IR-1,IM1,NM1)
  8280.          CALL INDXB (I+I1,IR-1,IP1,NP1)
  8281.          CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM,
  8282.      1               CM,WD,WW,WU)
  8283.          DO 112 J=1,M
  8284.             W1(J) = Y(J,I)+W1(J)
  8285.   112    CONTINUE
  8286.          CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM,
  8287.      1               BM,CM,WD,WW,WU)
  8288.   113 CONTINUE
  8289.       DO 118 LL=2,K
  8290.          L = K-LL+1
  8291.          IR = L-1
  8292.          I2 = 2**IR
  8293.          I1 = I2/2
  8294.          I4 = I2+I2
  8295.          IFD = IF-I2
  8296.          DO 117 I=I2,IFD,I4
  8297.             IF (I-I2-IZR) 117,114,117
  8298.   114       IF (I-NM) 115,115,118
  8299.   115       CALL INDXA (I,IR,IDXA,NA)
  8300.             CALL INDXB (I,IR,IZ,NZ)
  8301.             CALL INDXB (I-I1,IR-1,IM1,NM1)
  8302.             CALL INDXB (I+I1,IR-1,IP1,NP1)
  8303.             CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM,
  8304.      1                  BM,CM,WD,WW,WU)
  8305.             DO 116 J=1,M
  8306.                W2(J) = Y(J,I)+W2(J)
  8307.   116       CONTINUE
  8308.             CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M,
  8309.      1                  AM,BM,CM,WD,WW,WU)
  8310.             IZR = I
  8311.             IF (I-NM) 117,119,117
  8312.   117    CONTINUE
  8313.   118 CONTINUE
  8314.   119 DO 120 J=1,M
  8315.          Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J)
  8316.   120 CONTINUE
  8317.       CALL INDXB (IF/2,K-1,IM1,NM1)
  8318.       CALL INDXB (IF,K-1,IP,NP)
  8319.       IF (NCMPLX) 121,122,121
  8320.   121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
  8321.      1             Y(1,NM+1),M,AM,BM,CM,W1,W3,WW)
  8322.       GO TO 123
  8323.   122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
  8324.      1            Y(1,NM+1),M,AM,BM,CM,WD,WW,WU)
  8325.   123 DO 124 J=1,M
  8326.          W1(J) = AN(1)*Y(J,NM+1)
  8327.          W2(J) = CN(NM)*Y(J,NM+1)
  8328.          Y(J,1) = Y(J,1)-W1(J)
  8329.          Y(J,NM) = Y(J,NM)-W2(J)
  8330.   124 CONTINUE
  8331.       DO 126 L=1,KDO
  8332.          IR = L-1
  8333.          I2 = 2**IR
  8334.          I4 = I2+I2
  8335.          I1 = I2/2
  8336.          I = I4
  8337.          CALL INDXA (I,IR,IDXA,NA)
  8338.          CALL INDXB (I-I2,IR,IM2,NM2)
  8339.          CALL INDXB (I-I2-I1,IR-1,IM3,NM3)
  8340.          CALL INDXB (I-I1,IR-1,IM1,NM1)
  8341.          CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM,
  8342.      1               BM,CM,WD,WW,WU)
  8343.          CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM,
  8344.      1               CM,WD,WW,WU)
  8345.          DO 125 J=1,M
  8346.             Y(J,I) = Y(J,I)-W1(J)
  8347.   125    CONTINUE
  8348.   126 CONTINUE
  8349. C
  8350.       IZR = NM
  8351.       DO 131 L=1,KDO
  8352.          IR = L-1
  8353.          I2 = 2**IR
  8354.          I1 = I2/2
  8355.          I3 = I2+I1
  8356.          I4 = I2+I2
  8357.          IRM1 = IR-1
  8358.          DO 130 I=I4,IF,I4
  8359.             IPI1 = I+I1
  8360.             IPI2 = I+I2
  8361.             IPI3 = I+I3
  8362.             IF (IPI2-IZR) 127,128,127
  8363.   127       IF (I-IZR) 130,131,130
  8364.   128       CALL INDXC (I,IR,IDXC,NC)
  8365.             CALL INDXB (IPI2,IR,IP2,NP2)
  8366.             CALL INDXB (IPI1,IRM1,IP1,NP1)
  8367.             CALL INDXB (IPI3,IRM1,IP3,NP3)
  8368.             CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M,
  8369.      1                  AM,BM,CM,WD,WW,WU)
  8370.             CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM,
  8371.      1                  BM,CM,WD,WW,WU)
  8372.             DO 129 J=1,M
  8373.                Y(J,I) = Y(J,I)-W2(J)
  8374.   129       CONTINUE
  8375.             IZR = I
  8376.             GO TO 131
  8377.   130    CONTINUE
  8378.   131 CONTINUE
  8379. C
  8380. C BEGIN BACK SUBSTITUTION PHASE
  8381. C
  8382.   132 DO 144 LL=1,K
  8383.          L = K-LL+1
  8384.          IR = L-1
  8385.          IRM1 = IR-1
  8386.          I2 = 2**IR
  8387.          I1 = I2/2
  8388.          I4 = I2+I2
  8389.          IFD = IF-I2
  8390.          DO 143 I=I2,IFD,I4
  8391.             IF (I-NM) 133,133,143
  8392.   133       IMI1 = I-I1
  8393.             IMI2 = I-I2
  8394.             IPI1 = I+I1
  8395.             IPI2 = I+I2
  8396.             CALL INDXA (I,IR,IDXA,NA)
  8397.             CALL INDXC (I,IR,IDXC,NC)
  8398.             CALL INDXB (I,IR,IZ,NZ)
  8399.             CALL INDXB (IMI1,IRM1,IM1,NM1)
  8400.             CALL INDXB (IPI1,IRM1,IP1,NP1)
  8401.             IF (I-I2) 134,134,136
  8402.   134       DO 135 J=1,M
  8403.                W1(J) = 0.
  8404.   135       CONTINUE
  8405.             GO TO 137
  8406.   136       CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2),
  8407.      1                  W1,M,AM,BM,CM,WD,WW,WU)
  8408.   137       IF (IPI2-NM) 140,140,138
  8409.   138       DO 139 J=1,M
  8410.                W2(J) = 0.
  8411.   139       CONTINUE
  8412.             GO TO 141
  8413.   140       CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2),
  8414.      1                  W2,M,AM,BM,CM,WD,WW,WU)
  8415.   141       DO 142 J=1,M
  8416.                W1(J) = Y(J,I)+W1(J)+W2(J)
  8417.   142       CONTINUE
  8418.             CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I),
  8419.      1                  M,AM,BM,CM,WD,WW,WU)
  8420.   143    CONTINUE
  8421.   144 CONTINUE
  8422.       RETURN
  8423.       END
  8424. *DECK BLKTRI
  8425.       SUBROUTINE BLKTRI (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
  8426.      +   IDIMY, Y, IERROR, W)
  8427. C***BEGIN PROLOGUE  BLKTRI
  8428. C***PURPOSE  Solve a block tridiagonal system of linear equations
  8429. C            (usually resulting from the discretization of separable
  8430. C            two-dimensional elliptic equations).
  8431. C***LIBRARY   SLATEC (FISHPACK)
  8432. C***CATEGORY  I2B4B
  8433. C***TYPE      SINGLE PRECISION (BLKTRI-S, CBLKTR-C)
  8434. C***KEYWORDS  ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM
  8435. C***AUTHOR  Adams, J., (NCAR)
  8436. C           Swarztrauber, P. N., (NCAR)
  8437. C           Sweet, R., (NCAR)
  8438. C***DESCRIPTION
  8439. C
  8440. C     Subroutine BLKTRI Solves a System of Linear Equations of the Form
  8441. C
  8442. C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
  8443. C
  8444. C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
  8445. C
  8446. C               for I = 1,2,...,M  and  J = 1,2,...,N.
  8447. C
  8448. C     I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e.,
  8449. C
  8450. C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
  8451. C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
  8452. C
  8453. C     These equations usually result from the discretization of
  8454. C     separable elliptic equations.  Boundary conditions may be
  8455. C     Dirichlet, Neumann, or Periodic.
  8456. C
  8457. C
  8458. C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
  8459. C
  8460. C     IFLG
  8461. C       = 0  Initialization only.  Certain quantities that depend on NP,
  8462. C            N, AN, BN, and CN are computed and stored in the work
  8463. C            array  W.
  8464. C       = 1  The quantities that were computed in the initialization are
  8465. C            used to obtain the solution X(I,J).
  8466. C
  8467. C       NOTE   A call with IFLG=0 takes approximately one half the time
  8468. C              as a call with IFLG = 1  .  However, the
  8469. C              initialization does not have to be repeated unless NP, N,
  8470. C              AN, BN, or CN change.
  8471. C
  8472. C     NP
  8473. C       = 0  If AN(1) and CN(N) are not zero, which corresponds to
  8474. C            periodic boundary conditions.
  8475. C       = 1  If AN(1) and CN(N) are zero.
  8476. C
  8477. C     N
  8478. C       The number of unknowns in the J-direction. N must be greater
  8479. C       than 4. The operation count is proportional to MNlog2(N), hence
  8480. C       N should be selected less than or equal to M.
  8481. C
  8482. C     AN,BN,CN
  8483. C       One-dimensional arrays of length N that specify the coefficients
  8484. C       in the linear equations given above.
  8485. C
  8486. C     MP
  8487. C       = 0  If AM(1) and CM(M) are not zero, which corresponds to
  8488. C            periodic boundary conditions.
  8489. C       = 1  If AM(1) = CM(M) = 0  .
  8490. C
  8491. C     M
  8492. C       The number of unknowns in the I-direction. M must be greater
  8493. C       than 4.
  8494. C
  8495. C     AM,BM,CM
  8496. C       One-dimensional arrays of length M that specify the coefficients
  8497. C       in the linear equations given above.
  8498. C
  8499. C     IDIMY
  8500. C       The row (or first) dimension of the two-dimensional array Y as
  8501. C       it appears in the program calling BLKTRI.  This parameter is
  8502. C       used to specify the variable dimension of Y.  IDIMY must be at
  8503. C       least M.
  8504. C
  8505. C     Y
  8506. C       A two-dimensional array that specifies the values of the right
  8507. C       side of the linear system of equations given above.  Y must be
  8508. C       dimensioned at least M*N.
  8509. C
  8510. C     W
  8511. C       A one-dimensional array that must be provided by the user for
  8512. C       work space.
  8513. C             If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then
  8514. C                     W must have dimension (K-2)*L+K+5+MAX(2N,6M)
  8515. C
  8516. C             If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then
  8517. C                     W must have dimension (K-2)*L+K+5+2N+MAX(2N,6M)
  8518. C
  8519. C       **IMPORTANT** For purposes of checking, the required dimension
  8520. C                     of W is computed by BLKTRI and stored in W(1)
  8521. C                     in floating point format.
  8522. C
  8523. C     * * * * * * * * * *     On Output     * * * * * * * * * *
  8524. C
  8525. C     Y
  8526. C       Contains the solution X.
  8527. C
  8528. C     IERROR
  8529. C       An error flag that indicates invalid input parameters.  Except
  8530. C       for number zero, a solution is not attempted.
  8531. C
  8532. C       = 0  No error.
  8533. C       = 1  M is less than 5.
  8534. C       = 2  N is less than 5.
  8535. C       = 3  IDIMY is less than M.
  8536. C       = 4  BLKTRI failed while computing results that depend on the
  8537. C            coefficient arrays AN, BN, CN.  Check these arrays.
  8538. C       = 5  AN(J)*CN(J-1) is less than 0 for some J. Possible reasons
  8539. C            for this condition are
  8540. C            1. The arrays AN and CN are not correct.
  8541. C            2. Too large a grid spacing was used in the discretization
  8542. C               of the elliptic equation.
  8543. C            3. The linear equations resulted from a partial
  8544. C               differential equation which was not elliptic.
  8545. C
  8546. C     W
  8547. C       Contains intermediate values that must not be destroyed if
  8548. C       BLKTRI will be called again with IFLG=1.  W(1) contains the
  8549. C       number of locations required by W in floating point format.
  8550. C
  8551. C *Long Description:
  8552. C
  8553. C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
  8554. C
  8555. C     Dimension of   AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N)
  8556. C     Arguments      W(See argument list)
  8557. C
  8558. C     Latest         June 1979
  8559. C     Revision
  8560. C
  8561. C     Required       BLKTRI,BLKTRI,PROD,PRODP,CPROD,CPRODP,COMPB,INDXA,
  8562. C     Subprograms    INDXB,INDXC,PPADD,PSGF,PPSGF,PPSPF,BSRH,TEVLS,
  8563. C                    R1MACH
  8564. C
  8565. C     Special        The Algorithm may fail if ABS(BM(I)+BN(J)) is less
  8566. C     Conditions     than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J))
  8567. C                    for some I and J. The Algorithm will also fail if
  8568. C                    AN(J)*CN(J-1) is less than zero for some J.
  8569. C                    See the description of the output parameter IERROR.
  8570. C
  8571. C     Common         CBLKT
  8572. C     Blocks
  8573. C
  8574. C     I/O            None
  8575. C
  8576. C     Precision      Single
  8577. C
  8578. C     Specialist     Paul Swarztrauber
  8579. C
  8580. C     Language       FORTRAN
  8581. C
  8582. C     History        Version 1 September 1973
  8583. C                    Version 2 April     1976
  8584. C                    Version 3 June      1979
  8585. C
  8586. C     Algorithm      Generalized Cyclic Reduction (See Reference below)
  8587. C
  8588. C     Space
  8589. C     Required       Control Data 7600
  8590. C
  8591. C     Portability    American National Standards Institute Fortran.
  8592. C                    The machine accuracy is set using function R1MACH.
  8593. C
  8594. C     Required       None
  8595. C     Resident
  8596. C     Routines
  8597. C
  8598. C     References     Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN
  8599. C                    Subprograms For The Solution Of Elliptic Equations'
  8600. C                    NCAR TN/IA-109, July, 1975, 138 PP.
  8601. C
  8602. C                    Swarztrauber P. ,'A Direct Method For The Discrete
  8603. C                    Solution Of Separable Elliptic Equations', S.I.A.M.
  8604. C                    J. Numer. Anal.,11(1974) PP. 1136-1150.
  8605. C
  8606. C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
  8607. C                 subprograms for the solution of elliptic equations,
  8608. C                 NCAR TN/IA-109, July 1975, 138 pp.
  8609. C               P. N. Swarztrauber, A direct method for the discrete
  8610. C                 solution of separable elliptic equations, SIAM Journal
  8611. C                 on Numerical Analysis 11, (1974), pp. 1136-1150.
  8612. C***ROUTINES CALLED  BLKTR1, COMPB, CPROD, CPRODP, PROD, PRODP
  8613. C***COMMON BLOCKS    CBLKT
  8614. C***REVISION HISTORY  (YYMMDD)
  8615. C   801001  DATE WRITTEN
  8616. C   890531  Changed all specific intrinsics to generic.  (WRB)
  8617. C   890531  REVISION DATE from Version 3.2
  8618. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  8619. C   920501  Reformatted the REFERENCES section.  (WRB)
  8620. C***END PROLOGUE  BLKTRI
  8621. C
  8622.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
  8623.      1                BM(*)      ,CM(*)      ,Y(IDIMY,*) ,W(*)
  8624.       EXTERNAL        PROD       ,PRODP      ,CPROD      ,CPRODP
  8625.       COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
  8626.      1                NM         ,NCMPLX     ,IK
  8627. C***FIRST EXECUTABLE STATEMENT  BLKTRI
  8628.       NM = N
  8629.       IERROR = 0
  8630.       IF (M-5) 101,102,102
  8631.   101 IERROR = 1
  8632.       GO TO 119
  8633.   102 IF (NM-3) 103,104,104
  8634.   103 IERROR = 2
  8635.       GO TO 119
  8636.   104 IF (IDIMY-M) 105,106,106
  8637.   105 IERROR = 3
  8638.       GO TO 119
  8639.   106 NH = N
  8640.       NPP = NP
  8641.       IF (NPP) 107,108,107
  8642.   107 NH = NH+1
  8643.   108 IK = 2
  8644.       K = 1
  8645.   109 IK = IK+IK
  8646.       K = K+1
  8647.       IF (NH-IK) 110,110,109
  8648.   110 NL = IK
  8649.       IK = IK+IK
  8650.       NL = NL-1
  8651.       IWAH = (K-2)*IK+K+6
  8652.       IF (NPP) 111,112,111
  8653. C
  8654. C     DIVIDE W INTO WORKING SUB ARRAYS
  8655. C
  8656.   111 IW1 = IWAH
  8657.       IWBH = IW1+NM
  8658.       W(1) = IW1-1+MAX(2*NM,6*M)
  8659.       GO TO 113
  8660.   112 IWBH = IWAH+NM+NM
  8661.       IW1 = IWBH
  8662.       W(1) = IW1-1+MAX(2*NM,6*M)
  8663.       NM = NM-1
  8664. C
  8665. C SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS
  8666. C
  8667.   113 IF (IERROR) 119,114,119
  8668.   114 IW2 = IW1+M
  8669.       IW3 = IW2+M
  8670.       IWD = IW3+M
  8671.       IWW = IWD+M
  8672.       IWU = IWW+M
  8673.       IF (IFLG) 116,115,116
  8674.   115 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
  8675.       GO TO 119
  8676.   116 IF (MP) 117,118,117
  8677. C
  8678. C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM
  8679. C
  8680.   117 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
  8681.      1             W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD)
  8682.       GO TO 119
  8683.   118 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
  8684.      1             W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP)
  8685.   119 CONTINUE
  8686.       RETURN
  8687.       END
  8688. *DECK BNDACC
  8689.       SUBROUTINE BNDACC (G, MDG, NB, IP, IR, MT, JT)
  8690. C***BEGIN PROLOGUE  BNDACC
  8691. C***PURPOSE  Compute the LU factorization of a banded matrices using
  8692. C            sequential accumulation of rows of the data matrix.
  8693. C            Exactly one right-hand side vector is permitted.
  8694. C***LIBRARY   SLATEC
  8695. C***CATEGORY  D9
  8696. C***TYPE      SINGLE PRECISION (BNDACC-S, DBNDAC-D)
  8697. C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
  8698. C***AUTHOR  Lawson, C. L., (JPL)
  8699. C           Hanson, R. J., (SNLA)
  8700. C***DESCRIPTION
  8701. C
  8702. C     These subroutines solve the least squares problem Ax = b for
  8703. C     banded matrices A using sequential accumulation of rows of the
  8704. C     data matrix.  Exactly one right-hand side vector is permitted.
  8705. C
  8706. C     These subroutines are intended for the type of least squares
  8707. C     systems that arise in applications such as curve or surface
  8708. C     fitting of data.  The least squares equations are accumulated and
  8709. C     processed using only part of the data.  This requires a certain
  8710. C     user interaction during the solution of Ax = b.
  8711. C
  8712. C     Specifically, suppose the data matrix (A B) is row partitioned
  8713. C     into Q submatrices.  Let (E F) be the T-th one of these
  8714. C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
  8715. C     and the dimension of C is MT by NB.  The value of NB is the
  8716. C     bandwidth of A.  The dimensions of the leading block of zeros in E
  8717. C     are MT by JT-1.
  8718. C
  8719. C     The user of the subroutine BNDACC provides MT,JT,C and F for
  8720. C     T=1,...,Q.  Not all of this data must be supplied at once.
  8721. C
  8722. C     Following the processing of the various blocks (E F), the matrix
  8723. C     (A B) has been transformed to the form (R D) where R is upper
  8724. C     triangular and banded with bandwidth NB.  The least squares
  8725. C     system Rx = d is then easily solved using back substitution by
  8726. C     executing the statement CALL BNDSOL(1,...). The sequence of
  8727. C     values for JT must be nondecreasing.  This may require some
  8728. C     preliminary interchanges of rows and columns of the matrix A.
  8729. C
  8730. C     The primary reason for these subroutines is that the total
  8731. C     processing can take place in a working array of dimension MU by
  8732. C     NB+1.  An acceptable value for MU is
  8733. C
  8734. C                       MU = MAX(MT + N + 1),
  8735. C
  8736. C     where N is the number of unknowns.
  8737. C
  8738. C     Here the maximum is taken over all values of MT for T=1,...,Q.
  8739. C     Notice that MT can be taken to be a small as one, showing that
  8740. C     MU can be as small as N+2.  The subprogram BNDACC processes the
  8741. C     rows more efficiently if MU is large enough so that each new
  8742. C     block (C F) has a distinct value of JT.
  8743. C
  8744. C     The four principle parts of these algorithms are obtained by the
  8745. C     following call statements
  8746. C
  8747. C     CALL BNDACC(...)  Introduce new blocks of data.
  8748. C
  8749. C     CALL BNDSOL(1,...)Compute solution vector and length of
  8750. C                       residual vector.
  8751. C
  8752. C     CALL BNDSOL(2,...)Given any row vector H solve YR = H for the
  8753. C                       row vector Y.
  8754. C
  8755. C     CALL BNDSOL(3,...)Given any column vector W solve RZ = W for
  8756. C                       the column vector Z.
  8757. C
  8758. C     The dots in the above call statements indicate additional
  8759. C     arguments that will be specified in the following paragraphs.
  8760. C
  8761. C     The user must dimension the array appearing in the call list..
  8762. C     G(MDG,NB+1)
  8763. C
  8764. C     Description of calling sequence for BNDACC..
  8765. C
  8766. C     The entire set of parameters for BNDACC are
  8767. C
  8768. C     Input..
  8769. C
  8770. C     G(*,*)            The working array into which the user will
  8771. C                       place the MT by NB+1 block (C F) in rows IR
  8772. C                       through IR+MT-1, columns 1 through NB+1.
  8773. C                       See descriptions of IR and MT below.
  8774. C
  8775. C     MDG               The number of rows in the working array
  8776. C                       G(*,*).  The value of MDG should be .GE. MU.
  8777. C                       The value of MU is defined in the abstract
  8778. C                       of these subprograms.
  8779. C
  8780. C     NB                The bandwidth of the data matrix A.
  8781. C
  8782. C     IP                Set by the user to the value 1 before the
  8783. C                       first call to BNDACC.  Its subsequent value
  8784. C                       is controlled by BNDACC to set up for the
  8785. C                       next call to BNDACC.
  8786. C
  8787. C     IR                Index of the row of G(*,*) where the user is
  8788. C                       to place the new block of data (C F).  Set by
  8789. C                       the user to the value 1 before the first call
  8790. C                       to BNDACC.  Its subsequent value is controlled
  8791. C                       by BNDACC. A value of IR .GT. MDG is considered
  8792. C                       an error.
  8793. C
  8794. C     MT,JT             Set by the user to indicate respectively the
  8795. C                       number of new rows of data in the block and
  8796. C                       the index of the first nonzero column in that
  8797. C                       set of rows (E F) = (0 C 0 F) being processed.
  8798. C
  8799. C     Output..
  8800. C
  8801. C     G(*,*)            The working array which will contain the
  8802. C                       processed rows of that part of the data
  8803. C                       matrix which has been passed to BNDACC.
  8804. C
  8805. C     IP,IR             The values of these arguments are advanced by
  8806. C                       BNDACC to be ready for storing and processing
  8807. C                       a new block of data in G(*,*).
  8808. C
  8809. C     Description of calling sequence for BNDSOL..
  8810. C
  8811. C     The user must dimension the arrays appearing in the call list..
  8812. C
  8813. C     G(MDG,NB+1), X(N)
  8814. C
  8815. C     The entire set of parameters for BNDSOL are
  8816. C
  8817. C     Input..
  8818. C
  8819. C     MODE              Set by the user to one of the values 1, 2, or
  8820. C                       3.  These values respectively indicate that
  8821. C                       the solution of AX = B, YR = H or RZ = W is
  8822. C                       required.
  8823. C
  8824. C     G(*,*),MDG,       These arguments all have the same meaning and
  8825. C      NB,IP,IR         contents as following the last call to BNDACC.
  8826. C
  8827. C     X(*)              With mode=2 or 3 this array contains,
  8828. C                       respectively, the right-side vectors H or W of
  8829. C                       the systems YR = H or RZ = W.
  8830. C
  8831. C     N                 The number of variables in the solution
  8832. C                       vector.  If any of the N diagonal terms are
  8833. C                       zero the subroutine BNDSOL prints an
  8834. C                       appropriate message.  This condition is
  8835. C                       considered an error.
  8836. C
  8837. C     Output..
  8838. C
  8839. C     X(*)              This array contains the solution vectors X,
  8840. C                       Y or Z of the systems AX = B, YR = H or
  8841. C                       RZ = W depending on the value of MODE=1,
  8842. C                       2 or 3.
  8843. C
  8844. C     RNORM             If MODE=1 RNORM is the Euclidean length of the
  8845. C                       residual vector AX-B.  When MODE=2 or 3 RNORM
  8846. C                       is set to zero.
  8847. C
  8848. C     Remarks..
  8849. C
  8850. C     To obtain the upper triangular matrix and transformed right-hand
  8851. C     side vector D so that the super diagonals of R form the columns
  8852. C     of G(*,*), execute the following Fortran statements.
  8853. C
  8854. C     NBP1=NB+1
  8855. C
  8856. C     DO 10 J=1, NBP1
  8857. C
  8858. C  10 G(IR,J) = 0.E0
  8859. C
  8860. C     MT=1
  8861. C
  8862. C     JT=N+1
  8863. C
  8864. C     CALL BNDACC(G,MDG,NB,IP,IR,MT,JT)
  8865. C
  8866. C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
  8867. C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
  8868. C***ROUTINES CALLED  H12, XERMSG
  8869. C***REVISION HISTORY  (YYMMDD)
  8870. C   790101  DATE WRITTEN
  8871. C   890531  Changed all specific intrinsics to generic.  (WRB)
  8872. C   891006  Cosmetic changes to prologue.  (WRB)
  8873. C   891006  REVISION DATE from Version 3.2
  8874. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  8875. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  8876. C   900326  Removed duplicate information from DESCRIPTION section.
  8877. C           (WRB)
  8878. C   920501  Reformatted the REFERENCES section.  (WRB)
  8879. C***END PROLOGUE  BNDACC
  8880.       DIMENSION G(MDG,*)
  8881. C***FIRST EXECUTABLE STATEMENT  BNDACC
  8882.       ZERO=0.
  8883. C
  8884. C              ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE.
  8885. C
  8886.       NBP1=NB+1
  8887.       IF (MT.LE.0.OR.NB.LE.0) RETURN
  8888. C
  8889.       IF(.NOT.MDG.LT.IR) GO TO 5
  8890.       NERR=1
  8891.       IOPT=2
  8892.       CALL XERMSG ('SLATEC', 'BNDACC', 'MDG.LT.IR, PROBABLE ERROR.',
  8893.      +   NERR, IOPT)
  8894.       RETURN
  8895.     5 CONTINUE
  8896. C
  8897. C                                             ALG. STEP 5
  8898.       IF (JT.EQ.IP) GO TO 70
  8899. C                                             ALG. STEPS 6-7
  8900.       IF (JT.LE.IR) GO TO 30
  8901. C                                             ALG. STEPS 8-9
  8902.       DO 10 I=1,MT
  8903.         IG1=JT+MT-I
  8904.         IG2=IR+MT-I
  8905.         DO 10 J=1,NBP1
  8906.         G(IG1,J)=G(IG2,J)
  8907.    10 CONTINUE
  8908. C                                             ALG. STEP 10
  8909.       IE=JT-IR
  8910.       DO 20 I=1,IE
  8911.         IG=IR+I-1
  8912.         DO 20 J=1,NBP1
  8913.         G(IG,J)=ZERO
  8914.    20 CONTINUE
  8915. C                                             ALG. STEP 11
  8916.       IR=JT
  8917. C                                             ALG. STEP 12
  8918.    30 MU=MIN(NB-1,IR-IP-1)
  8919.       IF (MU.EQ.0) GO TO 60
  8920. C                                             ALG. STEP 13
  8921.       DO 50 L=1,MU
  8922. C                                             ALG. STEP 14
  8923.         K=MIN(L,JT-IP)
  8924. C                                             ALG. STEP 15
  8925.         LP1=L+1
  8926.         IG=IP+L
  8927.         DO 40 I=LP1,NB
  8928.           JG=I-K
  8929.           G(IG,JG)=G(IG,I)
  8930.    40 CONTINUE
  8931. C                                             ALG. STEP 16
  8932.         DO 50 I=1,K
  8933.         JG=NBP1-I
  8934.         G(IG,JG)=ZERO
  8935.    50 CONTINUE
  8936. C                                             ALG. STEP 17
  8937.    60 IP=JT
  8938. C                                             ALG. STEPS 18-19
  8939.    70 MH=IR+MT-IP
  8940.       KH=MIN(NBP1,MH)
  8941. C                                             ALG. STEP 20
  8942.       DO 80 I=1,KH
  8943.         CALL H12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO,
  8944.      1            G(IP,I+1),1,MDG,NBP1-I)
  8945.    80 CONTINUE
  8946. C                                             ALG. STEP 21
  8947.       IR=IP+KH
  8948. C                                             ALG. STEP 22
  8949.       IF (KH.LT.NBP1) GO TO 100
  8950. C                                             ALG. STEP 23
  8951.       DO 90 I=1,NB
  8952.         G(IR-1,I)=ZERO
  8953.    90 CONTINUE
  8954. C                                             ALG. STEP 24
  8955.   100 CONTINUE
  8956. C                                             ALG. STEP 25
  8957.       RETURN
  8958.       END
  8959. *DECK BNDSOL
  8960.       SUBROUTINE BNDSOL (MODE, G, MDG, NB, IP, IR, X, N, RNORM)
  8961. C***BEGIN PROLOGUE  BNDSOL
  8962. C***PURPOSE  Solve the least squares problem for a banded matrix using
  8963. C            sequential accumulation of rows of the data matrix.
  8964. C            Exactly one right-hand side vector is permitted.
  8965. C***LIBRARY   SLATEC
  8966. C***CATEGORY  D9
  8967. C***TYPE      SINGLE PRECISION (BNDSOL-S, DBNDSL-D)
  8968. C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
  8969. C***AUTHOR  Lawson, C. L., (JPL)
  8970. C           Hanson, R. J., (SNLA)
  8971. C***DESCRIPTION
  8972. C
  8973. C     These subroutines solve the least squares problem Ax = b for
  8974. C     banded matrices A using sequential accumulation of rows of the
  8975. C     data matrix.  Exactly one right-hand side vector is permitted.
  8976. C
  8977. C     These subroutines are intended for the type of least squares
  8978. C     systems that arise in applications such as curve or surface
  8979. C     fitting of data.  The least squares equations are accumulated and
  8980. C     processed using only part of the data.  This requires a certain
  8981. C     user interaction during the solution of Ax = b.
  8982. C
  8983. C     Specifically, suppose the data matrix (A B) is row partitioned
  8984. C     into Q submatrices.  Let (E F) be the T-th one of these
  8985. C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
  8986. C     and the dimension of C is MT by NB.  The value of NB is the
  8987. C     bandwidth of A.  The dimensions of the leading block of zeros in E
  8988. C     are MT by JT-1.
  8989. C
  8990. C     The user of the subroutine BNDACC provides MT,JT,C and F for
  8991. C     T=1,...,Q.  Not all of this data must be supplied at once.
  8992. C
  8993. C     Following the processing of the various blocks (E F), the matrix
  8994. C     (A B) has been transformed to the form (R D) where R is upper
  8995. C     triangular and banded with bandwidth NB.  The least squares
  8996. C     system Rx = d is then easily solved using back substitution by
  8997. C     executing the statement CALL BNDSOL(1,...). The sequence of
  8998. C     values for JT must be nondecreasing.  This may require some
  8999. C     preliminary interchanges of rows and columns of the matrix A.
  9000. C
  9001. C     The primary reason for these subroutines is that the total
  9002. C     processing can take place in a working array of dimension MU by
  9003. C     NB+1.  An acceptable value for MU is
  9004. C
  9005. C                       MU = MAX(MT + N + 1),
  9006. C
  9007. C     where N is the number of unknowns.
  9008. C
  9009. C     Here the maximum is taken over all values of MT for T=1,...,Q.
  9010. C     Notice that MT can be taken to be a small as one, showing that
  9011. C     MU can be as small as N+2.  The subprogram BNDACC processes the
  9012. C     rows more efficiently if MU is large enough so that each new
  9013. C     block (C F) has a distinct value of JT.
  9014. C
  9015. C     The four principle parts of these algorithms are obtained by the
  9016. C     following call statements
  9017. C
  9018. C     CALL BNDACC(...)  Introduce new blocks of data.
  9019. C
  9020. C     CALL BNDSOL(1,...)Compute solution vector and length of
  9021. C                       residual vector.
  9022. C
  9023. C     CALL BNDSOL(2,...)Given any row vector H solve YR = H for the
  9024. C                       row vector Y.
  9025. C
  9026. C     CALL BNDSOL(3,...)Given any column vector W solve RZ = W for
  9027. C                       the column vector Z.
  9028. C
  9029. C     The dots in the above call statements indicate additional
  9030. C     arguments that will be specified in the following paragraphs.
  9031. C
  9032. C     The user must dimension the array appearing in the call list..
  9033. C     G(MDG,NB+1)
  9034. C
  9035. C     Description of calling sequence for BNDACC..
  9036. C
  9037. C     The entire set of parameters for BNDACC are
  9038. C
  9039. C     Input..
  9040. C
  9041. C     G(*,*)            The working array into which the user will
  9042. C                       place the MT by NB+1 block (C F) in rows IR
  9043. C                       through IR+MT-1, columns 1 through NB+1.
  9044. C                       See descriptions of IR and MT below.
  9045. C
  9046. C     MDG               The number of rows in the working array
  9047. C                       G(*,*).  The value of MDG should be .GE. MU.
  9048. C                       The value of MU is defined in the abstract
  9049. C                       of these subprograms.
  9050. C
  9051. C     NB                The bandwidth of the data matrix A.
  9052. C
  9053. C     IP                Set by the user to the value 1 before the
  9054. C                       first call to BNDACC.  Its subsequent value
  9055. C                       is controlled by BNDACC to set up for the
  9056. C                       next call to BNDACC.
  9057. C
  9058. C     IR                Index of the row of G(*,*) where the user is
  9059. C                       the user to the value 1 before the first call
  9060. C                       to BNDACC.  Its subsequent value is controlled
  9061. C                       by BNDACC. A value of IR .GT. MDG is considered
  9062. C                       an error.
  9063. C
  9064. C     MT,JT             Set by the user to indicate respectively the
  9065. C                       number of new rows of data in the block and
  9066. C                       the index of the first nonzero column in that
  9067. C                       set of rows (E F) = (0 C 0 F) being processed.
  9068. C     Output..
  9069. C
  9070. C     G(*,*)            The working array which will contain the
  9071. C                       processed rows of that part of the data
  9072. C                       matrix which has been passed to BNDACC.
  9073. C
  9074. C     IP,IR             The values of these arguments are advanced by
  9075. C                       BNDACC to be ready for storing and processing
  9076. C                       a new block of data in G(*,*).
  9077. C
  9078. C     Description of calling sequence for BNDSOL..
  9079. C
  9080. C     The user must dimension the arrays appearing in the call list..
  9081. C
  9082. C     G(MDG,NB+1), X(N)
  9083. C
  9084. C     The entire set of parameters for BNDSOL are
  9085. C
  9086. C     Input..
  9087. C
  9088. C     MODE              Set by the user to one of the values 1, 2, or
  9089. C                       3.  These values respectively indicate that
  9090. C                       the solution of AX = B, YR = H or RZ = W is
  9091. C                       required.
  9092. C
  9093. C     G(*,*),MDG,       These arguments all have the same meaning and
  9094. C      NB,IP,IR         contents as following the last call to BNDACC.
  9095. C
  9096. C     X(*)              With mode=2 or 3 this array contains,
  9097. C                       respectively, the right-side vectors H or W of
  9098. C                       the systems YR = H or RZ = W.
  9099. C
  9100. C     N                 The number of variables in the solution
  9101. C                       vector.  If any of the N diagonal terms are
  9102. C                       zero the subroutine BNDSOL prints an
  9103. C                       appropriate message.  This condition is
  9104. C                       considered an error.
  9105. C
  9106. C     Output..
  9107. C
  9108. C     X(*)              This array contains the solution vectors X,
  9109. C                       Y or Z of the systems AX = B, YR = H or
  9110. C                       RZ = W depending on the value of MODE=1,
  9111. C                       2 or 3.
  9112. C
  9113. C     RNORM             If MODE=1 RNORM is the Euclidean length of the
  9114. C                       residual vector AX-B.  When MODE=2 or 3 RNORM
  9115. C                       is set to zero.
  9116. C
  9117. C     Remarks..
  9118. C
  9119. C     To obtain the upper triangular matrix and transformed right-hand
  9120. C     side vector D so that the super diagonals of R form the columns
  9121. C     of G(*,*), execute the following Fortran statements.
  9122. C
  9123. C     NBP1=NB+1
  9124. C
  9125. C     DO 10 J=1, NBP1
  9126. C
  9127. C  10 G(IR,J) = 0.E0
  9128. C
  9129. C     MT=1
  9130. C
  9131. C     JT=N+1
  9132. C
  9133. C     CALL BNDACC(G,MDG,NB,IP,IR,MT,JT)
  9134. C
  9135. C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
  9136. C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
  9137. C***ROUTINES CALLED  XERMSG
  9138. C***REVISION HISTORY  (YYMMDD)
  9139. C   790101  DATE WRITTEN
  9140. C   890531  Changed all specific intrinsics to generic.  (WRB)
  9141. C   890831  Modified array declarations.  (WRB)
  9142. C   891006  Cosmetic changes to prologue.  (WRB)
  9143. C   891006  REVISION DATE from Version 3.2
  9144. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  9145. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  9146. C   900326  Removed duplicate information from DESCRIPTION section.
  9147. C           (WRB)
  9148. C   920501  Reformatted the REFERENCES section.  (WRB)
  9149. C***END PROLOGUE  BNDSOL
  9150.       DIMENSION G(MDG,*),X(*)
  9151. C***FIRST EXECUTABLE STATEMENT  BNDSOL
  9152.       ZERO=0.
  9153. C
  9154.       RNORM=ZERO
  9155.       GO TO (10,90,50), MODE
  9156. C                                   ********************* MODE = 1
  9157. C                                   ALG. STEP 26
  9158.    10      DO 20 J=1,N
  9159.            X(J)=G(J,NB+1)
  9160.    20 CONTINUE
  9161.       RSQ=ZERO
  9162.       NP1=N+1
  9163.       IRM1=IR-1
  9164.       IF (NP1.GT.IRM1) GO TO 40
  9165.            DO 30 J=NP1,IRM1
  9166.            RSQ=RSQ+G(J,NB+1)**2
  9167.    30 CONTINUE
  9168.       RNORM=SQRT(RSQ)
  9169.    40 CONTINUE
  9170. C                                   ********************* MODE = 3
  9171. C                                   ALG. STEP 27
  9172.    50      DO 80 II=1,N
  9173.            I=N+1-II
  9174. C                                   ALG. STEP 28
  9175.            S=ZERO
  9176.            L=MAX(0,I-IP)
  9177. C                                   ALG. STEP 29
  9178.            IF (I.EQ.N) GO TO 70
  9179. C                                   ALG. STEP 30
  9180.            IE=MIN(N+1-I,NB)
  9181.                 DO 60 J=2,IE
  9182.                 JG=J+L
  9183.                 IX=I-1+J
  9184.                 S=S+G(I,JG)*X(IX)
  9185.    60 CONTINUE
  9186. C                                   ALG. STEP 31
  9187.    70      IF (G(I,L+1)) 80,130,80
  9188.    80      X(I)=(X(I)-S)/G(I,L+1)
  9189. C                                   ALG. STEP 32
  9190.       RETURN
  9191. C                                   ********************* MODE = 2
  9192.    90      DO 120 J=1,N
  9193.            S=ZERO
  9194.            IF (J.EQ.1) GO TO 110
  9195.            I1=MAX(1,J-NB+1)
  9196.            I2=J-1
  9197.                 DO 100 I=I1,I2
  9198.                 L=J-I+1+MAX(0,I-IP)
  9199.                 S=S+X(I)*G(I,L)
  9200.   100 CONTINUE
  9201.   110      L=MAX(0,J-IP)
  9202.            IF (G(J,L+1)) 120,130,120
  9203.   120      X(J)=(X(J)-S)/G(J,L+1)
  9204.       RETURN
  9205. C
  9206.   130 CONTINUE
  9207.       NERR=1
  9208.       IOPT=2
  9209.       CALL XERMSG ('SLATEC', 'BNDSOL',
  9210.      +   'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' //
  9211.      +   'MATRIX.', NERR, IOPT)
  9212.       RETURN
  9213.       END
  9214. *DECK BNFAC
  9215.       SUBROUTINE BNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG)
  9216. C***BEGIN PROLOGUE  BNFAC
  9217. C***SUBSIDIARY
  9218. C***PURPOSE  Subsidiary to BINT4 and BINTK
  9219. C***LIBRARY   SLATEC
  9220. C***TYPE      SINGLE PRECISION (BNFAC-S, DBNFAC-D)
  9221. C***AUTHOR  (UNKNOWN)
  9222. C***DESCRIPTION
  9223. C
  9224. C  BNFAC is the BANFAC routine from
  9225. C        * A Practical Guide to Splines *  by C. de Boor
  9226. C
  9227. C  Returns in  W  the lu-factorization (without pivoting) of the banded
  9228. C  matrix  A  of order  NROW  with  (NBANDL + 1 + NBANDU) bands or diag-
  9229. C  onals in the work array  W .
  9230. C
  9231. C *****  I N P U T  ******
  9232. C  W.....Work array of size  (NROWW,NROW)  containing the interesting
  9233. C        part of a banded matrix  A , with the diagonals or bands of  A
  9234. C        stored in the rows of  W , while columns of  A  correspond to
  9235. C        columns of  W . This is the storage mode used in  LINPACK  and
  9236. C        results in efficient innermost loops.
  9237. C           Explicitly,  A  has  NBANDL  bands below the diagonal
  9238. C                            +     1     (main) diagonal
  9239. C                            +   NBANDU  bands above the diagonal
  9240. C        and thus, with    MIDDLE = NBANDU + 1,
  9241. C          A(I+J,J)  is in  W(I+MIDDLE,J)  for I=-NBANDU,...,NBANDL
  9242. C                                              J=1,...,NROW .
  9243. C        For example, the interesting entries of A (1,2)-banded matrix
  9244. C        of order  9  would appear in the first  1+1+2 = 4  rows of  W
  9245. C        as follows.
  9246. C                          13 24 35 46 57 68 79
  9247. C                       12 23 34 45 56 67 78 89
  9248. C                    11 22 33 44 55 66 77 88 99
  9249. C                    21 32 43 54 65 76 87 98
  9250. C
  9251. C        All other entries of  W  not identified in this way with an en-
  9252. C        try of  A  are never referenced .
  9253. C  NROWW.....Row dimension of the work array  W .
  9254. C        must be  .GE.  NBANDL + 1 + NBANDU  .
  9255. C  NBANDL.....Number of bands of  A  below the main diagonal
  9256. C  NBANDU.....Number of bands of  A  above the main diagonal .
  9257. C
  9258. C *****  O U T P U T  ******
  9259. C  IFLAG.....Integer indicating success( = 1) or failure ( = 2) .
  9260. C     If  IFLAG = 1, then
  9261. C  W.....contains the LU-factorization of  A  into a unit lower triangu-
  9262. C        lar matrix  L  and an upper triangular matrix  U (both banded)
  9263. C        and stored in customary fashion over the corresponding entries
  9264. C        of  A . This makes it possible to solve any particular linear
  9265. C        system  A*X = B  for  X  by A
  9266. C              CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
  9267. C        with the solution X  contained in  B  on return .
  9268. C     If  IFLAG = 2, then
  9269. C        one of  NROW-1, NBANDL,NBANDU failed to be nonnegative, or else
  9270. C        one of the potential pivots was found to be zero indicating
  9271. C        that  A  does not have an LU-factorization. This implies that
  9272. C        A  is singular in case it is totally positive .
  9273. C
  9274. C *****  M E T H O D  ******
  9275. C     Gauss elimination  W I T H O U T  pivoting is used. The routine is
  9276. C  intended for use with matrices  A  which do not require row inter-
  9277. C  changes during factorization, especially for the  T O T A L L Y
  9278. C  P O S I T I V E  matrices which occur in spline calculations.
  9279. C     The routine should not be used for an arbitrary banded matrix.
  9280. C
  9281. C***SEE ALSO  BINT4, BINTK
  9282. C***ROUTINES CALLED  (NONE)
  9283. C***REVISION HISTORY  (YYMMDD)
  9284. C   800901  DATE WRITTEN
  9285. C   890531  Changed all specific intrinsics to generic.  (WRB)
  9286. C   890831  Modified array declarations.  (WRB)
  9287. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  9288. C   900328  Added TYPE section.  (WRB)
  9289. C***END PROLOGUE  BNFAC
  9290. C
  9291.       INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K,
  9292.      1 KMAX, MIDDLE, MIDMK, NROWM1
  9293.       REAL W(NROWW,*), FACTOR, PIVOT
  9294. C
  9295. C***FIRST EXECUTABLE STATEMENT  BNFAC
  9296.       IFLAG = 1
  9297.       MIDDLE = NBANDU + 1
  9298. C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
  9299.       NROWM1 = NROW - 1
  9300.       IF (NROWM1) 120, 110, 10
  9301.    10 IF (NBANDL.GT.0) GO TO 30
  9302. C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
  9303.       DO 20 I=1,NROWM1
  9304.         IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120
  9305.    20 CONTINUE
  9306.       GO TO 110
  9307.    30 IF (NBANDU.GT.0) GO TO 60
  9308. C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
  9309. C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
  9310.       DO 50 I=1,NROWM1
  9311.         PIVOT = W(MIDDLE,I)
  9312.         IF (PIVOT.EQ.0.0E0) GO TO 120
  9313.         JMAX = MIN(NBANDL,NROW-I)
  9314.         DO 40 J=1,JMAX
  9315.           W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
  9316.    40   CONTINUE
  9317.    50 CONTINUE
  9318.       RETURN
  9319. C
  9320. C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
  9321.    60 DO 100 I=1,NROWM1
  9322. C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
  9323.         PIVOT = W(MIDDLE,I)
  9324.         IF (PIVOT.EQ.0.0E0) GO TO 120
  9325. C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
  9326. C                     BELOW THE DIAGONAL .
  9327.         JMAX = MIN(NBANDL,NROW-I)
  9328. C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
  9329.         DO 70 J=1,JMAX
  9330.           W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
  9331.    70   CONTINUE
  9332. C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
  9333. C                     THE RIGHT OF THE DIAGONAL .
  9334.         KMAX = MIN(NBANDU,NROW-I)
  9335. C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
  9336. C                  (BELOW ROW  I ) .
  9337.         DO 90 K=1,KMAX
  9338.           IPK = I + K
  9339.           MIDMK = MIDDLE - K
  9340.           FACTOR = W(MIDMK,IPK)
  9341.           DO 80 J=1,JMAX
  9342.             W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR
  9343.    80     CONTINUE
  9344.    90   CONTINUE
  9345.   100 CONTINUE
  9346. C                                       CHECK THE LAST DIAGONAL ENTRY .
  9347.   110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN
  9348.   120 IFLAG = 2
  9349.       RETURN
  9350.       END
  9351. *DECK BNSLV
  9352.       SUBROUTINE BNSLV (W, NROWW, NROW, NBANDL, NBANDU, B)
  9353. C***BEGIN PROLOGUE  BNSLV
  9354. C***SUBSIDIARY
  9355. C***PURPOSE  Subsidiary to BINT4 and BINTK
  9356. C***LIBRARY   SLATEC
  9357. C***TYPE      SINGLE PRECISION (BNSLV-S, DBNSLV-D)
  9358. C***AUTHOR  (UNKNOWN)
  9359. C***DESCRIPTION
  9360. C
  9361. C  BNSLV is the BANSLV routine from
  9362. C        * A Practical Guide to Splines *  by C. de Boor
  9363. C
  9364. C  Companion routine to  BNFAC . It returns the solution  X  of the
  9365. C  linear system  A*X = B  in place of  B , given the LU-factorization
  9366. C  for  A  in the work array  W from BNFAC.
  9367. C
  9368. C *****  I N P U T  ******
  9369. C  W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a
  9370. C        banded matrix  A  of order  NROW  as constructed in  BNFAC .
  9371. C        For details, see  BNFAC .
  9372. C  B.....Right side of the system to be solved .
  9373. C
  9374. C *****  O U T P U T  ******
  9375. C  B.....Contains the solution  X , of order  NROW .
  9376. C
  9377. C *****  M E T H O D  ******
  9378. C     (With  A = L*U, as stored in  W,) the unit lower triangular system
  9379. C  L(U*X) = B  is solved for  Y = U*X, and  Y  stored in  B . Then the
  9380. C  upper triangular system  U*X = Y  is solved for  X  . The calcul-
  9381. C  ations are so arranged that the innermost loops stay within columns.
  9382. C
  9383. C***SEE ALSO  BINT4, BINTK
  9384. C***ROUTINES CALLED  (NONE)
  9385. C***REVISION HISTORY  (YYMMDD)
  9386. C   800901  DATE WRITTEN
  9387. C   890531  Changed all specific intrinsics to generic.  (WRB)
  9388. C   890831  Modified array declarations.  (WRB)
  9389. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  9390. C   900328  Added TYPE section.  (WRB)
  9391. C***END PROLOGUE  BNSLV
  9392. C
  9393.       INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1
  9394.       REAL W(NROWW,*), B(*)
  9395. C***FIRST EXECUTABLE STATEMENT  BNSLV
  9396.       MIDDLE = NBANDU + 1
  9397.       IF (NROW.EQ.1) GO TO 80
  9398.       NROWM1 = NROW - 1
  9399.       IF (NBANDL.EQ.0) GO TO 30
  9400. C                                 FORWARD PASS
  9401. C            FOR I=1,2,...,NROW-1, SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
  9402. C            OF  L )  FROM RIGHT SIDE  (BELOW I-TH ROW) .
  9403.       DO 20 I=1,NROWM1
  9404.         JMAX = MIN(NBANDL,NROW-I)
  9405.         DO 10 J=1,JMAX
  9406.           B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I)
  9407.    10   CONTINUE
  9408.    20 CONTINUE
  9409. C                                 BACKWARD PASS
  9410. C            FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG-
  9411. C            ONAL ENTRY OF  U, THEN SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
  9412. C            OF  U)  FROM RIGHT SIDE  (ABOVE I-TH ROW).
  9413.    30 IF (NBANDU.GT.0) GO TO 50
  9414. C                                A  IS LOWER TRIANGULAR .
  9415.       DO 40 I=1,NROW
  9416.         B(I) = B(I)/W(1,I)
  9417.    40 CONTINUE
  9418.       RETURN
  9419.    50 I = NROW
  9420.    60 B(I) = B(I)/W(MIDDLE,I)
  9421.       JMAX = MIN(NBANDU,I-1)
  9422.       DO 70 J=1,JMAX
  9423.         B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I)
  9424.    70 CONTINUE
  9425.       I = I - 1
  9426.       IF (I.GT.1) GO TO 60
  9427.    80 B(1) = B(1)/W(MIDDLE,1)
  9428.       RETURN
  9429.       END
  9430. *DECK BQR
  9431.       SUBROUTINE BQR (NM, N, MB, A, T, R, IERR, NV, RV)
  9432. C***BEGIN PROLOGUE  BQR
  9433. C***PURPOSE  Compute some of the eigenvalues of a real symmetric
  9434. C            matrix using the QR method with shifts of origin.
  9435. C***LIBRARY   SLATEC (EISPACK)
  9436. C***CATEGORY  D4A6
  9437. C***TYPE      SINGLE PRECISION (BQR-S)
  9438. C***KEYWORDS  EIGENVALUES, EISPACK
  9439. C***AUTHOR  Smith, B. T., et al.
  9440. C***DESCRIPTION
  9441. C
  9442. C     This subroutine is a translation of the ALGOL procedure BQR,
  9443. C     NUM. MATH. 16, 85-92(1970) by Martin, Reinsch, and Wilkinson.
  9444. C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971).
  9445. C
  9446. C     This subroutine finds the eigenvalue of smallest (usually)
  9447. C     magnitude of a REAL SYMMETRIC BAND matrix using the
  9448. C     QR algorithm with shifts of origin.  Consecutive calls
  9449. C     can be made to find further eigenvalues.
  9450. C
  9451. C     On INPUT
  9452. C
  9453. C        NM must be set to the row dimension of the two-dimensional
  9454. C          array parameter, A, as declared in the calling program
  9455. C          dimension statement.  NM is an INTEGER variable.
  9456. C
  9457. C        N is the order of the matrix A.  N is an INTEGER variable.
  9458. C          N must be less than or equal to NM.
  9459. C
  9460. C        MB is the (half) band width of the matrix, defined as the
  9461. C          number of adjacent diagonals, including the principal
  9462. C          diagonal, required to specify the non-zero portion of the
  9463. C          lower triangle of the matrix.  MB is an INTEGER variable.
  9464. C          MB must be less than or equal to N on first call.
  9465. C
  9466. C        A contains the lower triangle of the symmetric band input
  9467. C          matrix stored as an N by MB array.  Its lowest subdiagonal
  9468. C          is stored in the last N+1-MB positions of the first column,
  9469. C          its next subdiagonal in the last N+2-MB positions of the
  9470. C          second column, further subdiagonals similarly, and finally
  9471. C          its principal diagonal in the N positions of the last column.
  9472. C          Contents of storages not part of the matrix are arbitrary.
  9473. C          On a subsequent call, its output contents from the previous
  9474. C          call should be passed.  A is a two-dimensional REAL array,
  9475. C          dimensioned A(NM,MB).
  9476. C
  9477. C        T specifies the shift (of eigenvalues) applied to the diagonal
  9478. C          of A in forming the input matrix. What is actually determined
  9479. C          is the eigenvalue of A+TI (I is the identity matrix) nearest
  9480. C          to T.  On a subsequent call, the output value of T from the
  9481. C          previous call should be passed if the next nearest eigenvalue
  9482. C          is sought.  T is a REAL variable.
  9483. C
  9484. C        R should be specified as zero on the first call, and as its
  9485. C          output value from the previous call on a subsequent call.
  9486. C          It is used to determine when the last row and column of
  9487. C          the transformed band matrix can be regarded as negligible.
  9488. C          R is a REAL variable.
  9489. C
  9490. C        NV must be set to the dimension of the array parameter RV
  9491. C          as declared in the calling program dimension statement.
  9492. C          NV is an INTEGER variable.
  9493. C
  9494. C     On OUTPUT
  9495. C
  9496. C        A contains the transformed band matrix.  The matrix A+TI
  9497. C          derived from the output parameters is similar to the
  9498. C          input A+TI to within rounding errors.  Its last row and
  9499. C          column are null (if IERR is zero).
  9500. C
  9501. C        T contains the computed eigenvalue of A+TI (if IERR is zero),
  9502. C          where I is the identity matrix.
  9503. C
  9504. C        R contains the maximum of its input value and the norm of the
  9505. C          last column of the input matrix A.
  9506. C
  9507. C        IERR is an INTEGER flag set to
  9508. C          Zero       for normal return,
  9509. C          J          if the J-th eigenvalue has not been
  9510. C                     determined after a total of 30 iterations.
  9511. C
  9512. C        RV is a one-dimensional REAL array of dimension NV which is
  9513. C          at least (2*MB**2+4*MB-3), used for temporary storage.  The
  9514. C          first (3*MB-2) locations correspond to the ALGOL array B,
  9515. C          the next (2*MB-1) locations correspond to the ALGOL array H,
  9516. C          and the final (2*MB**2-MB) locations correspond to the MB
  9517. C          by (2*MB-1) ALGOL array U.
  9518. C
  9519. C     NOTE. For a subsequent call, N should be replaced by N-1, but
  9520. C     MB should not be altered even when it exceeds the current N.
  9521. C
  9522. C     Calls PYTHAG(A,B) for SQRT(A**2 + B**2).
  9523. C
  9524. C     Questions and comments should be directed to B. S. Garbow,
  9525. C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
  9526. C     ------------------------------------------------------------------
  9527. C
  9528. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  9529. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  9530. C                 system Routines - EISPACK Guide, Springer-Verlag,
  9531. C                 1976.
  9532. C***ROUTINES CALLED  PYTHAG
  9533. C***REVISION HISTORY  (YYMMDD)
  9534. C   760101  DATE WRITTEN
  9535. C   890531  Changed all specific intrinsics to generic.  (WRB)
  9536. C   890831  Modified array declarations.  (WRB)
  9537. C   890831  REVISION DATE from Version 3.2
  9538. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  9539. C   920501  Reformatted the REFERENCES section.  (WRB)
  9540. C***END PROLOGUE  BQR
  9541. C
  9542.       INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ
  9543.       INTEGER M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT
  9544.       REAL A(NM,*),RV(*)
  9545.       REAL F,G,Q,R,S,T,SCALE
  9546.       REAL PYTHAG
  9547. C
  9548. C***FIRST EXECUTABLE STATEMENT  BQR
  9549.       IERR = 0
  9550.       M1 = MIN(MB,N)
  9551.       M = M1 - 1
  9552.       M2 = M + M
  9553.       M21 = M2 + 1
  9554.       M3 = M21 + M
  9555.       M31 = M3 + 1
  9556.       M4 = M31 + M2
  9557.       MN = M + N
  9558.       MZ = MB - M1
  9559.       ITS = 0
  9560. C     .......... TEST FOR CONVERGENCE ..........
  9561.    40 G = A(N,MB)
  9562.       IF (M .EQ. 0) GO TO 360
  9563.       F = 0.0E0
  9564. C
  9565.       DO 50 K = 1, M
  9566.          MK = K + MZ
  9567.          F = F + ABS(A(N,MK))
  9568.    50 CONTINUE
  9569. C
  9570.       IF (ITS .EQ. 0 .AND. F .GT. R) R = F
  9571.       IF (R + F .LE. R) GO TO 360
  9572.       IF (ITS .EQ. 30) GO TO 1000
  9573.       ITS = ITS + 1
  9574. C     .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
  9575.       IF (F .GT. 0.25E0 * R .AND. ITS .LT. 5) GO TO 90
  9576.       F = A(N,MB-1)
  9577.       IF (F .EQ. 0.0E0) GO TO 70
  9578.       Q = (A(N-1,MB) - G) / (2.0E0 * F)
  9579.       S = PYTHAG(Q,1.0E0)
  9580.       G = G - F / (Q + SIGN(S,Q))
  9581.    70 T = T + G
  9582. C
  9583.       DO 80 I = 1, N
  9584.    80 A(I,MB) = A(I,MB) - G
  9585. C
  9586.    90 DO 100 K = M31, M4
  9587.   100 RV(K) = 0.0E0
  9588. C
  9589.       DO 350 II = 1, MN
  9590.          I = II - M
  9591.          NI = N - II
  9592.          IF (NI .LT. 0) GO TO 230
  9593. C     .......... FORM COLUMN OF SHIFTED MATRIX A-G*I ..........
  9594.          L = MAX(1,2-I)
  9595. C
  9596.          DO 110 K = 1, M3
  9597.   110    RV(K) = 0.0E0
  9598. C
  9599.          DO 120 K = L, M1
  9600.             KM = K + M
  9601.             MK = K + MZ
  9602.             RV(KM) = A(II,MK)
  9603.   120    CONTINUE
  9604. C
  9605.          LL = MIN(M,NI)
  9606.          IF (LL .EQ. 0) GO TO 135
  9607. C
  9608.          DO 130 K = 1, LL
  9609.             KM = K + M21
  9610.             IK = II + K
  9611.             MK = MB - K
  9612.             RV(KM) = A(IK,MK)
  9613.   130    CONTINUE
  9614. C     .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  9615.   135    LL = M2
  9616.          IMULT = 0
  9617. C     .......... MULTIPLICATION PROCEDURE ..........
  9618.   140    KJ = M4 - M1
  9619. C
  9620.          DO 170 J = 1, LL
  9621.             KJ = KJ + M1
  9622.             JM = J + M3
  9623.             IF (RV(JM) .EQ. 0.0E0) GO TO 170
  9624.             F = 0.0E0
  9625. C
  9626.             DO 150 K = 1, M1
  9627.                KJ = KJ + 1
  9628.                JK = J + K - 1
  9629.                F = F + RV(KJ) * RV(JK)
  9630.   150       CONTINUE
  9631. C
  9632.             F = F / RV(JM)
  9633.             KJ = KJ - M1
  9634. C
  9635.             DO 160 K = 1, M1
  9636.                KJ = KJ + 1
  9637.                JK = J + K - 1
  9638.                RV(JK) = RV(JK) - RV(KJ) * F
  9639.   160       CONTINUE
  9640. C
  9641.             KJ = KJ - M1
  9642.   170    CONTINUE
  9643. C
  9644.          IF (IMULT .NE. 0) GO TO 280
  9645. C     .......... HOUSEHOLDER REFLECTION ..........
  9646.          F = RV(M21)
  9647.          S = 0.0E0
  9648.          RV(M4) = 0.0E0
  9649.          SCALE = 0.0E0
  9650. C
  9651.          DO 180 K = M21, M3
  9652.   180    SCALE = SCALE + ABS(RV(K))
  9653. C
  9654.          IF (SCALE .EQ. 0.0E0) GO TO 210
  9655. C
  9656.          DO 190 K = M21, M3
  9657.   190    S = S + (RV(K)/SCALE)**2
  9658. C
  9659.          S = SCALE * SCALE * S
  9660.          G = -SIGN(SQRT(S),F)
  9661.          RV(M21) = G
  9662.          RV(M4) = S - F * G
  9663.          KJ = M4 + M2 * M1 + 1
  9664.          RV(KJ) = F - G
  9665. C
  9666.          DO 200 K = 2, M1
  9667.             KJ = KJ + 1
  9668.             KM = K + M2
  9669.             RV(KJ) = RV(KM)
  9670.   200    CONTINUE
  9671. C     .......... SAVE COLUMN OF TRIANGULAR FACTOR R ..........
  9672.   210    DO 220 K = L, M1
  9673.             KM = K + M
  9674.             MK = K + MZ
  9675.             A(II,MK) = RV(KM)
  9676.   220    CONTINUE
  9677. C
  9678.   230    L = MAX(1,M1+1-I)
  9679.          IF (I .LE. 0) GO TO 300
  9680. C     .......... PERFORM ADDITIONAL STEPS ..........
  9681.          DO 240 K = 1, M21
  9682.   240    RV(K) = 0.0E0
  9683. C
  9684.          LL = MIN(M1,NI+M1)
  9685. C     .......... GET ROW OF TRIANGULAR FACTOR R ..........
  9686.          DO 250 KK = 1, LL
  9687.             K = KK - 1
  9688.             KM = K + M1
  9689.             IK = I + K
  9690.             MK = MB - K
  9691.             RV(KM) = A(IK,MK)
  9692.   250    CONTINUE
  9693. C     .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  9694.          LL = M1
  9695.          IMULT = 1
  9696.          GO TO 140
  9697. C     .......... STORE COLUMN OF NEW A MATRIX ..........
  9698.   280    DO 290 K = L, M1
  9699.             MK = K + MZ
  9700.             A(I,MK) = RV(K)
  9701.   290    CONTINUE
  9702. C     .......... UPDATE HOUSEHOLDER REFLECTIONS ..........
  9703.   300    IF (L .GT. 1) L = L - 1
  9704.          KJ1 = M4 + L * M1
  9705. C
  9706.          DO 320 J = L, M2
  9707.             JM = J + M3
  9708.             RV(JM) = RV(JM+1)
  9709. C
  9710.             DO 320 K = 1, M1
  9711.                KJ1 = KJ1 + 1
  9712.                KJ = KJ1 - M1
  9713.                RV(KJ) = RV(KJ1)
  9714.   320    CONTINUE
  9715. C
  9716.   350 CONTINUE
  9717. C
  9718.       GO TO 40
  9719. C     .......... CONVERGENCE ..........
  9720.   360 T = T + G
  9721. C
  9722.       DO 380 I = 1, N
  9723.   380 A(I,MB) = A(I,MB) - G
  9724. C
  9725.       DO 400 K = 1, M1
  9726.          MK = K + MZ
  9727.          A(N,MK) = 0.0E0
  9728.   400 CONTINUE
  9729. C
  9730.       GO TO 1001
  9731. C     .......... SET ERROR -- NO CONVERGENCE TO
  9732. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  9733.  1000 IERR = N
  9734.  1001 RETURN
  9735.       END
  9736. *DECK BSGQ8
  9737.       SUBROUTINE BSGQ8 (FUN, XT, BC, N, KK, ID, A, B, INBV, ERR, ANS,
  9738.      +   IERR, WORK)
  9739. C***BEGIN PROLOGUE  BSGQ8
  9740. C***SUBSIDIARY
  9741. C***PURPOSE  Subsidiary to BFQAD
  9742. C***LIBRARY   SLATEC
  9743. C***TYPE      SINGLE PRECISION (BSGQ8-S, DBSGQ8-D)
  9744. C***AUTHOR  Jones, R. E., (SNLA)
  9745. C***DESCRIPTION
  9746. C
  9747. C     Abstract
  9748. C        BSGQ8, a modification of GAUS8, integrates the
  9749. C        product of FUN(X) by the ID-th derivative of a spline
  9750. C        BVALU(XT,BC,N,KK,ID,X,INBV,WORK)  between limits A and B.
  9751. C
  9752. C     Description of Arguments
  9753. C
  9754. C        INPUT--
  9755. C        FUN - Name of external function of one argument which
  9756. C              multiplies BVALU.
  9757. C        XT  - Knot array for BVALU
  9758. C        BC  - B-coefficient array for BVALU
  9759. C        N   - Number of B-coefficients for BVALU
  9760. C        KK  - Order of the spline, KK.GE.1
  9761. C        ID  - Order of the spline derivative, 0.LE.ID.LE.KK-1
  9762. C        A   - Lower limit of integral
  9763. C        B   - Upper limit of integral (may be less than A)
  9764. C        INBV- Initialization parameter for BVALU
  9765. C        ERR - Is a requested pseudorelative error tolerance.  Normally
  9766. C              pick a value of ABS(ERR).LT.1E-3.  ANS will normally
  9767. C              have no more error than ABS(ERR) times the integral of
  9768. C              the absolute value of FUN(X)*BVALU(XT,BC,N,KK,X,ID,
  9769. C              INBV,WORK).
  9770. C
  9771. C
  9772. C        OUTPUT--
  9773. C        ERR - Will be an estimate of the absolute error in ANS if the
  9774. C              input value of ERR was negative.  (ERR is unchanged if
  9775. C              the input value of ERR was nonnegative.)  The estimated
  9776. C              error is solely for information to the user and should
  9777. C              not be used as a correction to the computed integral.
  9778. C        ANS - Computed value of integral
  9779. C        IERR- A status code
  9780. C            --Normal Codes
  9781. C               1 ANS most likely meets requested error tolerance,
  9782. C                 or A=B.
  9783. C              -1 A and B are too nearly equal to allow normal
  9784. C                 integration.  ANS is set to zero.
  9785. C            --Abnormal Code
  9786. C               2 ANS probably does not meet requested error tolerance.
  9787. C        WORK- Work vector of length 3*K for BVALU
  9788. C
  9789. C***SEE ALSO  BFQAD
  9790. C***ROUTINES CALLED  BVALU, I1MACH, R1MACH, XERMSG
  9791. C***REVISION HISTORY  (YYMMDD)
  9792. C   800901  DATE WRITTEN
  9793. C   890531  Changed all specific intrinsics to generic.  (WRB)
  9794. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  9795. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  9796. C   900326  Removed duplicate information from DESCRIPTION section.
  9797. C           (WRB)
  9798. C   900328  Added TYPE section.  (WRB)
  9799. C   910408  Updated the AUTHOR section.  (WRB)
  9800. C***END PROLOGUE  BSGQ8
  9801. C
  9802.       INTEGER ID, IERR, INBV, K, KK, KML, KMX, L, LMN, LMX, LR, MXL,
  9803.      1 N, NBITS, NIB, NLMN, NLMX
  9804.       INTEGER I1MACH
  9805.       REAL A, AA, AE, ANIB, ANS, AREA, B, BC, C, CE, EE, EF, EPS, ERR,
  9806.      1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,WORK,W1, W2, W3, W4, XT, X1,
  9807.      2 X2, X3, X4, X, H
  9808.       REAL R1MACH, BVALU, G8, FUN
  9809.       DIMENSION XT(*), BC(*)
  9810.       DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30)
  9811.       SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML
  9812.       DATA X1, X2, X3, X4/
  9813.      1     1.83434642495649805E-01,     5.25532409916328986E-01,
  9814.      2     7.96666477413626740E-01,     9.60289856497536232E-01/
  9815.       DATA W1, W2, W3, W4/
  9816.      1     3.62683783378361983E-01,     3.13706645877887287E-01,
  9817.      2     2.22381034453374471E-01,     1.01228536290376259E-01/
  9818.       DATA SQ2/1.41421356E0/
  9819.       DATA NLMN/1/,KMX/5000/,KML/6/
  9820.       G8(X,H)=H*((W1*(FUN(X-X1*H)*BVALU(XT,BC,N,KK,ID,X-X1*H,INBV,WORK)+
  9821.      1                FUN(X+X1*H)*BVALU(XT,BC,N,KK,ID,X+X1*H,INBV,WORK))
  9822.      2           +W2*(FUN(X-X2*H)*BVALU(XT,BC,N,KK,ID,X-X2*H,INBV,WORK)+
  9823.      3              FUN(X+X2*H)*BVALU(XT,BC,N,KK,ID,X+X2*H,INBV,WORK)))
  9824.      4          +(W3*(FUN(X-X3*H)*BVALU(XT,BC,N,KK,ID,X-X3*H,INBV,WORK)+
  9825.      5                FUN(X+X3*H)*BVALU(XT,BC,N,KK,ID,X+X3*H,INBV,WORK))
  9826.      6           +W4*(FUN(X-X4*H)*BVALU(XT,BC,N,KK,ID,X-X4*H,INBV,WORK)+
  9827.      7             FUN(X+X4*H)*BVALU(XT,BC,N,KK,ID,X+X4*H,INBV,WORK))))
  9828. C
  9829. C     INITIALIZE
  9830. C
  9831. C***FIRST EXECUTABLE STATEMENT  BSGQ8
  9832.       K = I1MACH(11)
  9833.       ANIB = R1MACH(5)*K/0.30102000E0
  9834.       NBITS = INT(ANIB)
  9835.       NLMX = (NBITS*5)/8
  9836.       ANS = 0.0E0
  9837.       IERR = 1
  9838.       CE = 0.0E0
  9839.       IF (A.EQ.B) GO TO 140
  9840.       LMX = NLMX
  9841.       LMN = NLMN
  9842.       IF (B.EQ.0.0E0) GO TO 10
  9843.       IF (SIGN(1.0E0,B)*A.LE.0.0E0) GO TO 10
  9844.       C = ABS(1.0E0-A/B)
  9845.       IF (C.GT.0.1E0) GO TO 10
  9846.       IF (C.LE.0.0E0) GO TO 140
  9847.       ANIB = 0.5E0 - LOG(C)/0.69314718E0
  9848.       NIB = INT(ANIB)
  9849.       LMX = MIN(NLMX,NBITS-NIB-7)
  9850.       IF (LMX.LT.1) GO TO 130
  9851.       LMN = MIN(LMN,LMX)
  9852.    10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0
  9853.       IF (ERR.EQ.0.0E0) TOL = SQRT(R1MACH(4))
  9854.       EPS = TOL
  9855.       HH(1) = (B-A)/4.0E0
  9856.       AA(1) = A
  9857.       LR(1) = 1
  9858.       L = 1
  9859.       EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L))
  9860.       K = 8
  9861.       AREA = ABS(EST)
  9862.       EF = 0.5E0
  9863.       MXL = 0
  9864. C
  9865. C     COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC.
  9866. C
  9867.    20 GL = G8(AA(L)+HH(L),HH(L))
  9868.       GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L))
  9869.       K = K + 16
  9870.       AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST))
  9871.       GLR = GL + GR(L)
  9872.       EE = ABS(EST-GLR)*EF
  9873.       AE = MAX(EPS*AREA,TOL*ABS(GLR))
  9874.       IF (EE-AE) 40, 40, 50
  9875.    30 MXL = 1
  9876.    40 CE = CE + (EST-GLR)
  9877.       IF (LR(L)) 60, 60, 80
  9878. C
  9879. C     CONSIDER THE LEFT HALF OF THIS LEVEL
  9880. C
  9881.    50 IF (K.GT.KMX) LMX = KML
  9882.       IF (L.GE.LMX) GO TO 30
  9883.       L = L + 1
  9884.       EPS = EPS*0.5E0
  9885.       EF = EF/SQ2
  9886.       HH(L) = HH(L-1)*0.5E0
  9887.       LR(L) = -1
  9888.       AA(L) = AA(L-1)
  9889.       EST = GL
  9890.       GO TO 20
  9891. C
  9892. C     PROCEED TO RIGHT HALF AT THIS LEVEL
  9893. C
  9894.    60 VL(L) = GLR
  9895.    70 EST = GR(L-1)
  9896.       LR(L) = 1
  9897.       AA(L) = AA(L) + 4.0E0*HH(L)
  9898.       GO TO 20
  9899. C
  9900. C     RETURN ONE LEVEL
  9901. C
  9902.    80 VR = GLR
  9903.    90 IF (L.LE.1) GO TO 120
  9904.       L = L - 1
  9905.       EPS = EPS*2.0E0
  9906.       EF = EF*SQ2
  9907.       IF (LR(L)) 100, 100, 110
  9908.   100 VL(L) = VL(L+1) + VR
  9909.       GO TO 70
  9910.   110 VR = VL(L+1) + VR
  9911.       GO TO 90
  9912. C
  9913. C      EXIT
  9914. C
  9915.   120 ANS = VR
  9916.       IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0E0*TOL*AREA)) GO TO 140
  9917.       IERR = 2
  9918.       CALL XERMSG ('SLATEC', 'BSGQ8',
  9919.      +   'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1)
  9920.       GO TO 140
  9921.   130 IERR = -1
  9922.       CALL XERMSG ('SLATEC', 'BSGQ8',
  9923.      +   'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' //
  9924.      +   ' ANS IS SET TO ZERO AND IERR TO -1.', 1, -1)
  9925.   140 CONTINUE
  9926.       IF (ERR.LT.0.0E0) ERR = CE
  9927.       RETURN
  9928.       END
  9929. *DECK BSKIN
  9930.       SUBROUTINE BSKIN (X, N, KODE, M, Y, NZ, IERR)
  9931. C***BEGIN PROLOGUE  BSKIN
  9932. C***PURPOSE  Compute repeated integrals of the K-zero Bessel function.
  9933. C***LIBRARY   SLATEC
  9934. C***CATEGORY  C10F
  9935. C***TYPE      SINGLE PRECISION (BSKIN-S, DBSKIN-D)
  9936. C***KEYWORDS  BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL,
  9937. C             INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION
  9938. C***AUTHOR  Amos, D. E., (SNLA)
  9939. C***DESCRIPTION
  9940. C
  9941. C         The following definitions are used in BSKIN:
  9942. C
  9943. C   Definition 1
  9944. C         KI(0,X) = K-zero Bessel function.
  9945. C
  9946. C   Definition 2
  9947. C         KI(N,X) = Bickley Function
  9948. C                 =  integral from X to infinity of KI(N-1,t)dt
  9949. C                     for X .ge. 0 and N = 1,2,...
  9950. C   ____________________________________________________________________
  9951. C      BSKIN computes sequences of Bickley functions (repeated integrals
  9952. C      of the K0 Bessel function); i.e. for fixed X and N and K=1,...,
  9953. C      BSKIN computes the M-member sequence
  9954. C
  9955. C                     Y(K) =        KI(N+K-1,X) for KODE=1
  9956. C      or
  9957. C                     Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2,
  9958. C
  9959. C      for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously).
  9960. C
  9961. C      INPUT
  9962. C        X      - Argument, X .ge. 0.0E0
  9963. C        N      - Order of first member of the sequence N .ge. 0
  9964. C        KODE   - Selection parameter
  9965. C                 KODE = 1 returns Y(K)=       KI(N+K-1,X), K=1,M
  9966. C                      = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M
  9967. C        M      - Number of members in the sequence, M.ge.1
  9968. C
  9969. C      OUTPUT
  9970. C        Y      - A vector of dimension at least M containing the
  9971. C                 sequence selected by KODE.
  9972. C        NZ     - Underflow flag
  9973. C                 NZ = 0 means computation completed
  9974. C                    = M means an exponential underflow occurred on
  9975. C                        KODE=1.  Y(K)=0.0E0, K=1,...,M is returned
  9976. C        IERR   - Error flag
  9977. C                 IERR = 0, Normal return, computation completed.
  9978. C                      = 1, Input error,   no computation.
  9979. C                      = 2, Error,         no computation.  The
  9980. C                           termination condition was not met.
  9981. C
  9982. C      The nominal computational accuracy is the maximum of unit
  9983. C      roundoff (=R1MACH(4)) and 1.0e-18 since critical constants
  9984. C      are given to only 18 digits.
  9985. C
  9986. C      DBSKIN is the double precision version of BSKIN.
  9987. C
  9988. C *Long Description:
  9989. C
  9990. C         Numerical recurrence on
  9991. C
  9992. C      (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X)
  9993. C
  9994. C         is stable where recurrence is carried forward or backward
  9995. C         away from INT(X+0.5).  The power series for indices 0,1 and 2
  9996. C         on 0.le.X.le. 2 starts a stable recurrence for indices
  9997. C         greater than 2.  If N is sufficiently large (N.gt.NLIM), the
  9998. C         uniform asymptotic expansion for N to INFINITY is more
  9999. C         economical.  On X.gt.2 the recursion is started by evaluating
  10000. C         the uniform expansion for the three members whose indices are
  10001. C         closest to INT(X+0.5) within the set N,...,N+M-1.  Forward
  10002. C         recurrence, backward recurrence or both, complete the
  10003. C         sequence depending on the relation of INT(X+0.5) to the
  10004. C         indices N,...,N+M-1.
  10005. C
  10006. C***REFERENCES  D. E. Amos, Uniform asymptotic expansions for
  10007. C                 exponential integrals E(N,X) and Bickley functions
  10008. C                 KI(N,X), ACM Transactions on Mathematical Software,
  10009. C                 1983.
  10010. C               D. E. Amos, A portable Fortran subroutine for the
  10011. C                 Bickley functions KI(N,X), Algorithm 609, ACM
  10012. C                 Transactions on Mathematical Software, 1983.
  10013. C***ROUTINES CALLED  BKIAS, BKISR, EXINT, GAMRN, I1MACH, R1MACH
  10014. C***REVISION HISTORY  (YYMMDD)
  10015. C   820601  DATE WRITTEN
  10016. C   890531  Changed all specific intrinsics to generic.  (WRB)
  10017. C   891009  Removed unreferenced statement label.  (WRB)
  10018. C   891009  REVISION DATE from Version 3.2
  10019. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10020. C   920501  Reformatted the REFERENCES section.  (WRB)
  10021. C***END PROLOGUE  BSKIN
  10022.       INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M,
  10023.      * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ
  10024.       INTEGER I1MACH
  10025.       REAL A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, T1, T2, W, X,
  10026.      * XLIM, XNLIM, XP, Y, YS, YSS
  10027.       REAL GAMRN, R1MACH
  10028.       DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*)
  10029.       SAVE A, HRTPI
  10030. C-----------------------------------------------------------------------
  10031. C             COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS
  10032. C-----------------------------------------------------------------------
  10033.       DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10),
  10034.      * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19),
  10035.      * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000E+00,
  10036.      * 5.00000000000000000E-01,3.75000000000000000E-01,
  10037.      * 3.12500000000000000E-01,2.73437500000000000E-01,
  10038.      * 2.46093750000000000E-01,2.25585937500000000E-01,
  10039.      * 2.09472656250000000E-01,1.96380615234375000E-01,
  10040.      * 1.85470581054687500E-01,1.76197052001953125E-01,
  10041.      * 1.68188095092773438E-01,1.61180257797241211E-01,
  10042.      * 1.54981017112731934E-01,1.49445980787277222E-01,
  10043.      * 1.44464448094367981E-01,1.39949934091418982E-01,
  10044.      * 1.35833759559318423E-01,1.32060599571559578E-01,
  10045.      * 1.28585320635465905E-01,1.25370687619579257E-01,
  10046.      * 1.22385671247684513E-01,1.19604178719328047E-01,
  10047.      * 1.17004087877603524E-01/
  10048.       DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32),
  10049.      * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41),
  10050.      * A(42), A(43), A(44), A(45), A(46), A(47), A(48)
  10051.      * /1.14566502713486784E-01,1.12275172659217048E-01,
  10052.      * 1.10116034723462874E-01,1.08076848895250599E-01,
  10053.      * 1.06146905164978267E-01,1.04316786110409676E-01,
  10054.      * 1.02578173008569515E-01,1.00923686347140974E-01,
  10055.      * 9.93467537479668965E-02,9.78414999033007314E-02,
  10056.      * 9.64026543164874854E-02,9.50254735405376642E-02,
  10057.      * 9.37056752969190855E-02,9.24393823875012600E-02,
  10058.      * 9.12230747245078224E-02,9.00535481254756708E-02,
  10059.      * 8.89278787739072249E-02,8.78433924473961612E-02,
  10060.      * 8.67976377754033498E-02,8.57883629175498224E-02,
  10061.      * 8.48134951571231199E-02,8.38711229887106408E-02,
  10062.      * 8.29594803475290034E-02,8.20769326842574183E-02/
  10063.       DATA A(49), A(50) /8.12219646354630702E-02,8.03931690779583449E-02
  10064.      * /
  10065. C-----------------------------------------------------------------------
  10066. C             SQRT(PI)/2
  10067. C-----------------------------------------------------------------------
  10068.       DATA HRTPI /8.86226925452758014E-01/
  10069. C
  10070. C***FIRST EXECUTABLE STATEMENT  BSKIN
  10071.       IERR = 0
  10072.       NZ=0
  10073.       IF (X.LT.0.0E0) IERR=1
  10074.       IF (N.LT.0) IERR=1
  10075.       IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
  10076.       IF (M.LT.1) IERR=1
  10077.       IF (X.EQ.0.0E0 .AND. N.EQ.0) IERR=1
  10078.       IF (IERR.NE.0) RETURN
  10079.       IF (X.EQ.0.0E0) GO TO 300
  10080.       I1M = -I1MACH(12)
  10081.       T1 = 2.3026E0*R1MACH(5)*I1M
  10082.       XLIM = T1 - 3.228086E0
  10083.       T2 = T1 + N + M - 1
  10084.       IF (T2.GT.1000.0E0) XLIM = T1 - 0.5E0*(LOG(T2)-0.451583E0)
  10085.       IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320
  10086.       TOL = MAX(R1MACH(4),1.0E-18)
  10087.       I1M = I1MACH(11)
  10088. C-----------------------------------------------------------------------
  10089. C     LN(NLIM) = 0.125*LN(EPS),   NLIM = 2*KTRMS+N
  10090. C-----------------------------------------------------------------------
  10091.       XNLIM = 0.287823E0*(I1M-1)*R1MACH(5)
  10092.       ENLIM = EXP(XNLIM)
  10093.       NLIM = INT(ENLIM) + 2
  10094.       NLIM = MIN(100,NLIM)
  10095.       NLIM = MAX(20,NLIM)
  10096.       M3 = MIN(M,3)
  10097.       NL = N + M - 1
  10098.       IF (X.GT.2.0E0) GO TO 130
  10099.       IF (N.GT.NLIM) GO TO 280
  10100. C-----------------------------------------------------------------------
  10101. C     COMPUTATION BY SERIES FOR 0.LE.X.LE.2
  10102. C-----------------------------------------------------------------------
  10103.       NFLG = 0
  10104.       NN = N
  10105.       IF (NL.LE.2) GO TO 60
  10106.       M3 = 3
  10107.       NN = 0
  10108.       NFLG = 1
  10109.    60 CONTINUE
  10110.       XP = 1.0E0
  10111.       IF (KODE.EQ.2) XP = EXP(X)
  10112.       DO 80 I=1,M3
  10113.         CALL BKISR(X, NN, W, IERR)
  10114.       IF(IERR.NE.0) RETURN
  10115.         W = W*XP
  10116.         IF (NN.LT.N) GO TO 70
  10117.         KK = NN - N + 1
  10118.         Y(KK) = W
  10119.    70   CONTINUE
  10120.         YS(I) = W
  10121.         NN = NN + 1
  10122.    80 CONTINUE
  10123.       IF (NFLG.EQ.0) RETURN
  10124.       NS = NN
  10125.       XP = 1.0E0
  10126.    90 CONTINUE
  10127. C-----------------------------------------------------------------------
  10128. C     FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2
  10129. C-----------------------------------------------------------------------
  10130.       FN = NS - 1
  10131.       IL = NL - NS + 1
  10132.       IF (IL.LE.0) RETURN
  10133.       DO 110 I=1,IL
  10134.         T1 = YS(2)
  10135.         T2 = YS(3)
  10136.         YS(3) = (X*(YS(1)-YS(3))+(FN-1.0E0)*YS(2))/FN
  10137.         YS(2) = T2
  10138.         YS(1) = T1
  10139.         FN = FN + 1.0E0
  10140.         IF (NS.LT.N) GO TO 100
  10141.         KK = NS - N + 1
  10142.         Y(KK) = YS(3)*XP
  10143.   100   CONTINUE
  10144.         NS = NS + 1
  10145.   110 CONTINUE
  10146.       RETURN
  10147. C-----------------------------------------------------------------------
  10148. C     COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2
  10149. C-----------------------------------------------------------------------
  10150.   130 CONTINUE
  10151.       W = X + 0.5E0
  10152.       NT = INT(W)
  10153.       IF (NL.GT.NT) GO TO 270
  10154. C-----------------------------------------------------------------------
  10155. C     CASE NL.LE.NT, ICASE=0
  10156. C-----------------------------------------------------------------------
  10157.       ICASE = 0
  10158.       NN = NL
  10159.       NFLG = MIN(M-M3,1)
  10160.   140 CONTINUE
  10161.       KK = (NLIM-NN)/2
  10162.       KTRMS = MAX(0,KK)
  10163.       NS = NN + 1
  10164.       NP = NN - M3 + 1
  10165.       XP = 1.0E0
  10166.       IF (KODE.EQ.1) XP = EXP(-X)
  10167.       DO 150 I=1,M3
  10168.         KK = I
  10169.         CALL BKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR)
  10170.       IF(IERR.NE.0) RETURN
  10171.         YS(I) = W
  10172.         NP = NP + 1
  10173.   150 CONTINUE
  10174. C-----------------------------------------------------------------------
  10175. C     SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD
  10176. C-----------------------------------------------------------------------
  10177.       IF (KTRMS.EQ.0) GO TO 160
  10178.       NE = KTRMS + KTRMS + 1
  10179.       NP = NN - M3 + 2
  10180.       CALL EXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR)
  10181.       IF(NZ.NE.0) GO TO 320
  10182.       IF(IERR.EQ.2) RETURN
  10183.   160 CONTINUE
  10184.       DO 190 I=1,M3
  10185.         SS = 0.0E0
  10186.         IF (KTRMS.EQ.0) GO TO 180
  10187.         KK = I + KTRMS + KTRMS - 2
  10188.         IL = KTRMS
  10189.         DO 170 K=1,KTRMS
  10190.           SS = SS + A(IL)*EXI(KK)
  10191.           KK = KK - 2
  10192.           IL = IL - 1
  10193.   170   CONTINUE
  10194.   180   CONTINUE
  10195.         YS(I) = YS(I) + SS
  10196.   190 CONTINUE
  10197.       IF (ICASE.EQ.1) GO TO 200
  10198.       IF (NFLG.NE.0) GO TO 220
  10199.   200 CONTINUE
  10200.       DO 210 I=1,M3
  10201.         Y(I) = YS(I)*XP
  10202.   210 CONTINUE
  10203.       IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90
  10204.       RETURN
  10205.   220 CONTINUE
  10206. C-----------------------------------------------------------------------
  10207. C     BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2
  10208. C-----------------------------------------------------------------------
  10209.       KK = NN - N + 1
  10210.       K = M3
  10211.       DO 230 I=1,M3
  10212.         Y(KK) = YS(K)*XP
  10213.         YSS(I) = YS(I)
  10214.         KK = KK - 1
  10215.         K = K - 1
  10216.   230 CONTINUE
  10217.       IL = KK
  10218.       IF (IL.LE.0) GO TO 250
  10219.       FN = NN - 3
  10220.       DO 240 I=1,IL
  10221.         T1 = YS(2)
  10222.         T2 = YS(1)
  10223.         YS(1) = YS(2) + ((FN+2.0E0)*YS(3)-(FN+1.0E0)*YS(1))/X
  10224.         YS(2) = T2
  10225.         YS(3) = T1
  10226.         Y(KK) = YS(1)*XP
  10227.         KK = KK - 1
  10228.         FN = FN - 1.0E0
  10229.   240 CONTINUE
  10230.   250 CONTINUE
  10231.       IF (ICASE.NE.2) RETURN
  10232.       DO 260 I=1,M3
  10233.         YS(I) = YSS(I)
  10234.   260 CONTINUE
  10235.       GO TO 90
  10236.   270 CONTINUE
  10237.       IF (N.LT.NT) GO TO 290
  10238. C-----------------------------------------------------------------------
  10239. C     ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION
  10240. C-----------------------------------------------------------------------
  10241.   280 CONTINUE
  10242.       NN = N + M3 - 1
  10243.       NFLG = MIN(M-M3,1)
  10244.       ICASE = 1
  10245.       GO TO 140
  10246. C-----------------------------------------------------------------------
  10247. C     ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION
  10248. C-----------------------------------------------------------------------
  10249.   290 CONTINUE
  10250.       NN = NT + 1
  10251.       NFLG = MIN(M-M3,1)
  10252.       ICASE = 2
  10253.       GO TO 140
  10254. C-----------------------------------------------------------------------
  10255. C     X=0 CASE
  10256. C-----------------------------------------------------------------------
  10257.   300 CONTINUE
  10258.       FN = N
  10259.       HN = 0.5E0*FN
  10260.       GR = GAMRN(HN)
  10261.       Y(1) = HRTPI*GR
  10262.       IF (M.EQ.1) RETURN
  10263.       Y(2) = HRTPI/(HN*GR)
  10264.       IF (M.EQ.2) RETURN
  10265.       DO 310 K=3,M
  10266.         Y(K) = FN*Y(K-2)/(FN+1.0E0)
  10267.         FN = FN + 1.0E0
  10268.   310 CONTINUE
  10269.       RETURN
  10270. C-----------------------------------------------------------------------
  10271. C     UNDERFLOW ON KODE=1, X.GT.XLIM
  10272. C-----------------------------------------------------------------------
  10273.   320 CONTINUE
  10274.       NZ=M
  10275.       DO 330 I=1,M
  10276.         Y(I) = 0.0E0
  10277.   330 CONTINUE
  10278.       RETURN
  10279.       END
  10280. *DECK BSPDOC
  10281.       SUBROUTINE BSPDOC
  10282. C***BEGIN PROLOGUE  BSPDOC
  10283. C***PURPOSE  Documentation for BSPLINE, a package of subprograms for
  10284. C            working with piecewise polynomial functions
  10285. C            in B-representation.
  10286. C***LIBRARY   SLATEC
  10287. C***CATEGORY  E, E1A, K, Z
  10288. C***TYPE      ALL (BSPDOC-A)
  10289. C***KEYWORDS  B-SPLINE, DOCUMENTATION, SPLINES
  10290. C***AUTHOR  Amos, D. E., (SNLA)
  10291. C***DESCRIPTION
  10292. C
  10293. C     Abstract
  10294. C         BSPDOC is a non-executable, B-spline documentary routine.
  10295. C         The narrative describes a B-spline and the routines
  10296. C         necessary to manipulate B-splines at a fairly high level.
  10297. C         The basic package described herein is that of reference
  10298. C         5 with names altered to prevent duplication and conflicts
  10299. C         with routines from reference 3.  The call lists used here
  10300. C         are also different.  Work vectors were added to ensure
  10301. C         portability and proper execution in an overlay environ-
  10302. C         ment.  These work arrays can be used for other purposes
  10303. C         except as noted in BSPVN.  While most of the original
  10304. C         routines in reference 5 were restricted to orders 20
  10305. C         or less, this restriction was removed from all routines
  10306. C         except the quadrature routine BSQAD.  (See the section
  10307. C         below on differentiation and integration for details.)
  10308. C
  10309. C         The subroutines referenced below are single precision
  10310. C         routines.  Corresponding double precision versions are also
  10311. C         part of the package, and these are referenced by prefixing
  10312. C         a D in front of the single precision name.  For example,
  10313. C         BVALU and DBVALU are the single and double precision
  10314. C         versions for evaluating a B-spline or any of its deriva-
  10315. C         tives in the B-representation.
  10316. C
  10317. C                ****Description of B-Splines****
  10318. C
  10319. C     A collection of polynomials of fixed degree K-1 defined on a
  10320. C     subdivision (X(I),X(I+1)), I=1,...,M-1 of (A,B) with X(1)=A,
  10321. C     X(M)=B is called a B-spline of order K.  If the spline has K-2
  10322. C     continuous derivatives on (A,B), then the B-spline is simply
  10323. C     called a spline of order K.  Each of the M-1 polynomial pieces
  10324. C     has K coefficients, making a total of K(M-1) parameters.  This
  10325. C     B-spline and its derivatives have M-2 jumps at the subdivision
  10326. C     points X(I), I=2,...,M-1.  Continuity requirements at these
  10327. C     subdivision points add constraints and reduce the number of free
  10328. C     parameters.  If a B-spline is continuous at each of the M-2 sub-
  10329. C     division points, there are K(M-1)-(M-2) free parameters; if in
  10330. C     addition the B-spline has continuous first derivatives, there
  10331. C     are K(M-1)-2(M-2) free parameters, etc., until we get to a
  10332. C     spline where we have K(M-1)-(K-1)(M-2) = M+K-2 free parameters.
  10333. C     Thus, the principle is that increasing the continuity of
  10334. C     derivatives decreases the number of free parameters and
  10335. C     conversely.
  10336. C
  10337. C     The points at which the polynomials are tied together by the
  10338. C     continuity conditions are called knots.  If two knots are
  10339. C     allowed to come together at some X(I), then we say that we
  10340. C     have a knot of multiplicity 2 there, and the knot values are
  10341. C     the X(I) value.  If we reverse the procedure of the first
  10342. C     paragraph, we find that adding a knot to increase multiplicity
  10343. C     increases the number of free parameters and, according to the
  10344. C     principle above, we thereby introduce a discontinuity in what
  10345. C     was the highest continuous derivative at that knot.  Thus, the
  10346. C     number of free parameters is N = NU+K-2 where NU is the sum
  10347. C     of multiplicities at the X(I) values with X(1) and X(M) of
  10348. C     multiplicity 1 (NU = M if all knots are simple, i.e., for a
  10349. C     spline, all knots have multiplicity 1.)  Each knot can have a
  10350. C     multiplicity of at most K.  A B-spline is commonly written in the
  10351. C     B-representation
  10352. C
  10353. C               Y(X) = sum( A(I)*B(I,X), I=1 , N)
  10354. C
  10355. C     to show the explicit dependence of the spline on the free
  10356. C     parameters or coefficients A(I)=BCOEF(I) and basis functions
  10357. C     B(I,X).  These basis functions are themselves special B-splines
  10358. C     which are zero except on (at most) K adjoining intervals where
  10359. C     each B(I,X) is positive and, in most cases, hat or bell-
  10360. C     shaped.  In order for the nonzero part of B(1,X) to be a spline
  10361. C     covering (X(1),X(2)), it is necessary to put K-1 knots to the
  10362. C     left of A and similarly for B(N,X) to the right of B.  Thus, the
  10363. C     total number of knots for this representation is NU+2K-2 = N+K.
  10364. C     These knots are carried in an array T(*) dimensioned by at least
  10365. C     N+K.  From the construction, A=T(K) and B=T(N+1) and the spline is
  10366. C     defined on T(K).LE.X.LE.T(N+1).  The nonzero part of each basis
  10367. C     function lies in the  Interval (T(I),T(I+K)).  In many problems
  10368. C     where extrapolation beyond A or B is not anticipated, it is common
  10369. C     practice to set T(1)=T(2)=...=T(K)=A and T(N+1)=T(N+2)=...=
  10370. C     T(N+K)=B.  In summary, since T(K) and T(N+1) as well as
  10371. C     interior knots can have multiplicity K, the number of free
  10372. C     parameters N = sum of multiplicities - K.  The fact that each
  10373. C     B(I,X) function is nonzero over at most K intervals means that
  10374. C     for a given X value, there are at most K nonzero terms of the
  10375. C     sum.  This leads to banded matrices in linear algebra problems,
  10376. C     and references 3 and 6 take advantage of this in con-
  10377. C     structing higher level routines to achieve speed and avoid
  10378. C     ill-conditioning.
  10379. C
  10380. C                     ****Basic Routines****
  10381. C
  10382. C     The basic routines which most casual users will need are those
  10383. C     concerned with direct evaluation of splines or B-splines.
  10384. C     Since the B-representation, denoted by (T,BCOEF,N,K), is
  10385. C     preferred because of numerical stability, the knots T(*), the
  10386. C     B-spline coefficients BCOEF(*), the number of coefficients N,
  10387. C     and the order K of the polynomial pieces (of degree K-1) are
  10388. C     usually given.  While the knot array runs from T(1) to T(N+K),
  10389. C     the B-spline is normally defined on the interval T(K).LE.X.LE.
  10390. C     T(N+1).  To evaluate the B-spline or any of its derivatives
  10391. C     on this interval, one can use
  10392. C
  10393. C                  Y = BVALU(T,BCOEF,N,K,ID,X,INBV,WORK)
  10394. C
  10395. C     where ID is an integer for the ID-th derivative, 0.LE.ID.LE.K-1.
  10396. C     ID=0 gives the zero-th derivative or B-spline value at X.
  10397. C     If X.LT.T(K) or X.GT.T(N+1), whether by mistake or the result
  10398. C     of round off accumulation in incrementing X, BVALU gives a
  10399. C     diagnostic.  INBV is an initialization parameter which is set
  10400. C     to 1 on the first call.  Distinct splines require distinct
  10401. C     INBV parameters.  WORK is a scratch vector of length at least
  10402. C     3*K.
  10403. C
  10404. C     When more conventional communication is needed for publication,
  10405. C     physical interpretation, etc., the B-spline coefficients can
  10406. C     be converted to piecewise polynomial (PP) coefficients.  Thus,
  10407. C     the breakpoints (distinct knots) XI(*), the number of
  10408. C     polynomial pieces LXI, and the (right) derivatives C(*,J) at
  10409. C     each breakpoint XI(J) are needed to define the Taylor
  10410. C     expansion to the right of XI(J) on each interval XI(J).LE.
  10411. C     X.LT.XI(J+1), J=1,LXI where XI(1)=A and XI(LXI+1)=B.
  10412. C     These are obtained from the (T,BCOEF,N,K) representation by
  10413. C
  10414. C                CALL BSPPP(T,BCOEF,N,K,LDC,C,XI,LXI,WORK)
  10415. C
  10416. C     where LDC.GE.K is the leading dimension of the matrix C and
  10417. C     WORK is a scratch vector of length at least K*(N+3).
  10418. C     Then the PP-representation (C,XI,LXI,K) of Y(X), denoted
  10419. C     by Y(J,X) on each interval XI(J).LE.X.LT.XI(J+1), is
  10420. C
  10421. C     Y(J,X) = sum( C(I,J)*((X-XI(J))**(I-1))/factorial(I-1), I=1,K)
  10422. C
  10423. C     for J=1,...,LXI.  One must view this conversion from the B-
  10424. C     to the PP-representation with some skepticism because the
  10425. C     conversion may lose significant digits when the B-spline
  10426. C     varies in an almost discontinuous fashion.  To evaluate
  10427. C     the B-spline or any of its derivatives using the PP-
  10428. C     representation, one uses
  10429. C
  10430. C                Y = PPVAL(LDC,C,XI,LXI,K,ID,X,INPPV)
  10431. C
  10432. C     where ID and INPPV have the same meaning and usage as ID and
  10433. C     INBV in BVALU.
  10434. C
  10435. C     To determine to what extent the conversion process loses
  10436. C     digits, compute the relative error ABS((Y1-Y2)/Y2) over
  10437. C     the X interval with Y1 from PPVAL and Y2 from BVALU.  A
  10438. C     major reason for considering PPVAL is that evaluation is
  10439. C     much faster than that from BVALU.
  10440. C
  10441. C     Recall that when multiple knots are encountered, jump type
  10442. C     discontinuities in the B-spline or its derivatives occur
  10443. C     at these knots, and we need to know that BVALU and PPVAL
  10444. C     return right limiting values at these knots except at
  10445. C     X=B where left limiting values are returned.  These values
  10446. C     are used for the Taylor expansions about left end points of
  10447. C     breakpoint intervals.  That is, the derivatives C(*,J) are
  10448. C     right derivatives.  Note also that a computed X value which,
  10449. C     mathematically, would be a knot value may differ from the knot
  10450. C     by a round off error.  When this happens in evaluating a dis-
  10451. C     continuous B-spline or some discontinuous derivative, the
  10452. C     value at the knot and the value at X can be radically
  10453. C     different.  In this case, setting X to a T or XI value makes
  10454. C     the computation precise.  For left limiting values at knots
  10455. C     other than X=B, see the prologues to BVALU and other
  10456. C     routines.
  10457. C
  10458. C                     ****Interpolation****
  10459. C
  10460. C     BINTK is used to generate B-spline parameters (T,BCOEF,N,K)
  10461. C     which will interpolate the data by calls to BVALU.  A similar
  10462. C     interpolation can also be done for cubic splines using BINT4
  10463. C     or the code in reference 7.  If the PP-representation is given,
  10464. C     one can evaluate this representation at an appropriate number of
  10465. C     abscissas to create data then use BINTK or BINT4 to generate
  10466. C     the B-representation.
  10467. C
  10468. C               ****Differentiation and Integration****
  10469. C
  10470. C     Derivatives of B-splines are obtained from BVALU or PPVAL.
  10471. C     Integrals are obtained from BSQAD using the B-representation
  10472. C     (T,BCOEF,N,K) and PPQAD using the PP-representation (C,XI,LXI,
  10473. C     K).  More complicated integrals involving the product of a
  10474. C     of a function F and some derivative of a B-spline can be
  10475. C     evaluated with BFQAD or PFQAD using the B- or PP- represen-
  10476. C     tations respectively.  All quadrature routines, except for PPQAD,
  10477. C     are limited in accuracy to 18 digits or working precision,
  10478. C     whichever is smaller.  PPQAD is limited to working precision
  10479. C     only.  In addition, the order K for BSQAD is limited to 20 or
  10480. C     less.  If orders greater than 20 are required, use BFQAD with
  10481. C     F(X) = 1.
  10482. C
  10483. C                      ****Extrapolation****
  10484. C
  10485. C     Extrapolation outside the interval (A,B) can be accomplished
  10486. C     easily by the PP-representation using PPVAL.  However,
  10487. C     caution should be exercised, especially when several knots
  10488. C     are located at A or B or when the extrapolation is carried
  10489. C     significantly beyond A or B.  On the other hand, direct
  10490. C     evaluation with BVALU outside A=T(K).LE.X.LE.T(N+1)=B
  10491. C     produces an error message, and some manipulation of the knots
  10492. C     and coefficients are needed to extrapolate with BVALU.  This
  10493. C     process is described in reference 6.
  10494. C
  10495. C                ****Curve Fitting and Smoothing****
  10496. C
  10497. C     Unless one has many accurate data points, direct inter-
  10498. C     polation is not recommended for summarizing data.  The
  10499. C     results are often not in accordance with intuition since the
  10500. C     fitted curve tends to oscillate through the set of points.
  10501. C     Monotone splines (reference 7) can help curb this undulating
  10502. C     tendency but constrained least squares is more likely to give an
  10503. C     acceptable fit with fewer parameters.  Subroutine FC, des-
  10504. C     cribed in reference 6, is recommended for this purpose.  The
  10505. C     output from this fitting process is the B-representation.
  10506. C
  10507. C              **** Routines in the B-Spline Package ****
  10508. C
  10509. C                      Single Precision Routines
  10510. C
  10511. C         The subroutines referenced below are SINGLE PRECISION
  10512. C         routines. Corresponding DOUBLE PRECISION versions are also
  10513. C         part of the package and these are referenced by prefixing
  10514. C         a D in front of the single precision name. For example,
  10515. C         BVALU and DBVALU are the SINGLE and DOUBLE PRECISION
  10516. C         versions for evaluating a B-spline or any of its deriva-
  10517. C         tives in the B-representation.
  10518. C
  10519. C     BINT4 - interpolates with splines of order 4
  10520. C     BINTK - interpolates with splines of order k
  10521. C     BSQAD - integrates the B-representation on subintervals
  10522. C     PPQAD - integrates the PP-representation
  10523. C     BFQAD - integrates the product of a function F and any spline
  10524. C             derivative in the B-representation
  10525. C     PFQAD - integrates the product of a function F and any spline
  10526. C             derivative in the PP-representation
  10527. C     BVALU - evaluates the B-representation or a derivative
  10528. C     PPVAL - evaluates the PP-representation or a derivative
  10529. C     INTRV - gets the largest index of the knot to the left of x
  10530. C     BSPPP - converts from B- to PP-representation
  10531. C     BSPVD - computes nonzero basis functions and derivatives at x
  10532. C     BSPDR - sets up difference array for BSPEV
  10533. C     BSPEV - evaluates the B-representation and derivatives
  10534. C     BSPVN - called by BSPEV, BSPVD, BSPPP and BINTK for function and
  10535. C             derivative evaluations
  10536. C                        Auxiliary Routines
  10537. C
  10538. C       BSGQ8,PPGQ8,BNSLV,BNFAC,XERMSG,DBSGQ8,DPPGQ8,DBNSLV,DBNFAC
  10539. C
  10540. C                    Machine Dependent Routines
  10541. C
  10542. C                      I1MACH, R1MACH, D1MACH
  10543. C
  10544. C***REFERENCES  1. D. E. Amos, Computation with splines and
  10545. C                 B-splines, Report SAND78-1968, Sandia
  10546. C                 Laboratories, March 1979.
  10547. C               2. D. E. Amos, Quadrature subroutines for splines and
  10548. C                 B-splines, Report SAND79-1825, Sandia Laboratories,
  10549. C                 December 1979.
  10550. C               3. Carl de Boor, A Practical Guide to Splines, Applied
  10551. C                 Mathematics Series 27, Springer-Verlag, New York,
  10552. C                 1978.
  10553. C               4. Carl de Boor, On calculating with B-Splines, Journal
  10554. C                 of Approximation Theory 6, (1972), pp. 50-62.
  10555. C               5. Carl de Boor, Package for calculating with B-splines,
  10556. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  10557. C                 pp. 441-472.
  10558. C               6. R. J. Hanson, Constrained least squares curve fitting
  10559. C                 to discrete data using B-splines, a users guide,
  10560. C                 Report SAND78-1291, Sandia Laboratories, December
  10561. C                 1978.
  10562. C               7. F. N. Fritsch and R. E. Carlson, Monotone piecewise
  10563. C                 cubic interpolation, SIAM Journal on Numerical Ana-
  10564. C                 lysis 17, 2 (April 1980), pp. 238-246.
  10565. C***ROUTINES CALLED  (NONE)
  10566. C***REVISION HISTORY  (YYMMDD)
  10567. C   810223  DATE WRITTEN
  10568. C   861211  REVISION DATE from Version 3.2
  10569. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10570. C   900723  PURPOSE section revised.  (WRB)
  10571. C   920501  Reformatted the REFERENCES section.  (WRB)
  10572. C***END PROLOGUE  BSPDOC
  10573. C***FIRST EXECUTABLE STATEMENT  BSPDOC
  10574.       RETURN
  10575.       END
  10576. *DECK BSPDR
  10577.       SUBROUTINE BSPDR (T, A, N, K, NDERIV, AD)
  10578. C***BEGIN PROLOGUE  BSPDR
  10579. C***PURPOSE  Use the B-representation to construct a divided difference
  10580. C            table preparatory to a (right) derivative calculation.
  10581. C***LIBRARY   SLATEC
  10582. C***CATEGORY  E3
  10583. C***TYPE      SINGLE PRECISION (BSPDR-S, DBSPDR-D)
  10584. C***KEYWORDS  B-SPLINE, DATA FITTING, DIFFERENTIATION OF SPLINES,
  10585. C             INTERPOLATION
  10586. C***AUTHOR  Amos, D. E., (SNLA)
  10587. C***DESCRIPTION
  10588. C
  10589. C     Written by Carl de Boor and modified by D. E. Amos
  10590. C
  10591. C     Abstract
  10592. C         BSPDR is the BSPLDR routine of the reference.
  10593. C
  10594. C         BSPDR uses the B-representation (T,A,N,K) to construct a
  10595. C         divided difference table ADIF preparatory to a (right)
  10596. C         derivative calculation in BSPEV.  The lower triangular matrix
  10597. C         ADIF is stored in vector AD by columns.  The arrays are
  10598. C         related by
  10599. C
  10600. C           ADIF(I,J) = AD(I-J+1 + (2*N-J+2)*(J-1)/2)
  10601. C
  10602. C         I = J,N , J = 1,NDERIV .
  10603. C
  10604. C     Description of Arguments
  10605. C         Input
  10606. C          T       - knot vector of length N+K
  10607. C          A       - B-spline coefficient vector of length N
  10608. C          N       - number of B-spline coefficients
  10609. C                    N = sum of knot multiplicities-K
  10610. C          K       - order of the spline, K .GE. 1
  10611. C          NDERIV  - number of derivatives, 1 .LE. NDERIV .LE. K.
  10612. C                    NDERIV=1 gives the zero-th derivative = function
  10613. C                    value
  10614. C
  10615. C         Output
  10616. C          AD      - table of differences in a vector of length
  10617. C                    (2*N-NDERIV+1)*NDERIV/2 for input to BSPEV
  10618. C
  10619. C     Error Conditions
  10620. C         Improper input is a fatal error
  10621. C
  10622. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  10623. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  10624. C                 pp. 441-472.
  10625. C***ROUTINES CALLED  XERMSG
  10626. C***REVISION HISTORY  (YYMMDD)
  10627. C   800901  DATE WRITTEN
  10628. C   890831  Modified array declarations.  (WRB)
  10629. C   890831  REVISION DATE from Version 3.2
  10630. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10631. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  10632. C   900326  Removed duplicate information from DESCRIPTION section.
  10633. C           (WRB)
  10634. C   920501  Reformatted the REFERENCES section.  (WRB)
  10635. C***END PROLOGUE  BSPDR
  10636. C
  10637.       INTEGER I, ID, II, IPKMID, JJ, JM, K, KMID, N, NDERIV
  10638.       REAL A, AD, DIFF, FKMID, T
  10639. C     DIMENSION T(N+K), AD((2*N-NDERIV+1)*NDERIV/2)
  10640.       DIMENSION T(*), A(*), AD(*)
  10641. C***FIRST EXECUTABLE STATEMENT  BSPDR
  10642.       IF(K.LT.1) GO TO 100
  10643.       IF(N.LT.K) GO TO 105
  10644.       IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 110
  10645.       DO 10 I=1,N
  10646.         AD(I) = A(I)
  10647.    10 CONTINUE
  10648.       IF (NDERIV.EQ.1) RETURN
  10649.       KMID = K
  10650.       JJ = N
  10651.       JM = 0
  10652.       DO 30 ID=2,NDERIV
  10653.         KMID = KMID - 1
  10654.         FKMID = KMID
  10655.         II = 1
  10656.         DO 20 I=ID,N
  10657.           IPKMID = I + KMID
  10658.           DIFF = T(IPKMID) - T(I)
  10659.           IF (DIFF.NE.0.0E0) AD(II+JJ) = (AD(II+JM+1)-AD(II+JM))/
  10660.      1     DIFF*FKMID
  10661.           II = II + 1
  10662.    20   CONTINUE
  10663.         JM = JJ
  10664.         JJ = JJ + N - ID + 1
  10665.    30 CONTINUE
  10666.       RETURN
  10667. C
  10668. C
  10669.   100 CONTINUE
  10670.       CALL XERMSG ('SLATEC', 'BSPDR', 'K DOES NOT SATISFY K.GE.1', 2,
  10671.      +   1)
  10672.       RETURN
  10673.   105 CONTINUE
  10674.       CALL XERMSG ('SLATEC', 'BSPDR', 'N DOES NOT SATISFY N.GE.K', 2,
  10675.      +   1)
  10676.       RETURN
  10677.   110 CONTINUE
  10678.       CALL XERMSG ('SLATEC', 'BSPDR',
  10679.      +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
  10680.       RETURN
  10681.       END
  10682. *DECK BSPEV
  10683.       SUBROUTINE BSPEV (T, AD, N, K, NDERIV, X, INEV, SVALUE, WORK)
  10684. C***BEGIN PROLOGUE  BSPEV
  10685. C***PURPOSE  Calculate the value of the spline and its derivatives from
  10686. C            the B-representation.
  10687. C***LIBRARY   SLATEC
  10688. C***CATEGORY  E3, K6
  10689. C***TYPE      SINGLE PRECISION (BSPEV-S, DBSPEV-D)
  10690. C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES
  10691. C***AUTHOR  Amos, D. E., (SNLA)
  10692. C***DESCRIPTION
  10693. C
  10694. C     Written by Carl de Boor and modified by D. E. Amos
  10695. C
  10696. C     Abstract
  10697. C         BSPEV is the BSPLEV routine of the reference.
  10698. C
  10699. C         BSPEV calculates the value of the spline and its derivatives
  10700. C         at X from the B-representation (T,A,N,K) and returns them
  10701. C         in SVALUE(I),I=1,NDERIV, T(K) .LE. X .LE. T(N+1).  AD(I) can
  10702. C         be the B-spline coefficients A(I), I=1,N if NDERIV=1.  Other-
  10703. C         wise AD must be computed before hand by a call to BSPDR (T,A,
  10704. C         N,K,NDERIV,AD).  If X=T(I),I=K,N, right limiting values are
  10705. C         obtained.
  10706. C
  10707. C         To compute left derivatives or left limiting values at a
  10708. C         knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1.
  10709. C
  10710. C         BSPEV calls INTRV, BSPVN
  10711. C
  10712. C     Description of Arguments
  10713. C         Input
  10714. C          T       - knot vector of length N+K
  10715. C          AD      - vector of length (2*N-NDERIV+1)*NDERIV/2 containing
  10716. C                    the difference table from BSPDR.
  10717. C          N       - number of B-spline coefficients
  10718. C                    N = sum of knot multiplicities-K
  10719. C          K       - order of the B-spline, K .GE. 1
  10720. C          NDERIV  - number of derivatives, 1 .LE. NDERIV .LE. K.
  10721. C                    NDERIV=1 gives the zero-th derivative = function
  10722. C                    value
  10723. C          X       - argument, T(K) .LE. X .LE. T(N+1)
  10724. C          INEV    - an initialization parameter which must be set
  10725. C                    to 1 the first time BSPEV is called.
  10726. C
  10727. C         Output
  10728. C          INEV    - INEV contains information for efficient process-
  10729. C                    ing after the initial call and INEV must not
  10730. C                    be changed by the user.  Distinct splines require
  10731. C                    distinct INEV parameters.
  10732. C          SVALUE  - vector of length NDERIV containing the spline
  10733. C                    value in SVALUE(1) and the NDERIV-1 derivatives
  10734. C                    in the remaining components.
  10735. C          WORK    - work vector of length 3*K
  10736. C
  10737. C     Error Conditions
  10738. C         Improper input is a fatal error.
  10739. C
  10740. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  10741. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  10742. C                 pp. 441-472.
  10743. C***ROUTINES CALLED  BSPVN, INTRV, XERMSG
  10744. C***REVISION HISTORY  (YYMMDD)
  10745. C   800901  DATE WRITTEN
  10746. C   890831  Modified array declarations.  (WRB)
  10747. C   890831  REVISION DATE from Version 3.2
  10748. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10749. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  10750. C   900326  Removed duplicate information from DESCRIPTION section.
  10751. C           (WRB)
  10752. C   920501  Reformatted the REFERENCES section.  (WRB)
  10753. C***END PROLOGUE  BSPEV
  10754. C
  10755.       INTEGER I,ID,INEV,IWORK,JJ,K,KP1,KP1MN,L,LEFT,LL,MFLAG,
  10756.      1 N, NDERIV
  10757.       REAL AD, SVALUE, SUM, T, WORK, X
  10758. C     DIMENSION T(N+K)
  10759.       DIMENSION T(*), AD(*), SVALUE(*), WORK(*)
  10760. C***FIRST EXECUTABLE STATEMENT  BSPEV
  10761.       IF(K.LT.1) GO TO 100
  10762.       IF(N.LT.K) GO TO 105
  10763.       IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 115
  10764.       ID = NDERIV
  10765.       CALL INTRV(T, N+1, X, INEV, I, MFLAG)
  10766.       IF (X.LT.T(K)) GO TO 110
  10767.       IF (MFLAG.EQ.0) GO TO 30
  10768.       IF (X.GT.T(I)) GO TO 110
  10769.    20 IF (I.EQ.K) GO TO 120
  10770.       I = I - 1
  10771.       IF (X.EQ.T(I)) GO TO 20
  10772. C
  10773. C *I* HAS BEEN FOUND IN (K,N) SO THAT T(I) .LE. X .LT. T(I+1)
  10774. C     (OR .LE. T(I+1), IF T(I) .LT. T(I+1) = T(N+1) ).
  10775.    30 KP1MN = K + 1 - ID
  10776.       KP1 = K + 1
  10777.       CALL BSPVN(T, KP1MN, K, 1, X, I, WORK(1),WORK(KP1),IWORK)
  10778.       JJ = (N+N-ID+2)*(ID-1)/2
  10779. C     ADIF(LEFTPL,ID) = AD(LEFTPL-ID+1 + (2*N-ID+2)*(ID-1)/2)
  10780. C     LEFTPL = LEFT + L
  10781.    40 LEFT = I - KP1MN
  10782.       SUM = 0.0E0
  10783.       LL = LEFT + JJ + 2 - ID
  10784.       DO 50 L=1,KP1MN
  10785.         SUM = SUM + WORK(L)*AD(LL)
  10786.         LL = LL + 1
  10787.    50 CONTINUE
  10788.       SVALUE(ID) = SUM
  10789.       ID = ID - 1
  10790.       IF (ID.EQ.0) GO TO 60
  10791.       JJ = JJ-(N-ID+1)
  10792.       KP1MN = KP1MN + 1
  10793.       CALL BSPVN(T, KP1MN, K, 2, X, I, WORK(1), WORK(KP1),IWORK)
  10794.       GO TO 40
  10795. C
  10796.    60 RETURN
  10797. C
  10798. C
  10799.   100 CONTINUE
  10800.       CALL XERMSG ('SLATEC', 'BSPEV', 'K DOES NOT SATISFY K.GE.1', 2,
  10801.      +   1)
  10802.       RETURN
  10803.   105 CONTINUE
  10804.       CALL XERMSG ('SLATEC', 'BSPEV', 'N DOES NOT SATISFY N.GE.K', 2,
  10805.      +   1)
  10806.       RETURN
  10807.   110 CONTINUE
  10808.       CALL XERMSG ('SLATEC', 'BSPEV', 'X IS NOT IN T(K).LE.X.LE.T(N+1)'
  10809.      +   , 2, 1)
  10810.       RETURN
  10811.   115 CONTINUE
  10812.       CALL XERMSG ('SLATEC', 'BSPEV',
  10813.      +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
  10814.       RETURN
  10815.   120 CONTINUE
  10816.       CALL XERMSG ('SLATEC', 'BSPEV',
  10817.      +   'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1)
  10818.       RETURN
  10819.       END
  10820. *DECK BSPLVD
  10821.       SUBROUTINE BSPLVD (T, K, X, ILEFT, VNIKX, NDERIV)
  10822. C***BEGIN PROLOGUE  BSPLVD
  10823. C***SUBSIDIARY
  10824. C***PURPOSE  Subsidiary to FC
  10825. C***LIBRARY   SLATEC
  10826. C***TYPE      SINGLE PRECISION (BSPLVD-S, DFSPVD-D)
  10827. C***AUTHOR  (UNKNOWN)
  10828. C***DESCRIPTION
  10829. C
  10830. C Calculates value and deriv.s of all B-splines which do not vanish at X
  10831. C
  10832. C  Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K  with nonzero values of
  10833. C  B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated
  10834. C  calls to BSPLVN
  10835. C
  10836. C***SEE ALSO  FC
  10837. C***ROUTINES CALLED  BSPLVN
  10838. C***REVISION HISTORY  (YYMMDD)
  10839. C   780801  DATE WRITTEN
  10840. C   890531  Changed all specific intrinsics to generic.  (WRB)
  10841. C   890831  Modified array declarations.  (WRB)
  10842. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10843. C   900328  Added TYPE section.  (WRB)
  10844. C***END PROLOGUE  BSPLVD
  10845.       DIMENSION T(*),VNIKX(K,*)
  10846.       DIMENSION A(20,20)
  10847. C***FIRST EXECUTABLE STATEMENT  BSPLVD
  10848.       CALL BSPLVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV))
  10849.       IF (NDERIV .LE. 1)               GO TO 99
  10850.       IDERIV = NDERIV
  10851.       DO 15 I=2,NDERIV
  10852.          IDERVM = IDERIV-1
  10853.          DO 11 J=IDERIV,K
  10854.    11       VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV)
  10855.          IDERIV = IDERVM
  10856.          CALL BSPLVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV))
  10857.    15    CONTINUE
  10858. C
  10859.       DO 20 I=1,K
  10860.          DO 19 J=1,K
  10861.    19       A(I,J) = 0.
  10862.    20    A(I,I) = 1.
  10863.       KMD = K
  10864.       DO 40 M=2,NDERIV
  10865.          KMD = KMD-1
  10866.          FKMD = KMD
  10867.          I = ILEFT
  10868.          J = K
  10869.    21       JM1 = J-1
  10870.             IPKMD = I + KMD
  10871.             DIFF = T(IPKMD) - T(I)
  10872.             IF (JM1 .EQ. 0)            GO TO 26
  10873.             IF (DIFF .EQ. 0.)          GO TO 25
  10874.             DO 24 L=1,J
  10875.    24          A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD
  10876.    25       J = JM1
  10877.             I = I - 1
  10878.                                        GO TO 21
  10879.    26    IF (DIFF .EQ. 0.)             GO TO 30
  10880.          A(1,1) = A(1,1)/DIFF*FKMD
  10881. C
  10882.    30    DO 40 I=1,K
  10883.             V = 0.
  10884.             JLOW = MAX(I,M)
  10885.             DO 35 J=JLOW,K
  10886.    35          V = A(I,J)*VNIKX(J,M) + V
  10887.    40       VNIKX(I,M) = V
  10888.    99                                  RETURN
  10889.       END
  10890. *DECK BSPLVN
  10891.       SUBROUTINE BSPLVN (T, JHIGH, INDEX, X, ILEFT, VNIKX)
  10892. C***BEGIN PROLOGUE  BSPLVN
  10893. C***SUBSIDIARY
  10894. C***PURPOSE  Subsidiary to FC
  10895. C***LIBRARY   SLATEC
  10896. C***TYPE      SINGLE PRECISION (BSPLVN-S, DFSPVN-D)
  10897. C***AUTHOR  (UNKNOWN)
  10898. C***DESCRIPTION
  10899. C
  10900. C Calculates the value of all possibly nonzero B-splines at *X* of
  10901. C  order MAX(JHIGH,(J+1)(INDEX-1)) on *T*.
  10902. C
  10903. C***SEE ALSO  FC
  10904. C***ROUTINES CALLED  (NONE)
  10905. C***REVISION HISTORY  (YYMMDD)
  10906. C   780801  DATE WRITTEN
  10907. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10908. C   900328  Added TYPE section.  (WRB)
  10909. C***END PROLOGUE  BSPLVN
  10910.       DIMENSION T(*),VNIKX(*)
  10911.       DIMENSION DELTAM(20),DELTAP(20)
  10912.       SAVE J, DELTAM, DELTAP
  10913.       DATA J/1/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*0./
  10914. C***FIRST EXECUTABLE STATEMENT  BSPLVN
  10915.                                        GO TO (10,20),INDEX
  10916.    10 J = 1
  10917.       VNIKX(1) = 1.
  10918.       IF (J .GE. JHIGH)                GO TO 99
  10919. C
  10920.    20    IPJ = ILEFT+J
  10921.          DELTAP(J) = T(IPJ) - X
  10922.          IMJP1 = ILEFT-J+1
  10923.          DELTAM(J) = X - T(IMJP1)
  10924.          VMPREV = 0.
  10925.          JP1 = J+1
  10926.          DO 26 L=1,J
  10927.             JP1ML = JP1-L
  10928.             VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML))
  10929.             VNIKX(L) = VM*DELTAP(L) + VMPREV
  10930.    26       VMPREV = VM*DELTAM(JP1ML)
  10931.          VNIKX(JP1) = VMPREV
  10932.          J = JP1
  10933.          IF (J .LT. JHIGH)             GO TO 20
  10934. C
  10935.    99                                  RETURN
  10936.       END
  10937. *DECK BSPPP
  10938.       SUBROUTINE BSPPP (T, A, N, K, LDC, C, XI, LXI, WORK)
  10939. C***BEGIN PROLOGUE  BSPPP
  10940. C***PURPOSE  Convert the B-representation of a B-spline to the piecewise
  10941. C            polynomial (PP) form.
  10942. C***LIBRARY   SLATEC
  10943. C***CATEGORY  E3, K6
  10944. C***TYPE      SINGLE PRECISION (BSPPP-S, DBSPPP-D)
  10945. C***KEYWORDS  B-SPLINE, PIECEWISE POLYNOMIAL
  10946. C***AUTHOR  Amos, D. E., (SNLA)
  10947. C***DESCRIPTION
  10948. C
  10949. C     Written by Carl de Boor and modified by D. E. Amos
  10950. C
  10951. C     Abstract
  10952. C         BSPPP is the BSPLPP routine of the reference.
  10953. C
  10954. C         BSPPP converts the B-representation (T,A,N,K) to the
  10955. C         piecewise polynomial (PP) form (C,XI,LXI,K) for use with
  10956. C         PPVAL.  Here XI(*), the break point array of length LXI, is
  10957. C         the knot array T(*) with multiplicities removed.  The columns
  10958. C         of the matrix C(I,J) contain the right Taylor derivatives
  10959. C         for the polynomial expansion about XI(J) for the intervals
  10960. C         XI(J) .LE. X .LE. XI(J+1), I=1,K, J=1,LXI.  Function PPVAL
  10961. C         makes this evaluation at a specified point X in
  10962. C         XI(1) .LE. X .LE. XI(LXI(1) .LE. X .LE. XI+1)
  10963. C
  10964. C     Description of Arguments
  10965. C         Input
  10966. C          T       - knot vector of length N+K
  10967. C          A       - B-spline coefficient vector of length N
  10968. C          N       - number of B-spline coefficients
  10969. C                    N = sum of knot multiplicities-K
  10970. C          K       - order of the B-spline, K .GE. 1
  10971. C          LDC     - leading dimension of C, LDC .GE. K
  10972. C
  10973. C         Output
  10974. C          C       - matrix of dimension at least (K,LXI) containing
  10975. C                    right derivatives at break points
  10976. C          XI      - XI break point vector of length LXI+1
  10977. C          LXI     - number of break points, LXI .LE. N-K+1
  10978. C          WORK    - work vector of length K*(N+3)
  10979. C
  10980. C     Error Conditions
  10981. C         Improper input is a fatal error
  10982. C
  10983. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  10984. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  10985. C                 pp. 441-472.
  10986. C***ROUTINES CALLED  BSPDR, BSPEV, XERMSG
  10987. C***REVISION HISTORY  (YYMMDD)
  10988. C   800901  DATE WRITTEN
  10989. C   890831  Modified array declarations.  (WRB)
  10990. C   890831  REVISION DATE from Version 3.2
  10991. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  10992. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  10993. C   900326  Removed duplicate information from DESCRIPTION section.
  10994. C           (WRB)
  10995. C   920501  Reformatted the REFERENCES section.  (WRB)
  10996. C***END PROLOGUE  BSPPP
  10997. C
  10998.       INTEGER ILEFT, INEV, K, LDC, LXI, N, NK
  10999.       REAL A, C, T, WORK, XI
  11000. C     DIMENSION T(N+K),XI(LXI+1),C(LDC,*)
  11001. C     HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI.
  11002.       DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*)
  11003. C***FIRST EXECUTABLE STATEMENT  BSPPP
  11004.       IF(K.LT.1) GO TO 100
  11005.       IF(N.LT.K) GO TO 105
  11006.       IF(LDC.LT.K) GO TO 110
  11007.       CALL BSPDR(T, A, N, K, K, WORK)
  11008.       LXI = 0
  11009.       XI(1) = T(K)
  11010.       INEV = 1
  11011.       NK = N*K + 1
  11012.       DO 10 ILEFT=K,N
  11013.         IF (T(ILEFT+1).EQ.T(ILEFT)) GO TO 10
  11014.         LXI = LXI + 1
  11015.         XI(LXI+1) = T(ILEFT+1)
  11016.         CALL BSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK))
  11017.    10 CONTINUE
  11018.       RETURN
  11019.   100 CONTINUE
  11020.       CALL XERMSG ('SLATEC', 'BSPPP', 'K DOES NOT SATISFY K.GE.1', 2,
  11021.      +   1)
  11022.       RETURN
  11023.   105 CONTINUE
  11024.       CALL XERMSG ('SLATEC', 'BSPPP', 'N DOES NOT SATISFY N.GE.K', 2,
  11025.      +   1)
  11026.       RETURN
  11027.   110 CONTINUE
  11028.       CALL XERMSG ('SLATEC', 'BSPPP', 'LDC DOES NOT SATISFY LDC.GE.K',
  11029.      +   2, 1)
  11030.       RETURN
  11031.       END
  11032. *DECK BSPVD
  11033.       SUBROUTINE BSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK)
  11034. C***BEGIN PROLOGUE  BSPVD
  11035. C***PURPOSE  Calculate the value and all derivatives of order less than
  11036. C            NDERIV of all basis functions which do not vanish at X.
  11037. C***LIBRARY   SLATEC
  11038. C***CATEGORY  E3, K6
  11039. C***TYPE      SINGLE PRECISION (BSPVD-S, DBSPVD-D)
  11040. C***KEYWORDS  DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE
  11041. C***AUTHOR  Amos, D. E., (SNLA)
  11042. C***DESCRIPTION
  11043. C
  11044. C     Written by Carl de Boor and modified by D. E. Amos
  11045. C
  11046. C     Abstract
  11047. C         BSPVD is the BSPLVD routine of the reference.
  11048. C
  11049. C         BSPVD calculates the value and all derivatives of order
  11050. C         less than NDERIV of all basis functions which do not
  11051. C         (possibly) vanish at X.  ILEFT is input such that
  11052. C         T(ILEFT) .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,
  11053. C         ILO,ILEFT,MFLAG) will produce the proper ILEFT.  The output of
  11054. C         BSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV)
  11055. C         whose columns contain the K nonzero basis functions and
  11056. C         their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV.
  11057. C         These basis functions have indices ILEFT-K+I, I=1,K,
  11058. C         K .LE. ILEFT .LE. N. The nonzero part of the I-th basis
  11059. C         function lies in (T(I),T(I+K)), I=1,N.
  11060. C
  11061. C         If X=T(ILEFT+1) then VNIKX contains left limiting values
  11062. C         (left derivatives) at T(ILEFT+1).  In particular, ILEFT = N
  11063. C         produces left limiting values at the right end point
  11064. C         X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1,
  11065. C         set X= next lower distinct knot, call INTRV to get ILEFT,
  11066. C         set X=T(I), and then call BSPVD.
  11067. C
  11068. C     Description of Arguments
  11069. C         Input
  11070. C          T       - knot vector of length N+K, where
  11071. C                    N = number of B-spline basis functions
  11072. C                    N = sum of knot multiplicities-K
  11073. C          K       - order of the B-spline, K .GE. 1
  11074. C          NDERIV  - number of derivatives = NDERIV-1,
  11075. C                    1 .LE. NDERIV .LE. K
  11076. C          X       - argument of basis functions,
  11077. C                    T(K) .LE. X .LE. T(N+1)
  11078. C          ILEFT   - largest integer such that
  11079. C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
  11080. C          LDVNIK  - leading dimension of matrix VNIKX
  11081. C
  11082. C         Output
  11083. C          VNIKX   - matrix of dimension at least (K,NDERIV) contain-
  11084. C                    ing the nonzero basis functions at X and their
  11085. C                    derivatives columnwise.
  11086. C          WORK    - a work vector of length (K+1)*(K+2)/2
  11087. C
  11088. C     Error Conditions
  11089. C         Improper input is a fatal error
  11090. C
  11091. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  11092. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  11093. C                 pp. 441-472.
  11094. C***ROUTINES CALLED  BSPVN, XERMSG
  11095. C***REVISION HISTORY  (YYMMDD)
  11096. C   800901  DATE WRITTEN
  11097. C   890531  Changed all specific intrinsics to generic.  (WRB)
  11098. C   890831  Modified array declarations.  (WRB)
  11099. C   890831  REVISION DATE from Version 3.2
  11100. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11101. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  11102. C   900326  Removed duplicate information from DESCRIPTION section.
  11103. C           (WRB)
  11104. C   920501  Reformatted the REFERENCES section.  (WRB)
  11105. C***END PROLOGUE  BSPVD
  11106. C
  11107.       INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L,
  11108.      1 LDUMMY, M, MHIGH, NDERIV
  11109.       REAL FACTOR, FKMD, T, V, VNIKX, WORK, X
  11110. C     DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2)
  11111. C     A(I,J) = WORK(I+J*(J+1)/2),  I=1,J+1  J=1,K-1
  11112. C     A(I,K) = W0RK(I+K*(K-1)/2)  I=1.K
  11113. C     WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED.
  11114.       DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*)
  11115. C***FIRST EXECUTABLE STATEMENT  BSPVD
  11116.       IF(K.LT.1) GO TO 200
  11117.       IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 205
  11118.       IF(LDVNIK.LT.K) GO TO 210
  11119.       IDERIV = NDERIV
  11120.       KP1 = K + 1
  11121.       JJ = KP1 - IDERIV
  11122.       CALL BSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK)
  11123.       IF (IDERIV.EQ.1) GO TO 100
  11124.       MHIGH = IDERIV
  11125.       DO 20 M=2,MHIGH
  11126.         JP1MID = 1
  11127.         DO 10 J=IDERIV,K
  11128.           VNIKX(J,IDERIV) = VNIKX(JP1MID,1)
  11129.           JP1MID = JP1MID + 1
  11130.    10   CONTINUE
  11131.         IDERIV = IDERIV - 1
  11132.         JJ = KP1 - IDERIV
  11133.         CALL BSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK)
  11134.    20 CONTINUE
  11135. C
  11136.       JM = KP1*(KP1+1)/2
  11137.       DO 30 L = 1,JM
  11138.         WORK(L) = 0.0E0
  11139.    30 CONTINUE
  11140. C     A(I,I) = WORK(I*(I+3)/2) = 1.0       I = 1,K
  11141.       L = 2
  11142.       J = 0
  11143.       DO 40 I = 1,K
  11144.         J = J + L
  11145.         WORK(J) = 1.0E0
  11146.         L = L + 1
  11147.    40 CONTINUE
  11148.       KMD = K
  11149.       DO 90 M=2,MHIGH
  11150.         KMD = KMD - 1
  11151.         FKMD = KMD
  11152.         I = ILEFT
  11153.         J = K
  11154.         JJ = J*(J+1)/2
  11155.         JM = JJ - J
  11156.         DO 60 LDUMMY=1,KMD
  11157.           IPKMD = I + KMD
  11158.           FACTOR = FKMD/(T(IPKMD)-T(I))
  11159.           DO 50 L=1,J
  11160.             WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR
  11161.    50     CONTINUE
  11162.           I = I - 1
  11163.           J = J - 1
  11164.           JJ = JM
  11165.           JM = JM - J
  11166.    60   CONTINUE
  11167. C
  11168.         DO 80 I=1,K
  11169.           V = 0.0E0
  11170.           JLOW = MAX(I,M)
  11171.           JJ = JLOW*(JLOW+1)/2
  11172.           DO 70 J=JLOW,K
  11173.             V = WORK(I+JJ)*VNIKX(J,M) + V
  11174.             JJ = JJ + J + 1
  11175.    70     CONTINUE
  11176.           VNIKX(I,M) = V
  11177.    80   CONTINUE
  11178.    90 CONTINUE
  11179.   100 RETURN
  11180. C
  11181. C
  11182.   200 CONTINUE
  11183.       CALL XERMSG ('SLATEC', 'BSPVD', 'K DOES NOT SATISFY K.GE.1', 2,
  11184.      +   1)
  11185.       RETURN
  11186.   205 CONTINUE
  11187.       CALL XERMSG ('SLATEC', 'BSPVD',
  11188.      +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
  11189.       RETURN
  11190.   210 CONTINUE
  11191.       CALL XERMSG ('SLATEC', 'BSPVD',
  11192.      +   'LDVNIK DOES NOT SATISFY LDVNIK.GE.K', 2, 1)
  11193.       RETURN
  11194.       END
  11195. *DECK BSPVN
  11196.       SUBROUTINE BSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK,
  11197.      +   IWORK)
  11198. C***BEGIN PROLOGUE  BSPVN
  11199. C***PURPOSE  Calculate the value of all (possibly) nonzero basis
  11200. C            functions at X.
  11201. C***LIBRARY   SLATEC
  11202. C***CATEGORY  E3, K6
  11203. C***TYPE      SINGLE PRECISION (BSPVN-S, DBSPVN-D)
  11204. C***KEYWORDS  EVALUATION OF B-SPLINE
  11205. C***AUTHOR  Amos, D. E., (SNLA)
  11206. C***DESCRIPTION
  11207. C
  11208. C     Written by Carl de Boor and modified by D. E. Amos
  11209. C
  11210. C     Abstract
  11211. C         BSPVN is the BSPLVN routine of the reference.
  11212. C
  11213. C         BSPVN calculates the value of all (possibly) nonzero basis
  11214. C         functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where
  11215. C         T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine
  11216. C         on the first call when INDEX=1.  ILEFT is such that T(ILEFT)
  11217. C         .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,ILO,ILEFT,
  11218. C         MFLAG) produces the proper ILEFT.  BSPVN calculates using the
  11219. C         basic algorithm needed in BSPVD.  If only basis functions are
  11220. C         desired, setting JHIGH=K and INDEX=1 can be faster than
  11221. C         calling BSPVD, but extra coding is required for derivatives
  11222. C         (INDEX=2) and BSPVD is set up for this purpose.
  11223. C
  11224. C         Left limiting values are set up as described in BSPVD.
  11225. C
  11226. C     Description of Arguments
  11227. C         Input
  11228. C          T       - knot vector of length N+K, where
  11229. C                    N = number of B-spline basis functions
  11230. C                    N = sum of knot multiplicities-K
  11231. C          JHIGH   - order of B-spline, 1 .LE. JHIGH .LE. K
  11232. C          K       - highest possible order
  11233. C          INDEX   - INDEX = 1 gives basis functions of order JHIGH
  11234. C                          = 2 denotes previous entry with WORK, IWORK
  11235. C                              values saved for subsequent calls to
  11236. C                              BSPVN.
  11237. C          X       - argument of basis functions,
  11238. C                    T(K) .LE. X .LE. T(N+1)
  11239. C          ILEFT   - largest integer such that
  11240. C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
  11241. C
  11242. C         Output
  11243. C          VNIKX   - vector of length K for spline values.
  11244. C          WORK    - a work vector of length 2*K
  11245. C          IWORK   - a work parameter.  Both WORK and IWORK contain
  11246. C                    information necessary to continue for INDEX = 2.
  11247. C                    When INDEX = 1 exclusively, these are scratch
  11248. C                    variables and can be used for other purposes.
  11249. C
  11250. C     Error Conditions
  11251. C         Improper input is a fatal error.
  11252. C
  11253. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  11254. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  11255. C                 pp. 441-472.
  11256. C***ROUTINES CALLED  XERMSG
  11257. C***REVISION HISTORY  (YYMMDD)
  11258. C   800901  DATE WRITTEN
  11259. C   890831  Modified array declarations.  (WRB)
  11260. C   890831  REVISION DATE from Version 3.2
  11261. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11262. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  11263. C   900326  Removed duplicate information from DESCRIPTION section.
  11264. C           (WRB)
  11265. C   920501  Reformatted the REFERENCES section.  (WRB)
  11266. C***END PROLOGUE  BSPVN
  11267. C
  11268.       INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L
  11269.       REAL T, VM, VMPREV, VNIKX, WORK, X
  11270. C     DIMENSION T(ILEFT+JHIGH)
  11271.       DIMENSION T(*), VNIKX(*), WORK(*)
  11272. C     CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS.
  11273. C     WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K
  11274. C***FIRST EXECUTABLE STATEMENT  BSPVN
  11275.       IF(K.LT.1) GO TO 90
  11276.       IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100
  11277.       IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105
  11278.       IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110
  11279.       GO TO (10, 20), INDEX
  11280.    10 IWORK = 1
  11281.       VNIKX(1) = 1.0E0
  11282.       IF (IWORK.GE.JHIGH) GO TO 40
  11283. C
  11284.    20 IPJ = ILEFT + IWORK
  11285.       WORK(IWORK) = T(IPJ) - X
  11286.       IMJP1 = ILEFT - IWORK + 1
  11287.       WORK(K+IWORK) = X - T(IMJP1)
  11288.       VMPREV = 0.0E0
  11289.       JP1 = IWORK + 1
  11290.       DO 30 L=1,IWORK
  11291.         JP1ML = JP1 - L
  11292.         VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML))
  11293.         VNIKX(L) = VM*WORK(L) + VMPREV
  11294.         VMPREV = VM*WORK(K+JP1ML)
  11295.    30 CONTINUE
  11296.       VNIKX(JP1) = VMPREV
  11297.       IWORK = JP1
  11298.       IF (IWORK.LT.JHIGH) GO TO 20
  11299. C
  11300.    40 RETURN
  11301. C
  11302. C
  11303.    90 CONTINUE
  11304.       CALL XERMSG ('SLATEC', 'BSPVN', 'K DOES NOT SATISFY K.GE.1', 2,
  11305.      +   1)
  11306.       RETURN
  11307.   100 CONTINUE
  11308.       CALL XERMSG ('SLATEC', 'BSPVN',
  11309.      +   'JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K', 2, 1)
  11310.       RETURN
  11311.   105 CONTINUE
  11312.       CALL XERMSG ('SLATEC', 'BSPVN', 'INDEX IS NOT 1 OR 2', 2, 1)
  11313.       RETURN
  11314.   110 CONTINUE
  11315.       CALL XERMSG ('SLATEC', 'BSPVN',
  11316.      +   'X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEFT+1)', 2, 1)
  11317.       RETURN
  11318.       END
  11319. *DECK BSQAD
  11320.       SUBROUTINE BSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK)
  11321. C***BEGIN PROLOGUE  BSQAD
  11322. C***PURPOSE  Compute the integral of a K-th order B-spline using the
  11323. C            B-representation.
  11324. C***LIBRARY   SLATEC
  11325. C***CATEGORY  H2A2A1, E3, K6
  11326. C***TYPE      SINGLE PRECISION (BSQAD-S, DBSQAD-D)
  11327. C***KEYWORDS  INTEGRAL OF B-SPLINES, QUADRATURE
  11328. C***AUTHOR  Amos, D. E., (SNLA)
  11329. C***DESCRIPTION
  11330. C
  11331. C     Abstract
  11332. C         BSQAD computes the integral on (X1,X2) of a K-th order
  11333. C         B-spline using the B-representation (T,BCOEF,N,K).  Orders
  11334. C         K as high as 20 are permitted by applying a 2, 6, or 10
  11335. C         point Gauss formula on subintervals of (X1,X2) which are
  11336. C         formed by included (distinct) knots.
  11337. C
  11338. C         If orders K greater than 20 are needed, use BFQAD with
  11339. C         F(X) = 1.
  11340. C
  11341. C     Description of Arguments
  11342. C         Input
  11343. C           T      - knot array of length N+K
  11344. C           BCOEF  - B-spline coefficient array of length N
  11345. C           N      - length of coefficient array
  11346. C           K      - order of B-spline, 1 .LE. K .LE. 20
  11347. C           X1,X2  - end points of quadrature interval in
  11348. C                    T(K) .LE. X .LE. T(N+1)
  11349. C
  11350. C         Output
  11351. C           BQUAD  - integral of the B-spline over (X1,X2)
  11352. C           WORK   - work vector of length 3*K
  11353. C
  11354. C     Error Conditions
  11355. C         Improper input is a fatal error
  11356. C
  11357. C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
  11358. C                 B-splines, Report SAND79-1825, Sandia Laboratories,
  11359. C                 December 1979.
  11360. C***ROUTINES CALLED  BVALU, INTRV, XERMSG
  11361. C***REVISION HISTORY  (YYMMDD)
  11362. C   800901  DATE WRITTEN
  11363. C   890531  Changed all specific intrinsics to generic.  (WRB)
  11364. C   890531  REVISION DATE from Version 3.2
  11365. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11366. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  11367. C   900326  Removed duplicate information from DESCRIPTION section.
  11368. C           (WRB)
  11369. C   920501  Reformatted the REFERENCES section.  (WRB)
  11370. C***END PROLOGUE  BSQAD
  11371. C
  11372.       INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1
  11373.       REAL A, AA, B, BB, BCOEF, BMA, BPA, BQUAD, C1, GPTS, GWTS, GX, Q,
  11374.      1 SUM, T, TA, TB, WORK, X1, X2, Y1, Y2
  11375.       REAL BVALU
  11376.       DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*)
  11377. C
  11378.       SAVE GPTS, GWTS
  11379.       DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6),
  11380.      1     GPTS(7), GPTS(8), GPTS(9)/
  11381.      2     5.77350269189625764E-01,     2.38619186083196909E-01,
  11382.      3     6.61209386466264514E-01,     9.32469514203152028E-01,
  11383.      4     1.48874338981631211E-01,     4.33395394129247191E-01,
  11384.      5     6.79409568299024406E-01,     8.65063366688984511E-01,
  11385.      6     9.73906528517171720E-01/
  11386.       DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6),
  11387.      1     GWTS(7), GWTS(8), GWTS(9)/
  11388.      2     1.00000000000000000E+00,     4.67913934572691047E-01,
  11389.      3     3.60761573048138608E-01,     1.71324492379170345E-01,
  11390.      4     2.95524224714752870E-01,     2.69266719309996355E-01,
  11391.      5     2.19086362515982044E-01,     1.49451349150580593E-01,
  11392.      6     6.66713443086881376E-02/
  11393. C
  11394. C***FIRST EXECUTABLE STATEMENT  BSQAD
  11395.       BQUAD = 0.0E0
  11396.       IF(K.LT.1 .OR. K.GT.20) GO TO 65
  11397.       IF(N.LT.K) GO TO 70
  11398.       AA = MIN(X1,X2)
  11399.       BB = MAX(X1,X2)
  11400.       IF (AA.LT.T(K)) GO TO 60
  11401.       NP1 = N + 1
  11402.       IF (BB.GT.T(NP1)) GO TO 60
  11403.       IF (AA.EQ.BB) RETURN
  11404.       NPK = N + K
  11405. C     SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA
  11406.       JF = 0
  11407.       MF = 1
  11408.       IF (K.LE.4) GO TO 10
  11409.       JF = 1
  11410.       MF = 3
  11411.       IF (K.LE.12) GO TO 10
  11412.       JF = 4
  11413.       MF = 5
  11414.    10 CONTINUE
  11415. C
  11416.       DO 20 I=1,MF
  11417.         SUM(I) = 0.0E0
  11418.    20 CONTINUE
  11419.       ILO = 1
  11420.       INBV = 1
  11421.       CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
  11422.       CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
  11423.       IF (IL2.GE.NP1) IL2 = N
  11424.       DO 40 LEFT=IL1,IL2
  11425.         TA = T(LEFT)
  11426.         TB = T(LEFT+1)
  11427.         IF (TA.EQ.TB) GO TO 40
  11428.         A = MAX(AA,TA)
  11429.         B = MIN(BB,TB)
  11430.         BMA = 0.5E0*(B-A)
  11431.         BPA = 0.5E0*(B+A)
  11432.         DO 30 M=1,MF
  11433.           C1 = BMA*GPTS(JF+M)
  11434.           GX = -C1 + BPA
  11435.           Y2 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
  11436.           GX = C1 + BPA
  11437.           Y1 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
  11438.           SUM(M) = SUM(M) + (Y1+Y2)*BMA
  11439.    30   CONTINUE
  11440.    40 CONTINUE
  11441.       Q = 0.0E0
  11442.       DO 50 M=1,MF
  11443.         Q = Q + GWTS(JF+M)*SUM(M)
  11444.    50 CONTINUE
  11445.       IF (X1.GT.X2) Q = -Q
  11446.       BQUAD = Q
  11447.       RETURN
  11448. C
  11449. C
  11450.    60 CONTINUE
  11451.       CALL XERMSG ('SLATEC', 'BSQAD',
  11452.      +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
  11453.       RETURN
  11454.    65 CONTINUE
  11455.       CALL XERMSG ('SLATEC', 'BSQAD', 'K DOES NOT SATISFY 1.LE.K.LE.20'
  11456.      +   , 2, 1)
  11457.       RETURN
  11458.    70 CONTINUE
  11459.       CALL XERMSG ('SLATEC', 'BSQAD', 'N DOES NOT SATISFY N.GE.K', 2,
  11460.      +   1)
  11461.       RETURN
  11462.       END
  11463. *DECK BSRH
  11464.       FUNCTION BSRH (XLL, XRR, IZ, C, A, BH, F, SGN)
  11465. C***BEGIN PROLOGUE  BSRH
  11466. C***SUBSIDIARY
  11467. C***PURPOSE  Subsidiary to BLKTRI
  11468. C***LIBRARY   SLATEC
  11469. C***TYPE      SINGLE PRECISION (BCRH-S, BSRH-S)
  11470. C***AUTHOR  (UNKNOWN)
  11471. C***SEE ALSO  BLKTRI
  11472. C***ROUTINES CALLED  (NONE)
  11473. C***COMMON BLOCKS    CBLKT
  11474. C***REVISION HISTORY  (YYMMDD)
  11475. C   801001  DATE WRITTEN
  11476. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11477. C   900402  Added TYPE section.  (WRB)
  11478. C***END PROLOGUE  BSRH
  11479.       DIMENSION       A(*)       ,C(*)       ,BH(*)
  11480.       COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
  11481.      1                NM         ,NCMPLX     ,IK
  11482. C***FIRST EXECUTABLE STATEMENT  BSRH
  11483.       XL = XLL
  11484.       XR = XRR
  11485.       DX = .5*ABS(XR-XL)
  11486.   101 X = .5*(XL+XR)
  11487.       IF (SGN*F(X,IZ,C,A,BH)) 103,105,102
  11488.   102 XR = X
  11489.       GO TO 104
  11490.   103 XL = X
  11491.   104 DX = .5*DX
  11492.       IF (DX-CNV) 105,105,101
  11493.   105 BSRH = .5*(XL+XR)
  11494.       RETURN
  11495.       END
  11496. *DECK BVALU
  11497.       FUNCTION BVALU (T, A, N, K, IDERIV, X, INBV, WORK)
  11498. C***BEGIN PROLOGUE  BVALU
  11499. C***PURPOSE  Evaluate the B-representation of a B-spline at X for the
  11500. C            function value or any of its derivatives.
  11501. C***LIBRARY   SLATEC
  11502. C***CATEGORY  E3, K6
  11503. C***TYPE      SINGLE PRECISION (BVALU-S, DBVALU-D)
  11504. C***KEYWORDS  DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE
  11505. C***AUTHOR  Amos, D. E., (SNLA)
  11506. C***DESCRIPTION
  11507. C
  11508. C     Written by Carl de Boor and modified by D. E. Amos
  11509. C
  11510. C     Abstract
  11511. C         BVALU is the BVALUE function of the reference.
  11512. C
  11513. C         BVALU evaluates the B-representation (T,A,N,K) of a B-spline
  11514. C         at X for the function value on IDERIV = 0 or any of its
  11515. C         derivatives on IDERIV = 1,2,...,K-1.  Right limiting values
  11516. C         (right derivatives) are returned except at the right end
  11517. C         point X=T(N+1) where left limiting values are computed.  The
  11518. C         spline is defined on T(K) .LE. X .LE. T(N+1).  BVALU returns
  11519. C         a fatal error message when X is outside of this interval.
  11520. C
  11521. C         To compute left derivatives or left limiting values at a
  11522. C         knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1.
  11523. C
  11524. C         BVALU calls INTRV
  11525. C
  11526. C     Description of Arguments
  11527. C         Input
  11528. C          T       - knot vector of length N+K
  11529. C          A       - B-spline coefficient vector of length N
  11530. C          N       - number of B-spline coefficients
  11531. C                    N = sum of knot multiplicities-K
  11532. C          K       - order of the B-spline, K .GE. 1
  11533. C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
  11534. C                    IDERIV=0 returns the B-spline value
  11535. C          X       - argument, T(K) .LE. X .LE. T(N+1)
  11536. C          INBV    - an initialization parameter which must be set
  11537. C                    to 1 the first time BVALU is called.
  11538. C
  11539. C         Output
  11540. C          INBV    - INBV contains information for efficient process-
  11541. C                    ing after the initial call and INBV must not
  11542. C                    be changed by the user.  Distinct splines require
  11543. C                    distinct INBV parameters.
  11544. C          WORK    - work vector of length 3*K.
  11545. C          BVALU   - value of the IDERIV-th derivative at X
  11546. C
  11547. C     Error Conditions
  11548. C         An improper input is a fatal error
  11549. C
  11550. C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
  11551. C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
  11552. C                 pp. 441-472.
  11553. C***ROUTINES CALLED  INTRV, XERMSG
  11554. C***REVISION HISTORY  (YYMMDD)
  11555. C   800901  DATE WRITTEN
  11556. C   890531  Changed all specific intrinsics to generic.  (WRB)
  11557. C   890531  REVISION DATE from Version 3.2
  11558. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11559. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  11560. C   900326  Removed duplicate information from DESCRIPTION section.
  11561. C           (WRB)
  11562. C   920501  Reformatted the REFERENCES section.  (WRB)
  11563. C***END PROLOGUE  BVALU
  11564. C
  11565.       INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ,
  11566.      1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N
  11567.       REAL A, FKMJ, T, WORK, X
  11568. C     DIMENSION T(N+K), WORK(3*K)
  11569.       DIMENSION T(*), A(*), WORK(*)
  11570. C***FIRST EXECUTABLE STATEMENT  BVALU
  11571.       BVALU = 0.0E0
  11572.       IF(K.LT.1) GO TO 102
  11573.       IF(N.LT.K) GO TO 101
  11574.       IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110
  11575.       KMIDER = K - IDERIV
  11576. C
  11577. C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1)
  11578. C     (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)).
  11579.       KM1 = K - 1
  11580.       CALL INTRV(T, N+1, X, INBV, I, MFLAG)
  11581.       IF (X.LT.T(K)) GO TO 120
  11582.       IF (MFLAG.EQ.0) GO TO 20
  11583.       IF (X.GT.T(I)) GO TO 130
  11584.    10 IF (I.EQ.K) GO TO 140
  11585.       I = I - 1
  11586.       IF (X.EQ.T(I)) GO TO 10
  11587. C
  11588. C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES
  11589. C     WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K
  11590. C
  11591.    20 IMK = I - K
  11592.       DO 30 J=1,K
  11593.         IMKPJ = IMK + J
  11594.         WORK(J) = A(IMKPJ)
  11595.    30 CONTINUE
  11596.       IF (IDERIV.EQ.0) GO TO 60
  11597.       DO 50 J=1,IDERIV
  11598.         KMJ = K - J
  11599.         FKMJ = KMJ
  11600.         DO 40 JJ=1,KMJ
  11601.           IHI = I + JJ
  11602.           IHMKMJ = IHI - KMJ
  11603.           WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ
  11604.    40   CONTINUE
  11605.    50 CONTINUE
  11606. C
  11607. C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE,
  11608. C     GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV).
  11609.    60 IF (IDERIV.EQ.KM1) GO TO 100
  11610.       IP1 = I + 1
  11611.       KPK = K + K
  11612.       J1 = K + 1
  11613.       J2 = KPK + 1
  11614.       DO 70 J=1,KMIDER
  11615.         IPJ = I + J
  11616.         WORK(J1) = T(IPJ) - X
  11617.         IP1MJ = IP1 - J
  11618.         WORK(J2) = X - T(IP1MJ)
  11619.         J1 = J1 + 1
  11620.         J2 = J2 + 1
  11621.    70 CONTINUE
  11622.       IDERP1 = IDERIV + 1
  11623.       DO 90 J=IDERP1,KM1
  11624.         KMJ = K - J
  11625.         ILO = KMJ
  11626.         DO 80 JJ=1,KMJ
  11627.           WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ)
  11628.      1              *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ))
  11629.           ILO = ILO - 1
  11630.    80   CONTINUE
  11631.    90 CONTINUE
  11632.   100 BVALU = WORK(1)
  11633.       RETURN
  11634. C
  11635. C
  11636.   101 CONTINUE
  11637.       CALL XERMSG ('SLATEC', 'BVALU', 'N DOES NOT SATISFY N.GE.K', 2,
  11638.      +   1)
  11639.       RETURN
  11640.   102 CONTINUE
  11641.       CALL XERMSG ('SLATEC', 'BVALU', 'K DOES NOT SATISFY K.GE.1', 2,
  11642.      +   1)
  11643.       RETURN
  11644.   110 CONTINUE
  11645.       CALL XERMSG ('SLATEC', 'BVALU',
  11646.      +   'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1)
  11647.       RETURN
  11648.   120 CONTINUE
  11649.       CALL XERMSG ('SLATEC', 'BVALU',
  11650.      +   'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1)
  11651.       RETURN
  11652.   130 CONTINUE
  11653.       CALL XERMSG ('SLATEC', 'BVALU',
  11654.      +   'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1)
  11655.       RETURN
  11656.   140 CONTINUE
  11657.       CALL XERMSG ('SLATEC', 'BVALU',
  11658.      +   'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1)
  11659.       RETURN
  11660.       END
  11661. *DECK BVDER
  11662.       SUBROUTINE BVDER (X, Y, YP, G, IPAR)
  11663. C***BEGIN PROLOGUE  BVDER
  11664. C***SUBSIDIARY
  11665. C***PURPOSE  Subsidiary to BVSUP
  11666. C***LIBRARY   SLATEC
  11667. C***TYPE      SINGLE PRECISION (BVDER-S, DBVDER-D)
  11668. C***AUTHOR  Watts, H. A., (SNLA)
  11669. C***DESCRIPTION
  11670. C
  11671. C **********************************************************************
  11672. C     NFC = Number of base solution vectors
  11673. C
  11674. C     NCOMP = Number of components per solution vector
  11675. C
  11676. C              1 -- Nonzero particular solution
  11677. C     INHOMO =
  11678. C              2 or 3 -- Zero particular solution
  11679. C
  11680. C             0 -- Inhomogeneous vector term G(X) identically zero
  11681. C     IGOFX =
  11682. C             1 -- Inhomogeneous vector term G(X) not identically zero
  11683. C
  11684. C     G = Inhomogeneous vector term G(X)
  11685. C
  11686. C     XSAV = Previous value of X
  11687. C
  11688. C     C = Normalization factor for the particular solution
  11689. C
  11690. C           0   ( if  NEQIVP = 0 )
  11691. C     IVP =
  11692. C           Number of differential equations integrated due to
  11693. C           the original boundary value problem   ( if  NEQIVP .GT. 0 )
  11694. C
  11695. C     NOFST - For problems with auxiliary initial value equations,
  11696. C             NOFST communicates to the routine FMAT how to access
  11697. C             the dependent variables corresponding to this initial
  11698. C             value problem.  For example, during any call to FMAT,
  11699. C             the first dependent variable for the initial value
  11700. C             problem is in position  Y(NOFST + 1).
  11701. C             See example in SAND77-1328.
  11702. C **********************************************************************
  11703. C
  11704. C***SEE ALSO  BVSUP
  11705. C***ROUTINES CALLED  (NONE)
  11706. C***COMMON BLOCKS    ML8SZ, MLIVP
  11707. C***REVISION HISTORY  (YYMMDD)
  11708. C   750601  DATE WRITTEN
  11709. C   890921  Realigned order of variables in certain COMMON blocks.
  11710. C           (WRB)
  11711. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11712. C   900328  Added TYPE section.  (WRB)
  11713. C   910701  Corrected ROUTINES CALLED section.  (WRB)
  11714. C   910722  Updated AUTHOR section.  (ALS)
  11715. C   920618  Minor restructuring of code.  (RWC, WRB)
  11716. C***END PROLOGUE  BVDER
  11717.       DIMENSION Y(*),YP(*),G(*)
  11718. C
  11719. C **********************************************************************
  11720. C
  11721.       COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC
  11722. C
  11723. C **********************************************************************
  11724. C     The COMMON block below is used to communicate with the user
  11725. C     supplied subroutine FMAT.  The user should not alter this
  11726. C     COMMON block.
  11727. C
  11728.       COMMON /MLIVP/ NOFST
  11729. C **********************************************************************
  11730. C
  11731. C***FIRST EXECUTABLE STATEMENT  BVDER
  11732.       IF (IVP .GT. 0) CALL UIVP(X,Y(IVP+1),YP(IVP+1))
  11733.       NOFST = IVP
  11734.       NA = 1
  11735.       DO 10 K=1,NFC
  11736.          CALL FMAT(X,Y(NA),YP(NA))
  11737.          NOFST = NOFST - NCOMP
  11738.          NA = NA + NCOMP
  11739.    10 CONTINUE
  11740. C
  11741.       IF (INHOMO .NE. 1) RETURN
  11742.       CALL FMAT(X,Y(NA),YP(NA))
  11743. C
  11744.       IF (IGOFX .EQ. 0) RETURN
  11745.       IF (X .NE. XSAV) THEN
  11746.          IF (IVP .EQ. 0) CALL GVEC(X,G)
  11747.          IF (IVP .GT. 0) CALL UVEC(X,Y(IVP+1),G)
  11748.          XSAV = X
  11749.       ENDIF
  11750. C
  11751. C     If the user has chosen not to normalize the particular
  11752. C     solution, then C is defined in BVPOR to be 1.0
  11753. C
  11754. C     The following loop is just
  11755. C     CALL SAXPY (NCOMP, 1.0E0/C, G, 1, YP(NA), 1)
  11756. C
  11757.       DO 20 J=1,NCOMP
  11758.          L = NA + J - 1
  11759.          YP(L) = YP(L) + G(J)/C
  11760.    20 CONTINUE
  11761.       RETURN
  11762.       END
  11763. *DECK BVPOR
  11764.       SUBROUTINE BVPOR (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA,
  11765.      +   NIC, B, NROWB, BETA, NFC, IFLAG, Z, MXNON, P, NTP, IP, W, NIV,
  11766.      +   YHP, U, V, COEF, S, STOWA, G, WORK, IWORK, NFCC)
  11767. C***BEGIN PROLOGUE  BVPOR
  11768. C***SUBSIDIARY
  11769. C***PURPOSE  Subsidiary to BVSUP
  11770. C***LIBRARY   SLATEC
  11771. C***TYPE      SINGLE PRECISION (BVPOR-S, DBVPOR-D)
  11772. C***AUTHOR  Watts, H. A., (SNLA)
  11773. C***DESCRIPTION
  11774. C
  11775. C **********************************************************************
  11776. C     INPUT to BVPOR    (items not defined in BVSUP comments)
  11777. C **********************************************************************
  11778. C
  11779. C     NOPG = 0 -- Orthonormalization points not pre-assigned
  11780. C          = 1 -- Orthonormalization points pre-assigned
  11781. C
  11782. C     MXNON = Maximum number of orthogonalizations allowed.
  11783. C
  11784. C     NDISK = 0 -- IN-CORE storage
  11785. C           = 1 -- DISK storage.  Value of NTAPE in data statement
  11786. C                  is set to 13.  If another value is desired,
  11787. C                  the data statement must be changed.
  11788. C
  11789. C     INTEG = Type of integrator and associated test to be used
  11790. C             to determine when to orthonormalize.
  11791. C
  11792. C             1 -- Use GRAM-SCHMIDT test and DERKF
  11793. C             2 -- Use GRAM-SCHMIDT test and DEABM
  11794. C
  11795. C     TOL = Tolerance for allowable error in orthogonalization test.
  11796. C
  11797. C     NPS = 0 Normalize particular solution to unit length at each
  11798. C             point of orthonormalization.
  11799. C         = 1 Do not normalize particular solution.
  11800. C
  11801. C     NTP = Must be .GE. NFC*(NFC+1)/2.
  11802. C
  11803. C
  11804. C     NFCC = 2*NFC for special treatment of a complex valued problem
  11805. C
  11806. C     ICOCO = 0 Skip final computations (superposition coefficients
  11807. C               and ,hence, boundary problem solution)
  11808. C           = 1 Calculate superposition coefficients and obtain
  11809. C               solution to the boundary value problem
  11810. C
  11811. C **********************************************************************
  11812. C     OUTPUT from BVPOR
  11813. C **********************************************************************
  11814. C
  11815. C     Y(NROWY,NXPTS) = Solution at specified output points.
  11816. C
  11817. C     MXNON = Number of orthonormalizations performed by BVPOR.
  11818. C
  11819. C     Z(MXNON+1) = Locations of orthonormalizations performed by BVPOR.
  11820. C
  11821. C     NIV = Number of independent vectors returned from MGSBV. Normally
  11822. C        this parameter will be meaningful only when MGSBV returns with
  11823. C           MFLAG = 2.
  11824. C
  11825. C **********************************************************************
  11826. C
  11827. C     The following variables are in the argument list because of
  11828. C     variable dimensioning. In general, they contain no information of
  11829. C     use to the user.  The amount of storage set aside by the user must
  11830. C     be greater than or equal to that indicated by the dimension
  11831. C     statements.   For the DISK storage mode, NON = 0 and KPTS = 1,
  11832. C     while for the IN-CORE storage mode, NON = MXNON and KPTS = NXPTS.
  11833. C
  11834. C     P(NTP,NON+1)
  11835. C     IP(NFCC,NON+1)
  11836. C     YHP(NCOMP,NFC+1)  plus an additional column of the length  NEQIVP
  11837. C     U(NCOMP,NFC,KPTS)
  11838. C     V(NCOMP,KPTS)
  11839. C     W(NFCC,NON+1)
  11840. C     COEF(NFCC)
  11841. C     S(NFC+1)
  11842. C     STOWA(NCOMP*(NFC+1)+NEQIVP+1)
  11843. C     G(NCOMP)
  11844. C     WORK(KKKWS)
  11845. C     IWORK(LLLIWS)
  11846. C
  11847. C **********************************************************************
  11848. C     Subroutines used by BVPOR
  11849. C         LSSUDS -- Solves an underdetermined system of linear
  11850. C                   equations.  This routine is used to get a full
  11851. C                   set of initial conditions for integration.
  11852. C                   Called by BVPOR
  11853. C
  11854. C         SVECS -- Obtains starting vectors for special treatment
  11855. C                  of complex valued problems , called by BVPOR
  11856. C
  11857. C         RKFAB -- Routine which conducts integration using DERKF or
  11858. C                   DEABM
  11859. C
  11860. C         STWAY -- Storage for backup capability, called by
  11861. C                   BVPOR and REORT
  11862. C
  11863. C         STOR1 -- Storage at output points, called by BVPOR,
  11864. C                  RKFAB, REORT and STWAY.
  11865. C
  11866. C         SDOT -- Single precision vector inner product routine,
  11867. C                   called by BVPOR, SCOEF, LSSUDS, MGSBV,
  11868. C                   BKSOL, REORT and PRVEC.
  11869. C         ** NOTE **
  11870. C         A considerable improvement in speed can be achieved if a
  11871. C         machine language version is used for SDOT.
  11872. C
  11873. C         SCOEF -- Computes the superposition constants from the
  11874. C                  boundary conditions at Xfinal.
  11875. C
  11876. C         BKSOL -- Solves an upper triangular set of linear equations.
  11877. C
  11878. C **********************************************************************
  11879. C
  11880. C***SEE ALSO  BVSUP
  11881. C***ROUTINES CALLED  BKSOL, LSSUDS, RKFAB, SCOEF, SDOT, STOR1, STWAY,
  11882. C                    SVECS
  11883. C***COMMON BLOCKS    ML15TO, ML18JR, ML8SZ
  11884. C***REVISION HISTORY  (YYMMDD)
  11885. C   750601  DATE WRITTEN
  11886. C   890531  Changed all specific intrinsics to generic.  (WRB)
  11887. C   890831  Modified array declarations.  (WRB)
  11888. C   890921  Realigned order of variables in certain COMMON blocks.
  11889. C           (WRB)
  11890. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  11891. C   900328  Added TYPE section.  (WRB)
  11892. C   910722  Updated AUTHOR section.  (ALS)
  11893. C***END PROLOGUE  BVPOR
  11894. C
  11895.       DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),
  11896.      1          BETA(*),P(NTP,*),IP(NFCC,*),
  11897.      2          U(NCOMP,NFC,*),V(NCOMP,*),W(NFCC,*),
  11898.      3          COEF(*),Z(*),YHP(NCOMP,*),XPTS(*),S(*),
  11899.      4          WORK(*),IWORK(*),STOWA(*),G(*)
  11900. C
  11901. C **********************************************************************
  11902. C
  11903.       COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD
  11904.       COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
  11905.      1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
  11906.       COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NICD,NOPG,MXNOND,NDISK,NTAPE,
  11907.      1                NEQ,INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD,
  11908.      2                ICOCO
  11909. C
  11910. C **********************************************************************
  11911. C
  11912. C***FIRST EXECUTABLE STATEMENT  BVPOR
  11913.       NFCP1 = NFC + 1
  11914.       NUMORT = 0
  11915.       C = 1.0
  11916. C
  11917. C **********************************************************************
  11918. C     CALCULATE INITIAL CONDITIONS WHICH SATISFY
  11919. C                   A*YH(XINITIAL)=0  AND  A*YP(XINITIAL)=ALPHA.
  11920. C     WHEN NFC .NE. NFCC LSSUDS DEFINES VALUES YHP IN A MATRIX OF SIZE
  11921. C     (NFCC+1)*NCOMP AND ,HENCE, OVERFLOWS THE STORAGE ALLOCATION INTO
  11922. C     THE U ARRAY. HOWEVER, THIS IS OKAY SINCE PLENTY OF SPACE IS
  11923. C     AVAILABLE IN U AND IT HAS NOT YET BEEN USED.
  11924. C
  11925.       NDW = NROWA * NCOMP
  11926.       KWS = NDW + NIC + 1
  11927.       KWD = KWS + NIC
  11928.       KWT = KWD + NIC
  11929.       KWC = KWT + NIC
  11930.       IFLAG = 0
  11931.       CALL LSSUDS(A,YHP(1,NFCC+1),ALPHA,NIC,NCOMP,NROWA,YHP,NCOMP,
  11932.      1            IFLAG,1,IRA,0,WORK(1),WORK(NDW+1),IWORK,WORK(KWS),
  11933.      2            WORK(KWD),WORK(KWT),ISFLG,WORK(KWC))
  11934.       IF (IFLAG .EQ. 1) GO TO 3
  11935.       IFLAG=-4
  11936.       GO TO 250
  11937.     3 IF (NFC .NE. NFCC) CALL SVECS(NCOMP,NFC,YHP,WORK,IWORK,
  11938.      1                   INHOMO,IFLAG)
  11939.       IF (IFLAG .EQ. 1)  GO TO 5
  11940.       IFLAG=-5
  11941.       GO TO 250
  11942. C
  11943. C **********************************************************************
  11944. C     DETERMINE THE NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED,
  11945. C     INITIALIZE VARIABLES FOR AUXILIARY INITIAL VALUE PROBLEM AND
  11946. C     STORE INITIAL CONDITIONS.
  11947. C
  11948.     5 NEQ = NCOMP * NFC
  11949.       IF (INHOMO .EQ. 1)  NEQ = NEQ + NCOMP
  11950.       IVP = 0
  11951.       IF (NEQIVP .EQ. 0)  GO TO 10
  11952.       IVP = NEQ
  11953.       NEQ = NEQ + NEQIVP
  11954.       NFCP2 = NFCP1
  11955.       IF (INHOMO .EQ. 1)  NFCP2 = NFCP1 + 1
  11956.       DO 7 K = 1,NEQIVP
  11957.     7 YHP(K,NFCP2) = ALPHA(NIC+K)
  11958.    10 CALL STOR1(U,YHP,V,YHP(1,NFCP1),0,NDISK,NTAPE)
  11959. C
  11960. C **********************************************************************
  11961. C     SET UP DATA FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND
  11962. C     SAVE INITIAL CONDITIONS IN CASE A RESTART IS NECESSARY.
  11963. C
  11964.       NSWOT=1
  11965.       KNSWOT=0
  11966.       LOTJP=1
  11967.       TND=LOG10(10.*TOL)
  11968.       PWCND=LOG10(SQRT(TOL))
  11969.       X=XBEG
  11970.       PX=X
  11971.       XOT=XEND
  11972.       XOP=X
  11973.       KOP=1
  11974.       CALL STWAY(U,V,YHP,0,STOWA)
  11975. C
  11976. C **********************************************************************
  11977. C ******** FORWARD INTEGRATION OF ALL INITIAL VALUE EQUATIONS **********
  11978. C **********************************************************************
  11979. C
  11980.       CALL RKFAB(NCOMP,XPTS,NXPTS,NFC,IFLAG,Z,MXNON,P,NTP,IP,
  11981.      1            YHP,NIV,U,V,W,S,STOWA,G,WORK,IWORK,NFCC)
  11982.       IF (IFLAG .NE. 0  .OR.  ICOCO .EQ. 0)  GO TO 250
  11983. C
  11984. C **********************************************************************
  11985. C **************** BACKWARD SWEEP TO OBTAIN SOLUTION *******************
  11986. C **********************************************************************
  11987. C
  11988. C     CALCULATE SUPERPOSITION COEFFICIENTS AT XFINAL.
  11989. C
  11990. C   FOR THE DISK STORAGE VERSION, IT IS NOT NECESSARY TO READ  U  AND  V
  11991. C   AT THE LAST OUTPUT POINT, SINCE THE LOCAL COPY OF EACH STILL EXISTS.
  11992. C
  11993.       KOD = 1
  11994.       IF (NDISK .EQ. 0)  KOD = NXPTS
  11995.       I1=1+NFCC*NFCC
  11996.       I2=I1+NFCC
  11997.       CALL SCOEF(U(1,1,KOD),V(1,KOD),NCOMP,NROWB,NFC,NIC,B,BETA,COEF,
  11998.      1           INHOMO,RE,AE,WORK,WORK(I1),WORK(I2),IWORK,IFLAG,NFCC)
  11999. C
  12000. C **********************************************************************
  12001. C     CALCULATE SOLUTION AT OUTPUT POINTS BY RECURRING BACKWARDS.
  12002. C     AS WE RECUR BACKWARDS FROM XFINAL TO XINITIAL WE MUST CALCULATE
  12003. C     NEW SUPERPOSITION COEFFICIENTS EACH TIME WE CROSS A POINT OF
  12004. C     ORTHONORMALIZATION.
  12005. C
  12006.       K = NUMORT
  12007.       NCOMP2=NCOMP/2
  12008.       IC=1
  12009.       IF (NFC .NE. NFCC) IC=2
  12010.       DO 200 J = 1,NXPTS
  12011.       KPTS = NXPTS - J + 1
  12012.       KOD = KPTS
  12013.       IF (NDISK .EQ. 1)  KOD = 1
  12014.   135 IF (K .EQ. 0)  GO TO 170
  12015.       IF (XEND.GT.XBEG .AND. XPTS(KPTS).GE.Z(K))  GO TO 170
  12016.       IF (XEND.LT.XBEG .AND. XPTS(KPTS).LE.Z(K))  GO TO 170
  12017.       NON = K
  12018.       IF (NDISK .EQ. 0)  GO TO 136
  12019.       NON = 1
  12020.       BACKSPACE NTAPE
  12021.       READ (NTAPE) (IP(I,1), I = 1,NFCC),(P(I,1), I = 1,NTP)
  12022.       BACKSPACE NTAPE
  12023.   136 IF (INHOMO .NE. 1)  GO TO 150
  12024.       IF (NDISK .EQ. 0)  GO TO 138
  12025.       BACKSPACE NTAPE
  12026.       READ (NTAPE) (W(I,1), I = 1,NFCC)
  12027.       BACKSPACE NTAPE
  12028.   138 DO 140 N = 1,NFCC
  12029.   140 COEF(N) = COEF(N) - W(N,NON)
  12030.   150 CALL BKSOL(NFCC,P(1,NON),COEF)
  12031.       DO 155 M = 1,NFCC
  12032.   155 WORK(M) = COEF(M)
  12033.       DO 160 M = 1,NFCC
  12034.       L = IP(M,NON)
  12035.   160 COEF(L) = WORK(M)
  12036.       K = K - 1
  12037.       GO TO 135
  12038.   170 IF (NDISK .EQ. 0)  GO TO 175
  12039.       BACKSPACE NTAPE
  12040.       READ (NTAPE) (V(I,1), I = 1,NCOMP),
  12041.      1             ((U(I,M,1), I = 1,NCOMP), M = 1,NFC)
  12042.       BACKSPACE NTAPE
  12043.   175 DO 180 N = 1,NCOMP
  12044.   180 Y(N,KPTS) = V(N,KOD) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF,IC)
  12045.       IF (NFC .EQ. NFCC) GO TO 200
  12046.       DO 190 N=1,NCOMP2
  12047.       NN=NCOMP2+N
  12048.       Y(N,KPTS)=Y(N,KPTS) - SDOT(NFC,U(NN,1,KOD),NCOMP,COEF(2),2)
  12049.   190 Y(NN,KPTS)=Y(NN,KPTS) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF(2),2)
  12050.   200 CONTINUE
  12051. C
  12052. C **********************************************************************
  12053. C
  12054.   250 MXNON = NUMORT
  12055.       RETURN
  12056.       END
  12057. *DECK BVSUP
  12058.       SUBROUTINE BVSUP (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA,
  12059.      +   NIC, B, NROWB, BETA, NFC, IGOFX, RE, AE, IFLAG, WORK, NDW,
  12060.      +   IWORK, NDIW, NEQIVP)
  12061. C***BEGIN PROLOGUE  BVSUP
  12062. C***PURPOSE  Solve a linear two-point boundary value problem using
  12063. C            superposition coupled with an orthonormalization procedure
  12064. C            and a variable-step integration scheme.
  12065. C***LIBRARY   SLATEC
  12066. C***CATEGORY  I1B1
  12067. C***TYPE      SINGLE PRECISION (BVSUP-S, DBVSUP-D)
  12068. C***KEYWORDS  ORTHONORMALIZATION, SHOOTING,
  12069. C             TWO-POINT BOUNDARY VALUE PROBLEM
  12070. C***AUTHOR  Scott, M. R., (SNLA)
  12071. C           Watts, H. A., (SNLA)
  12072. C***DESCRIPTION
  12073. C
  12074. C **********************************************************************
  12075. C     Subroutine BVSUP solves a LINEAR two-point boundary-value problem
  12076. C     of the form
  12077. C                        dY/dX = MATRIX(X,U)*Y(X) + G(X,U)
  12078. C                A*Y(Xinitial) = ALPHA ,  B*Y(Xfinal) = BETA
  12079. C
  12080. C     Coupled with the solution of the initial value problem
  12081. C
  12082. C                        dU/dX = F(X,U)
  12083. C                      U(Xinitial) = ETA
  12084. C
  12085. C **********************************************************************
  12086. C     Abstract
  12087. C        The method of solution uses superposition coupled with an
  12088. C     orthonormalization procedure and a variable-step integration
  12089. C     scheme.  Each time the superposition solutions start to
  12090. C     lose their numerical linear independence, the vectors are
  12091. C     reorthonormalized before integration proceeds.  The underlying
  12092. C     principle of the algorithm is then to piece together the
  12093. C     intermediate (orthogonalized) solutions, defined on the various
  12094. C     subintervals, to obtain the desired solutions.
  12095. C
  12096. C **********************************************************************
  12097. C     INPUT to BVSUP
  12098. C **********************************************************************
  12099. C
  12100. C     NROWY = Actual row dimension of Y in calling program.
  12101. C             NROWY must be .GE. NCOMP
  12102. C
  12103. C     NCOMP = Number of components per solution vector.
  12104. C             NCOMP is equal to number of original differential
  12105. C             equations.  NCOMP = NIC + NFC.
  12106. C
  12107. C     XPTS = Desired output points for solution. They must be monotonic.
  12108. C            Xinitial = XPTS(1)
  12109. C            Xfinal = XPTS(NXPTS)
  12110. C
  12111. C     NXPTS = Number of output points
  12112. C
  12113. C     A(NROWA,NCOMP) = Boundary condition matrix at Xinitial,
  12114. C                      must be contained in (NIC,NCOMP) sub-matrix.
  12115. C
  12116. C     NROWA = Actual row dimension of A in calling program,
  12117. C             NROWA must be .GE. NIC.
  12118. C
  12119. C     ALPHA(NIC+NEQIVP) = Boundary conditions at Xinitial.
  12120. C                         If NEQIVP .GT. 0 (see below), the boundary
  12121. C                         conditions at Xinitial for the initial value
  12122. C                         equations must be stored starting in
  12123. C                         position (NIC + 1) of ALPHA.
  12124. C                         Thus,  ALPHA(NIC+K) = ETA(K).
  12125. C
  12126. C     NIC = Number of boundary conditions at Xinitial.
  12127. C
  12128. C     B(NROWB,NCOMP) = Boundary condition matrix at Xfinal,
  12129. C                      must be contained in (NFC,NCOMP) sub-matrix.
  12130. C
  12131. C     NROWB = Actual row dimension of B in calling program,
  12132. C             NROWB must be .GE. NFC.
  12133. C
  12134. C     BETA(NFC) = Boundary conditions at Xfinal.
  12135. C
  12136. C     NFC = Number of boundary conditions at Xfinal
  12137. C
  12138. C     IGOFX =0 -- The inhomogeneous term G(X) is identically zero.
  12139. C           =1 -- The inhomogeneous term G(X) is not identically zero.
  12140. C                 (if IGOFX=1, then subroutine GVEC (or UVEC) must be
  12141. C                  supplied).
  12142. C
  12143. C     RE = Relative error tolerance used by the integrator
  12144. C          (see one of the integrators)
  12145. C
  12146. C     AE = Absolute error tolerance used by the integrator
  12147. C          (see one of the integrators)
  12148. C **NOTE-  RE and AE should not both be zero.
  12149. C
  12150. C     IFLAG = A status parameter used principally for output.
  12151. C             However, for efficient solution of problems which
  12152. C             are originally defined as complex valued (but
  12153. C             converted to real systems to use this code), the
  12154. C             user must set IFLAG=13 on input. See the comment below
  12155. C             for more information on solving such problems.
  12156. C
  12157. C     WORK(NDW) = Floating point array used for internal storage.
  12158. C
  12159. C     NDW = Actual dimension of WORK array allocated by user.
  12160. C           An estimate for NDW can be computed from the following
  12161. C            NDW = 130 + NCOMP**2 * (6 + NXPTS/2 + expected number of
  12162. C                                                orthonormalizations/8)
  12163. C             For the DISK or TAPE storage mode,
  12164. C            NDW = 6 * NCOMP**2 + 10 * NCOMP + 130
  12165. C  However, when the ADAMS integrator is to be used, the estimates are
  12166. C            NDW = 130 + NCOMP**2 * (13 + NXPTS/2 + expected number of
  12167. C                                                orthonormalizations/8)
  12168. C    and     NDW = 13 * NCOMP**2 + 22 * NCOMP + 130   , respectively.
  12169. C
  12170. C     IWORK(NDIW) = Integer array used for internal storage.
  12171. C
  12172. C     NDIW = Actual dimension of IWORK array allocated by user.
  12173. C            An estimate for NDIW can be computed from the following
  12174. C            NDIW = 68 + NCOMP * (1 + expected number of
  12175. C                                        orthonormalizations)
  12176. C **NOTE --  The amount of storage required is problem dependent and may
  12177. C            be difficult to predict in advance. Experience has shown
  12178. C            that for most problems 20 or fewer orthonormalizations
  12179. C            should suffice. If the problem cannot be completed with the
  12180. C            allotted storage, then a message will be printed which
  12181. C            estimates the amount of storage necessary. In any case, the
  12182. C            user can examine the IWORK array for the actual storage
  12183. C            requirements, as described in the output information below.
  12184. C
  12185. C     NEQIVP = Number of auxiliary initial value equations being added
  12186. C              to the boundary value problem.
  12187. C **NOTE -- Occasionally the coefficients  MATRIX  and/or  G  may be
  12188. C           functions which depend on the independent variable  X  and
  12189. C           on  U, the solution of an auxiliary initial value problem.
  12190. C           In order to avoid the difficulties associated with
  12191. C           interpolation, the auxiliary equations may be solved
  12192. C           simultaneously with the given boundary value problem.
  12193. C           This initial value problem may be LINEAR or NONLINEAR.
  12194. C                 See SAND77-1328 for an example.
  12195. C
  12196. C
  12197. C     The user must supply subroutines FMAT, GVEC, UIVP and UVEC, when
  12198. C     needed (they MUST be so named), to evaluate the derivatives
  12199. C     as follows
  12200. C
  12201. C        A. FMAT must be supplied.
  12202. C
  12203. C              SUBROUTINE FMAT(X,Y,YP)
  12204. C              X = Independent variable (input to FMAT)
  12205. C              Y = Dependent variable vector (input to FMAT)
  12206. C              YP = dY/dX = Derivative vector (output from FMAT)
  12207. C
  12208. C            Compute the derivatives for the HOMOGENEOUS problem
  12209. C              YP(I) = dY(I)/dX = MATRIX(X) * Y(I)  , I = 1,...,NCOMP
  12210. C
  12211. C            When (NEQIVP .GT. 0) and  MATRIX  is dependent on  U  as
  12212. C            well as on  X, the following common statement must be
  12213. C            included in FMAT
  12214. C                    COMMON /MLIVP/ NOFST
  12215. C            For convenience, the  U  vector is stored at the bottom
  12216. C            of the  Y  array.  Thus, during any call to FMAT,
  12217. C            U(I) is referenced by  Y(NOFST + I).
  12218. C
  12219. C
  12220. C            Subroutine BVDER calls FMAT NFC times to evaluate the
  12221. C            homogeneous equations and, if necessary, it calls FMAT once
  12222. C            in evaluating the particular solution. Since X remains
  12223. C            unchanged in this sequence of calls it is possible to
  12224. C            realize considerable computational savings for complicated
  12225. C            and expensive evaluations of the MATRIX entries. To do this
  12226. C            the user merely passes a variable, say XS, via COMMON where
  12227. C            XS is defined in the main program to be any value except
  12228. C            the initial X. Then the non-constant elements of MATRIX(X)
  12229. C            appearing in the differential equations need only be
  12230. C            computed if X is unequal to XS, whereupon XS is reset to X.
  12231. C
  12232. C
  12233. C        B. If  NEQIVP .GT. 0 ,  UIVP must also be supplied.
  12234. C
  12235. C              SUBROUTINE UIVP(X,U,UP)
  12236. C              X = Independent variable (input to UIVP)
  12237. C              U = Dependent variable vector (input to UIVP)
  12238. C              UP = dU/dX = Derivative vector (output from UIVP)
  12239. C
  12240. C            Compute the derivatives for the auxiliary initial value eqs
  12241. C              UP(I) = dU(I)/dX, I = 1,...,NEQIVP.
  12242. C
  12243. C            Subroutine BVDER calls UIVP once to evaluate the
  12244. C            derivatives for the auxiliary initial value equations.
  12245. C
  12246. C
  12247. C        C. If  NEQIVP = 0  and  IGOFX = 1 ,  GVEC must be supplied.
  12248. C
  12249. C              SUBROUTINE GVEC(X,G)
  12250. C              X = Independent variable (input to GVEC)
  12251. C              G = Vector of inhomogeneous terms G(X) (output from GVEC)
  12252. C
  12253. C            Compute the inhomogeneous terms G(X)
  12254. C                G(I) = G(X) values for I = 1,...,NCOMP.
  12255. C
  12256. C            Subroutine BVDER calls GVEC in evaluating the particular
  12257. C            solution provided G(X) is NOT identically zero. Thus, when
  12258. C            IGOFX=0, the user need NOT write a GVEC subroutine. Also,
  12259. C            the user does not have to bother with the computational
  12260. C            savings scheme for GVEC as this is automatically achieved
  12261. C            via the BVDER subroutine.
  12262. C
  12263. C
  12264. C        D. If  NEQIVP .GT. 0  and  IGOFX = 1 ,  UVEC must be supplied.
  12265. C
  12266. C              SUBROUTINE UVEC(X,U,G)
  12267. C              X = Independent variable (input to UVEC)
  12268. C              U = Dependent variable vector from the auxiliary initial
  12269. C                  value problem    (input to UVEC)
  12270. C              G = Array of inhomogeneous terms G(X,U)(output from UVEC)
  12271. C
  12272. C            Compute the inhomogeneous terms G(X,U)
  12273. C                G(I) = G(X,U) values for I = 1,...,NCOMP.
  12274. C
  12275. C            Subroutine BVDER calls UVEC in evaluating the particular
  12276. C            solution provided G(X,U) is NOT identically zero.  Thus,
  12277. C            when IGOFX=0, the user need NOT write a UVEC subroutine.
  12278. C
  12279. C
  12280. C
  12281. C     The following is optional input to BVSUP to give the user more
  12282. C     flexibility in use of the code.  See SAND75-0198 , SAND77-1328 ,
  12283. C     SAND77-1690,SAND78-0522, and SAND78-1501 for more information.
  12284. C
  12285. C ****CAUTION -- The user MUST zero out IWORK(1),...,IWORK(15)
  12286. C                prior to calling BVSUP. These locations define optional
  12287. C                input and MUST be zero UNLESS set to special values by
  12288. C                the user as described below.
  12289. C
  12290. C     IWORK(1) -- Number of orthonormalization points.
  12291. C                 A value need be set only if IWORK(11) = 1
  12292. C
  12293. C     IWORK(9) -- Integrator and orthonormalization parameter
  12294. C                 (default value is 1)
  12295. C                 1 = RUNGE-KUTTA-FEHLBERG code using GRAM-SCHMIDT test.
  12296. C                 2 = ADAMS code using GRAM-SCHMIDT TEST.
  12297. C
  12298. C     IWORK(11) -- Orthonormalization points parameter
  12299. C                  (default value is 0)
  12300. C                  0 - Orthonormalization points not pre-assigned.
  12301. C                  1 - Orthonormalization points pre-assigned in
  12302. C                      the first IWORK(1) positions of WORK.
  12303. C
  12304. C     IWORK(12) -- Storage parameter
  12305. C                  (default value is 0)
  12306. C                  0 - All storage IN CORE
  12307. C                LUN - Homogeneous and inhomogeneous solutions at
  12308. C                     output points and orthonormalization information
  12309. C                     are stored on DISK.  The logical unit number to be
  12310. C                     used for DISK I/O (NTAPE) is set to IWORK(12).
  12311. C
  12312. C     WORK(1),... -- Pre-assigned orthonormalization points, stored
  12313. C                    monotonically, corresponding to the direction
  12314. C                    of integration.
  12315. C
  12316. C
  12317. C
  12318. C                 ******************************
  12319. C                 *** COMPLEX VALUED PROBLEM ***
  12320. C                 ******************************
  12321. C **NOTE***
  12322. C       Suppose the original boundary value problem is NC equations
  12323. C     of the form
  12324. C                   dW/dX = MAT(X,U)*W(X) + H(X,U)
  12325. C                 R*W(Xinitial)=GAMMA , S*W(Xfinal)=DELTA
  12326. C
  12327. C     where all variables are complex valued. The BVSUP code can be
  12328. C     used by converting to a real system of size 2*NC. To solve the
  12329. C     larger dimensioned problem efficiently,  the user must initialize
  12330. C     IFLAG=13 on input and order the vector components according to
  12331. C     Y(1)=real(W(1)),...,Y(NC)=real(W(NC)),Y(NC+1)=imag(W(1)),....,
  12332. C     Y(2*NC)=imag(W(NC)). Then define
  12333. C                        ...........................
  12334. C                        . real(MAT)    -imag(MAT) .
  12335. C            MATRIX  =   .                         .
  12336. C                        . imag(MAT)     real(MAT) .
  12337. C                        ...........................
  12338. C
  12339. C     The matrices A,B and vectors G,ALPHA,BETA must be defined
  12340. C     similarly. Further details can be found in SAND78-1501.
  12341. C
  12342. C
  12343. C **********************************************************************
  12344. C     OUTPUT from BVSUP
  12345. C **********************************************************************
  12346. C
  12347. C     Y(NROWY,NXPTS) = Solution at specified output points.
  12348. C
  12349. C     IFLAG output values
  12350. C            =-5 Algorithm ,for obtaining starting vectors for the
  12351. C                special complex problem structure, was unable to obtain
  12352. C                the initial vectors satisfying the necessary
  12353. C                independence criteria.
  12354. C            =-4 Rank of boundary condition matrix A is less than NIC,
  12355. C                as determined by LSSUDS.
  12356. C            =-2 Invalid input parameters.
  12357. C            =-1 Insufficient number of storage locations allocated for
  12358. C                WORK or IWORK.
  12359. C
  12360. C            =0 Indicates successful solution
  12361. C
  12362. C            =1 A computed solution is returned but UNIQUENESS of the
  12363. C               solution of the boundary-value problem is questionable.
  12364. C               For an eigenvalue problem, this should be treated as a
  12365. C               successful execution since this is the expected mode
  12366. C               of return.
  12367. C            =2 A computed solution is returned but the EXISTENCE of the
  12368. C               solution to the boundary-value problem is questionable.
  12369. C            =3 A nontrivial solution approximation is returned although
  12370. C               the boundary condition matrix B*Y(Xfinal) is found to be
  12371. C               nonsingular (to the desired accuracy level) while the
  12372. C               right hand side vector is zero. To eliminate this type
  12373. C               of return, the accuracy of the eigenvalue parameter
  12374. C               must be improved.
  12375. C           ***NOTE- We attempt to diagnose the correct problem behavior
  12376. C               and report possible difficulties by the appropriate
  12377. C               error flag.  However, the user should probably resolve
  12378. C               the problem using smaller error tolerances and/or
  12379. C               perturbations in the boundary conditions or other
  12380. C               parameters. This will often reveal the correct
  12381. C               interpretation for the problem posed.
  12382. C
  12383. C            =13 Maximum number of orthonormalizations attained before
  12384. C                reaching Xfinal.
  12385. C            =20-flag from integrator (DERKF or DEABM) values can range
  12386. C                from 21 to 25.
  12387. C            =30 Solution vectors form a dependent set.
  12388. C
  12389. C     WORK(1),...,WORK(IWORK(1)) = Orthonormalization points
  12390. C                                  determined by BVPOR.
  12391. C
  12392. C     IWORK(1) = Number of orthonormalizations performed by BVPOR.
  12393. C
  12394. C     IWORK(2) = Maximum number of orthonormalizations allowed as
  12395. C                calculated from storage allocated by user.
  12396. C
  12397. C     IWORK(3),IWORK(4),IWORK(5),IWORK(6)   Give information about
  12398. C                actual storage requirements for WORK and IWORK
  12399. C                arrays.  In particular,
  12400. C                       required storage for  WORK array is
  12401. C        IWORK(3) + IWORK(4)*(expected number of orthonormalizations)
  12402. C
  12403. C                       required storage for IWORK array is
  12404. C        IWORK(5) + IWORK(6)*(expected number of orthonormalizations)
  12405. C
  12406. C     IWORK(8) = Final value of exponent parameter used in tolerance
  12407. C                test for orthonormalization.
  12408. C
  12409. C     IWORK(16) = Number of independent vectors returned from MGSBV.
  12410. C                 It is only of interest when IFLAG=30 is obtained.
  12411. C
  12412. C     IWORK(17) = Numerically estimated rank of the boundary
  12413. C                 condition matrix defined from B*Y(Xfinal)
  12414. C
  12415. C **********************************************************************
  12416. C
  12417. C     Necessary machine constants are defined in the function
  12418. C     routine R1MACH. The user must make sure that the values
  12419. C     set in R1MACH are relevant to the computer being used.
  12420. C
  12421. C **********************************************************************
  12422. C
  12423. C***REFERENCES  M. R. Scott and H. A. Watts, SUPORT - a computer code
  12424. C                 for two-point boundary-value problems via
  12425. C                 orthonormalization, SIAM Journal of Numerical
  12426. C                 Analysis 14, (1977), pp. 40-70.
  12427. C               B. L. Darlow, M. R. Scott and H. A. Watts, Modifications
  12428. C                 of SUPORT, a linear boundary value problem solver
  12429. C                 Part I - pre-assigning orthonormalization points,
  12430. C                 auxiliary initial value problem, disk or tape storage,
  12431. C                 Report SAND77-1328, Sandia Laboratories, Albuquerque,
  12432. C                 New Mexico, 1977.
  12433. C               B. L. Darlow, M. R. Scott and H. A. Watts, Modifications
  12434. C                 of SUPORT, a linear boundary value problem solver
  12435. C                 Part II - inclusion of an Adams integrator, Report
  12436. C                 SAND77-1690, Sandia Laboratories, Albuquerque,
  12437. C                 New Mexico, 1977.
  12438. C               M. E. Lord and H. A. Watts, Modifications of SUPORT,
  12439. C                 a linear boundary value problem solver Part III -
  12440. C                 orthonormalization improvements, Report SAND78-0522,
  12441. C                 Sandia Laboratories, Albuquerque, New Mexico, 1978.
  12442. C               H. A. Watts, M. R. Scott and M. E. Lord, Computational
  12443. C                 solution of complex*16 valued boundary problems,
  12444. C                 Report SAND78-1501, Sandia Laboratories,
  12445. C                 Albuquerque, New Mexico, 1978.
  12446. C***ROUTINES CALLED  EXBVP, MACON, XERMSG
  12447. C***COMMON BLOCKS    ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ
  12448. C***REVISION HISTORY  (YYMMDD)
  12449. C   750601  DATE WRITTEN
  12450. C   890531  Changed all specific intrinsics to generic.  (WRB)
  12451. C   890831  Modified array declarations.  (WRB)
  12452. C   890921  Realigned order of variables in certain COMMON blocks.
  12453. C           (WRB)
  12454. C   890921  REVISION DATE from Version 3.2
  12455. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  12456. C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
  12457. C   920501  Reformatted the REFERENCES section.  (WRB)
  12458. C***END PROLOGUE  BVSUP
  12459. C **********************************************************************
  12460. C
  12461. C
  12462.       DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),
  12463.      1          BETA(*),WORK(*),IWORK(*),XPTS(*)
  12464.       CHARACTER*8 XERN1, XERN2, XERN3, XERN4
  12465. C
  12466. C **********************************************************************
  12467. C     THE COMMON BLOCK BELOW IS USED TO COMMUNICATE WITH SUBROUTINE
  12468. C     BVDER.  THE USER SHOULD NOT ALTER OR USE THIS COMMON BLOCK IN THE
  12469. C     CALLING PROGRAM.
  12470. C
  12471.       COMMON /ML8SZ/ C,XSAV,IGOFXD,INHOMO,IVP,NCOMPD,NFCD
  12472. C
  12473. C **********************************************************************
  12474. C     THESE COMMON BLOCKS AID IN REDUCING THE NUMBER OF SUBROUTINE
  12475. C     ARGUMENTS PREVALENT IN THIS MODULAR STRUCTURE
  12476. C
  12477.       COMMON /ML18JR/ AED,RED,TOL,NXPTSD,NICD,NOPG,MXNON,NDISK,NTAPE,
  12478.      1                NEQ,INDPVT,INTEG,NPS,NTP,NEQIVD,NUMORT,NFCC,
  12479.      2                ICOCO
  12480.       COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9,
  12481.      1                K10,K11,L1,L2,KKKINT,LLLINT
  12482. C
  12483. C **********************************************************************
  12484. C     THIS COMMON BLOCK IS USED IN SUBROUTINES BVSUP,BVPOR,RKFAB,
  12485. C     REORT, AND STWAY. IT CONTAINS INFORMATION NECESSARY
  12486. C     FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND A BACKUP
  12487. C     RESTARTING CAPABILITY.
  12488. C
  12489.       COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
  12490.      1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
  12491. C
  12492. C **********************************************************************
  12493. C     THIS COMMON BLOCK CONTAINS THE MACHINE DEPENDENT PARAMETERS
  12494. C     USED BY THE CODE
  12495. C
  12496.       COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR
  12497. C
  12498. C **********************************************************************
  12499. C     SET UP MACHINE DEPENDENT CONSTANTS.
  12500. C
  12501. C***FIRST EXECUTABLE STATEMENT  BVSUP
  12502.       CALL MACON
  12503. C
  12504. C **********************************************************************
  12505. C     TEST FOR INVALID INPUT
  12506. C
  12507.       IF (NROWY .LT. NCOMP)  GO TO 20
  12508.       IF (NCOMP .NE. NIC+NFC)  GO TO 20
  12509.       IF (NXPTS .LT. 2)  GO TO 20
  12510.       IF (NIC .LE. 0)  GO TO 20
  12511.       IF (NROWA .LT. NIC)  GO TO 20
  12512.       IF (NFC .LE. 0)  GO TO 20
  12513.       IF (NROWB .LT. NFC)  GO TO 20
  12514.       IF (IGOFX .LT. 0  .OR.  IGOFX .GT. 1) GO TO 20
  12515.       IF (RE .LT. 0.0)  GO TO 20
  12516.       IF (AE .LT. 0.0)  GO TO 20
  12517.       IF (RE .EQ. 0.0  .AND.  AE .EQ. 0.0)  GO TO 20
  12518.       IS = 1
  12519.       IF (XPTS(NXPTS) .LT. XPTS(1))  IS = 2
  12520.       NXPTSM = NXPTS - 1
  12521.       DO 13 K = 1,NXPTSM
  12522.       IF (IS .EQ. 2) GO TO 12
  12523.       IF (XPTS(K+1) .LE. XPTS(K))  GO TO 20
  12524.       GO TO 13
  12525.    12 IF (XPTS(K) .LE. XPTS(K+1))  GO TO 20
  12526.    13 CONTINUE
  12527.       GO TO 30
  12528.    20 IFLAG = -2
  12529.       RETURN
  12530.    30 CONTINUE
  12531. C
  12532. C **********************************************************************
  12533. C     CHECK FOR DISK STORAGE
  12534. C
  12535.       KPTS = NXPTS
  12536.       NDISK = 0
  12537.       IF (IWORK(12) .EQ. 0)  GO TO 35
  12538.       NTAPE = IWORK(12)
  12539.       KPTS = 1
  12540.       NDISK = 1
  12541.    35 CONTINUE
  12542. C
  12543. C **********************************************************************
  12544. C     SET INTEG PARAMETER ACCORDING TO CHOICE OF INTEGRATOR.
  12545. C
  12546.       INTEG = 1
  12547.       IF (IWORK(9) .EQ. 2)  INTEG = 2
  12548. C
  12549. C **********************************************************************
  12550. C     COMPUTE INHOMO
  12551. C
  12552.       IF (IGOFX .EQ. 1)  GO TO 43
  12553.       DO 40 J = 1,NIC
  12554.       IF (ALPHA(J) .NE. 0.0)  GO TO 43
  12555.    40 CONTINUE
  12556.       DO 41 J = 1,NFC
  12557.       IF (BETA(J) .NE. 0.0)  GO TO 42
  12558.    41 CONTINUE
  12559.       INHOMO = 3
  12560.       GO TO 45
  12561.    42 INHOMO = 2
  12562.       GO TO 45
  12563.    43 INHOMO = 1
  12564.    45 CONTINUE
  12565. C
  12566. C **********************************************************************
  12567. C     TO TAKE ADVANTAGE OF THE SPECIAL STRUCTURE WHEN SOLVING A
  12568. C     COMPLEX VALUED PROBLEM,WE INTRODUCE NFCC=NFC WHILE CHANGING
  12569. C     THE INTERNAL VALUE OF NFC
  12570. C
  12571.       NFCC=NFC
  12572.       IF (IFLAG .EQ. 13) NFC=NFC/2
  12573. C
  12574. C **********************************************************************
  12575. C     DETERMINE NECESSARY STORAGE REQUIREMENTS
  12576. C
  12577. C FOR BASIC ARRAYS IN BVPOR
  12578.       KKKYHP = NCOMP*(NFC+1) + NEQIVP
  12579.       KKKU   = NCOMP*NFC*KPTS
  12580.       KKKV   = NCOMP*KPTS
  12581.       KKKCOE = NFCC
  12582.       KKKS   = NFC+1
  12583.       KKKSTO = NCOMP*(NFC+1) + NEQIVP + 1
  12584.       KKKG   = NCOMP
  12585. C
  12586. C FOR ORTHONORMALIZATION RELATED MATTERS
  12587.       NTP = (NFCC*(NFCC+1))/2
  12588.       KKKZPW = 1 + NTP + NFCC
  12589.       LLLIP  = NFCC
  12590. C
  12591. C FOR ADDITIONAL REQUIRED WORK SPACE
  12592. C   (LSSUDS)
  12593.       KKKSUD = 4*NIC + (NROWA+1)*NCOMP
  12594.       LLLSUD = NIC
  12595. C   (SVECS)
  12596.       KKKSVC = 1 + 4*NFCC + 2*NFCC**2
  12597.       LLLSVC = 2*NFCC
  12598. C
  12599.       NDEQ=NCOMP*NFC+NEQIVP
  12600.       IF (INHOMO .EQ. 1) NDEQ=NDEQ+NCOMP
  12601.       GO TO (51,52),INTEG
  12602. C   (DERKF)
  12603.    51 KKKINT = 33 + 7*NDEQ
  12604.       LLLINT = 34
  12605.       GO TO 55
  12606. C   (DEABM)
  12607.    52 KKKINT = 130 + 21*NDEQ
  12608.       LLLINT = 51
  12609. C
  12610. C   (COEF)
  12611.    55 KKKCOF = 5*NFCC + NFCC**2
  12612.       LLLCOF = 3 + NFCC
  12613. C
  12614.       KKKWS  = MAX(KKKSUD,KKKSVC,KKKINT,KKKCOF)
  12615.       LLLIWS = MAX(LLLSUD,LLLSVC,LLLINT,LLLCOF)
  12616. C
  12617.       NEEDW  = KKKYHP + KKKU + KKKV + KKKCOE + KKKS + KKKSTO + KKKG +
  12618.      1         KKKZPW + KKKWS
  12619.       NEEDIW = 17 + LLLIP + LLLIWS
  12620. C **********************************************************************
  12621. C     COMPUTE THE NUMBER OF POSSIBLE ORTHONORMALIZATIONS WITH THE
  12622. C     ALLOTTED STORAGE
  12623. C
  12624.       IWORK(3) = NEEDW
  12625.       IWORK(4) = KKKZPW
  12626.       IWORK(5) = NEEDIW
  12627.       IWORK(6) = LLLIP
  12628.       NRTEMP = NDW - NEEDW
  12629.       NITEMP = NDIW - NEEDIW
  12630.       IF (NRTEMP .LT. 0)  GO TO 70
  12631.       IF (NITEMP .GE. 0)  GO TO 75
  12632. C
  12633.    70 IFLAG = -1
  12634.       IF (NDISK .NE. 1) THEN
  12635.          WRITE (XERN1, '(I8)') NEEDW
  12636.          WRITE (XERN2, '(I8)') KKKZPW
  12637.          WRITE (XERN3, '(I8)') NEEDIW
  12638.          WRITE (XERN4, '(I8)') LLLIP
  12639.          CALL XERMSG ('SLATEC', 'BVSUP',
  12640.      *      'REQUIRED STORAGE FOR WORK ARRAY IS '  // XERN1 // ' + ' //
  12641.      *      XERN2 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS) $$'  //
  12642.      *      'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN3 // ' + ' //
  12643.      *      XERN4 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS)', 1, 0)
  12644.       ELSE
  12645.          WRITE (XERN1, '(I8)') NEEDW
  12646.          WRITE (XERN2, '(I8)') NEEDIW
  12647.          CALL XERMSG ('SLATEC', 'BVSUP',
  12648.      *      'REQUIRED STORAGE FOR WORK ARRAY IS '  // XERN1 //
  12649.      *      ' + NUMBER OF ORTHONOMALIZATIONS. $$'  //
  12650.      *      'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN2, 1, 0)
  12651.       ENDIF
  12652.       RETURN
  12653. C
  12654.    75 IF (NDISK .EQ. 0)  GO TO 77
  12655.       NON = 0
  12656.       MXNON = NRTEMP
  12657.       GO TO 78
  12658. C
  12659.    77 MXNONR = NRTEMP / KKKZPW
  12660.       MXNONI = NITEMP / LLLIP
  12661.       MXNON = MIN(MXNONR,MXNONI)
  12662.       NON = MXNON
  12663. C
  12664.    78 IWORK(2) = MXNON
  12665. C
  12666. C **********************************************************************
  12667. C     CHECK FOR PRE-ASSIGNED ORTHONORMALIZATION POINTS
  12668. C
  12669.       NOPG = 0
  12670.       IF (IWORK(11) .NE. 1)  GO TO 85
  12671.       IF (MXNON .LT. IWORK(1))  GO TO 70
  12672.       NOPG = 1
  12673.       MXNON = IWORK(1)
  12674.       WORK(MXNON+1) = 2. * XPTS(NXPTS)  -  XPTS(1)
  12675.    85 CONTINUE
  12676. C
  12677. C **********************************************************************
  12678. C     ALLOCATE STORAGE FROM WORK AND IWORK ARRAYS
  12679. C
  12680. C  (Z)
  12681.       K1 = 1 + (MXNON+1)
  12682. C  (P)
  12683.       K2 = K1 + NTP*(NON+1)
  12684. C  (W)
  12685.       K3 = K2 + NFCC*(NON+1)
  12686. C  (YHP)
  12687.       K4 = K3 + KKKYHP
  12688. C  (U)
  12689.       K5 = K4 + KKKU
  12690. C  (V)
  12691.       K6 = K5 + KKKV
  12692. C  (COEF)
  12693.       K7 = K6 + KKKCOE
  12694. C  (S)
  12695.       K8 = K7 + KKKS
  12696. C  (STOWA)
  12697.       K9 = K8 + KKKSTO
  12698. C  (G)
  12699.       K10 = K9 + KKKG
  12700.       K11 = K10 + KKKWS
  12701. C            REQUIRED ADDITIONAL REAL WORK SPACE STARTS AT WORK(K10)
  12702. C            AND EXTENDS TO WORK(K11-1)
  12703. C
  12704. C     FIRST 17 LOCATIONS OF IWORK ARE USED FOR OPTIONAL
  12705. C     INPUT AND OUTPUT ITEMS
  12706. C  (IP)
  12707.       L1 = 18 + NFCC*(NON+1)
  12708.       L2 = L1 + LLLIWS
  12709. C            REQUIRED INTEGER WORK SPACE STARTS AT IWORK(L1)
  12710. C            AND EXTENDS TO IWORK(L2-1)
  12711. C
  12712. C **********************************************************************
  12713. C     SET INDICATOR FOR NORMALIZATION OF PARTICULAR SOLUTION
  12714. C
  12715.       NPS = 0
  12716.       IF (IWORK(10) .EQ. 1)  NPS = 1
  12717. C
  12718. C **********************************************************************
  12719. C     SET PIVOTING PARAMETER
  12720. C
  12721.       INDPVT=0
  12722.       IF (IWORK(15) .EQ. 1) INDPVT=1
  12723. C
  12724. C **********************************************************************
  12725. C     SET OTHER COMMON BLOCK PARAMETERS
  12726. C
  12727.       NFCD = NFC
  12728.       NCOMPD = NCOMP
  12729.       IGOFXD = IGOFX
  12730.       NXPTSD = NXPTS
  12731.       NICD = NIC
  12732.       RED = RE
  12733.       AED = AE
  12734.       NEQIVD = NEQIVP
  12735.       MNSWOT = 20
  12736.       IF (IWORK(13) .EQ. -1) MNSWOT=MAX(1,IWORK(14))
  12737.       XBEG=XPTS(1)
  12738.       XEND=XPTS(NXPTS)
  12739.       XSAV=XEND
  12740.       ICOCO=1
  12741.       IF (INHOMO .EQ. 3  .AND.  NOPG .EQ. 1) WORK(MXNON+1)=XEND
  12742. C
  12743. C **********************************************************************
  12744. C
  12745.       CALL EXBVP(Y,NROWY,XPTS,A,NROWA,ALPHA,B,NROWB,BETA,IFLAG,WORK,
  12746.      1           IWORK)
  12747.       NFC=NFCC
  12748.       IWORK(17)=IWORK(L1)
  12749.       RETURN
  12750.       END
  12751. *DECK C0LGMC
  12752.       COMPLEX FUNCTION C0LGMC (Z)
  12753. C***BEGIN PROLOGUE  C0LGMC
  12754. C***PURPOSE  Evaluate (Z+0.5)*LOG((Z+1.)/Z) - 1.0 with relative
  12755. C            accuracy.
  12756. C***LIBRARY   SLATEC (FNLIB)
  12757. C***CATEGORY  C7A
  12758. C***TYPE      COMPLEX (C0LGMC-C)
  12759. C***KEYWORDS  FNLIB, GAMMA FUNCTION, SPECIAL FUNCTIONS
  12760. C***AUTHOR  Fullerton, W., (LANL)
  12761. C***DESCRIPTION
  12762. C
  12763. C Evaluate  (Z+0.5)*LOG((Z+1.0)/Z) - 1.0  with relative error accuracy
  12764. C Let Q = 1.0/Z so that
  12765. C     (Z+0.5)*LOG(1+1/Z) - 1 = (Z+0.5)*(LOG(1+Q) - Q + Q*Q/2) - Q*Q/4
  12766. C        = (Z+0.5)*Q**3*C9LN2R(Q) - Q**2/4,
  12767. C where  C9LN2R  is (LOG(1+Q) - Q + 0.5*Q**2) / Q**3.
  12768. C
  12769. C***REFERENCES  (NONE)
  12770. C***ROUTINES CALLED  C9LN2R, R1MACH
  12771. C***REVISION HISTORY  (YYMMDD)
  12772. C   780401  DATE WRITTEN
  12773. C   890531  Changed all specific intrinsics to generic.  (WRB)
  12774. C   890531  REVISION DATE from Version 3.2
  12775. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  12776. C***END PROLOGUE  C0LGMC
  12777.       COMPLEX Z, Q, C9LN2R
  12778.       SAVE RBIG
  12779.       DATA RBIG / 0.0 /
  12780. C***FIRST EXECUTABLE STATEMENT  C0LGMC
  12781.       IF (RBIG.EQ.0.0) RBIG = 1.0/R1MACH(3)
  12782. C
  12783.       CABSZ = ABS(Z)
  12784.       IF (CABSZ.GT.RBIG) C0LGMC = -(Z+0.5)*LOG(Z) - Z
  12785.       IF (CABSZ.GT.RBIG) RETURN
  12786. C
  12787.       Q = 1.0/Z
  12788.       IF (CABSZ.LE.1.23) C0LGMC = (Z+0.5)*LOG(1.0+Q) - 1.0
  12789.       IF (CABSZ.GT.1.23) C0LGMC = ((1.+.5*Q)*C9LN2R(Q) - .25) * Q**2
  12790. C
  12791.       RETURN
  12792.       END
  12793. *DECK C1MERG
  12794.       SUBROUTINE C1MERG (TCOS, I1, M1, I2, M2, I3)
  12795. C***BEGIN PROLOGUE  C1MERG
  12796. C***SUBSIDIARY
  12797. C***PURPOSE  Merge two strings of complex numbers.  Each string is
  12798. C            ascending by the real part.
  12799. C***LIBRARY   SLATEC
  12800. C***TYPE      COMPLEX (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I)
  12801. C***AUTHOR  (UNKNOWN)
  12802. C***DESCRIPTION
  12803. C
  12804. C   This subroutine merges two ascending strings of numbers in the
  12805. C   array TCOS.  The first string is of length M1 and starts at
  12806. C   TCOS(I1+1).  The second string is of length M2 and starts at
  12807. C   TCOS(I2+1).  The merged string goes into TCOS(I3+1).  The ordering
  12808. C   is on the real part.
  12809. C
  12810. C***SEE ALSO  CMGNBN
  12811. C***ROUTINES CALLED  CCOPY
  12812. C***REVISION HISTORY  (YYMMDD)
  12813. C   801001  DATE WRITTEN
  12814. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  12815. C   900402  Added TYPE section.  (WRB)
  12816. C   910408  Modified to use IF-THEN-ELSE.  Make it look like MERGE
  12817. C           which was modified earlier due to compiler problems on
  12818. C           the IBM RS6000.  (RWC)
  12819. C   920130  Code name changed from CMPMRG to C1MERG.  (WRB)
  12820. C***END PROLOGUE  C1MERG
  12821.       INTEGER I1, I2, I3, M1, M2
  12822.       COMPLEX TCOS(*)
  12823. C
  12824.       INTEGER J1, J2, J3
  12825. C
  12826. C***FIRST EXECUTABLE STATEMENT  C1MERG
  12827.       IF (M1.EQ.0 .AND. M2.EQ.0) RETURN
  12828. C
  12829.       IF (M1.EQ.0 .AND. M2.NE.0) THEN
  12830.          CALL CCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1)
  12831.          RETURN
  12832.       ENDIF
  12833. C
  12834.       IF (M1.NE.0 .AND. M2.EQ.0) THEN
  12835.          CALL CCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1)
  12836.          RETURN
  12837.       ENDIF
  12838. C
  12839.       J1 = 1
  12840.       J2 = 1
  12841.       J3 = 1
  12842. C
  12843.    10 IF (REAL(TCOS(J1+I1)) .LE. REAL(TCOS(I2+J2))) THEN
  12844.          TCOS(I3+J3) = TCOS(I1+J1)
  12845.          J1 = J1+1
  12846.          IF (J1 .GT. M1) THEN
  12847.             CALL CCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1)
  12848.             RETURN
  12849.          ENDIF
  12850.       ELSE
  12851.          TCOS(I3+J3) = TCOS(I2+J2)
  12852.          J2 = J2+1
  12853.          IF (J2 .GT. M2) THEN
  12854.             CALL CCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1)
  12855.             RETURN
  12856.          ENDIF
  12857.       ENDIF
  12858.       J3 = J3+1
  12859.       GO TO 10
  12860.       END
  12861. *DECK C9LGMC
  12862.       COMPLEX FUNCTION C9LGMC (ZIN)
  12863. C***BEGIN PROLOGUE  C9LGMC
  12864. C***SUBSIDIARY
  12865. C***PURPOSE  Compute the log gamma correction factor so that
  12866. C            LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z
  12867. C            + C9LGMC(Z).
  12868. C***LIBRARY   SLATEC (FNLIB)
  12869. C***CATEGORY  C7A
  12870. C***TYPE      COMPLEX (R9LGMC-S, D9LGMC-D, C9LGMC-C)
  12871. C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
  12872. C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
  12873. C***AUTHOR  Fullerton, W., (LANL)
  12874. C***DESCRIPTION
  12875. C
  12876. C Compute the LOG GAMMA correction term for large ABS(Z) when REAL(Z)
  12877. C .GE. 0.0 and for large ABS(AIMAG(Y)) when REAL(Z) .LT. 0.0.  We find
  12878. C C9LGMC so that
  12879. C   LOG(Z) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z)
  12880. C
  12881. C***REFERENCES  (NONE)
  12882. C***ROUTINES CALLED  R1MACH, XERMSG
  12883. C***REVISION HISTORY  (YYMMDD)
  12884. C   780401  DATE WRITTEN
  12885. C   890531  Changed all specific intrinsics to generic.  (WRB)
  12886. C   890531  REVISION DATE from Version 3.2
  12887. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  12888. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  12889. C   900326  Removed duplicate information from DESCRIPTION section.
  12890. C           (WRB)
  12891. C   900720  Routine changed from user-callable to subsidiary.  (WRB)
  12892. C***END PROLOGUE  C9LGMC
  12893.       COMPLEX ZIN, Z, Z2INV
  12894.       DIMENSION BERN(11)
  12895.       LOGICAL FIRST
  12896.       SAVE BERN, NTERM, BOUND, XBIG, XMAX, FIRST
  12897.       DATA BERN( 1) /    .08333333333 3333333E0   /
  12898.       DATA BERN( 2) /   -.002777777777 7777778E0  /
  12899.       DATA BERN( 3) /    .0007936507936 5079365E0 /
  12900.       DATA BERN( 4) /   -.0005952380952 3809524E0 /
  12901.       DATA BERN( 5) /    .0008417508417 5084175E0 /
  12902.       DATA BERN( 6) /   -.001917526917 5269175E0  /
  12903.       DATA BERN( 7) /    .006410256410 2564103E0  /
  12904.       DATA BERN( 8) /   -.02955065359 4771242E0   /
  12905.       DATA BERN( 9) /    .1796443723 6883057E0    /
  12906.       DATA BERN(10) /  -1.392432216 9059011E0     /
  12907.       DATA BERN(11) /  13.40286404 4168392E0      /
  12908.       DATA FIRST /.TRUE./
  12909. C***FIRST EXECUTABLE STATEMENT  C9LGMC
  12910.       IF (FIRST) THEN
  12911.          NTERM = -0.30*LOG(R1MACH(3))
  12912.          BOUND = 0.1170*NTERM*(0.1*R1MACH(3))**(-1./(2*NTERM-1))
  12913.          XBIG = 1.0/SQRT(R1MACH(3))
  12914.          XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.*R1MACH(1))) )
  12915.       ENDIF
  12916.       FIRST = .FALSE.
  12917. C
  12918.       Z = ZIN
  12919.       X = REAL (Z)
  12920.       Y = AIMAG(Z)
  12921.       CABSZ = ABS(Z)
  12922. C
  12923.       IF (X .LT. 0.0 .AND. ABS(Y) .LT. BOUND) CALL XERMSG ('SLATEC',
  12924.      +   'C9LGMC', 'NOT VALID FOR NEGATIVE REAL(Z) AND SMALL ' //
  12925.      +   'ABS(AIMAG(Z))', 2, 2)
  12926.       IF (CABSZ .LT. BOUND) CALL XERMSG ('SLATEC', 'C9LGMC',
  12927.      +   'NOT VALID FOR SMALL ABS(Z)', 3, 2)
  12928. C
  12929.       IF (CABSZ.GE.XMAX) GO TO 50
  12930. C
  12931.       IF (CABSZ.GE.XBIG) C9LGMC = 1.0/(12.0*Z)
  12932.       IF (CABSZ.GE.XBIG) RETURN
  12933. C
  12934.       Z2INV = 1.0/Z**2
  12935.       C9LGMC = (0.0, 0.0)
  12936.       DO 40 I=1,NTERM
  12937.         NDX = NTERM + 1 - I
  12938.         C9LGMC = BERN(NDX) + C9LGMC*Z2INV
  12939.  40   CONTINUE
  12940. C
  12941.       C9LGMC = C9LGMC/Z
  12942.       RETURN
  12943. C
  12944.  50   C9LGMC = (0.0, 0.0)
  12945.       CALL XERMSG ('SLATEC', 'C9LGMC', 'Z SO BIG C9LGMC UNDERFLOWS', 1,
  12946.      +   1)
  12947.       RETURN
  12948. C
  12949.       END
  12950. *DECK C9LN2R
  12951.       COMPLEX FUNCTION C9LN2R (Z)
  12952. C***BEGIN PROLOGUE  C9LN2R
  12953. C***SUBSIDIARY
  12954. C***PURPOSE  Evaluate LOG(1+Z) from second order relative accuracy so
  12955. C            that  LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
  12956. C***LIBRARY   SLATEC (FNLIB)
  12957. C***CATEGORY  C4B
  12958. C***TYPE      COMPLEX (R9LN2R-S, D9LN2R-D, C9LN2R-C)
  12959. C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER
  12960. C***AUTHOR  Fullerton, W., (LANL)
  12961. C***DESCRIPTION
  12962. C
  12963. C Evaluate  LOG(1+Z)  from 2-nd order with relative error accuracy so
  12964. C that     LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
  12965. C
  12966. C Now  LOG(1+Z) = 0.5*LOG(1+2*X+ABS(Z)**2) + I*CARG(1+Z),
  12967. C where X = REAL(Z)  and  Y = AIMAG(Z).
  12968. C We find
  12969. C     Z**3 * C9LN2R(Z) = -X*ABS(Z)**2 - 0.25*ABS(Z)**4
  12970. C        + (2*X+ABS(Z)**2)**3 * R9LN2R(2*X+ABS(Z)**2)
  12971. C        + I * (CARG(1+Z) + (X-1)*Y)
  12972. C The imaginary part must be evaluated carefully as
  12973. C     (ATAN(Y/(1+X)) - Y/(1+X)) + Y/(1+X) - (1-X)*Y
  12974. C       = (Y/(1+X))**3 * R9ATN1(Y/(1+X)) + X**2*Y/(1+X)
  12975. C
  12976. C Now we divide through by Z**3 carefully.  Write
  12977. C     1/Z**3 = (X-I*Y)/ABS(Z)**3 * (1/ABS(Z)**3)
  12978. C then   C9LN2R(Z) = ((X-I*Y)/ABS(Z))**3 * (-X/ABS(Z) - ABS(Z)/4
  12979. C        + 0.5*((2*X+ABS(Z)**2)/ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
  12980. C        + I*Y/(ABS(Z)*(1+X)) * ((X/ABS(Z))**2 +
  12981. C          + (Y/(ABS(Z)*(1+X)))**2 * R9ATN1(Y/(1+X)) ) )
  12982. C
  12983. C If we let  XZ = X/ABS(Z)  and  YZ = Y/ABS(Z)  we may write
  12984. C     C9LN2R(Z) = (XZ-I*YZ)**3 * (-XZ - ABS(Z)/4
  12985. C        + 0.5*(2*XZ+ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
  12986. C        + I*YZ/(1+X) * (XZ**2 + (YZ/(1+X))**2*R9ATN1(Y/(1+X)) ))
  12987. C
  12988. C***REFERENCES  (NONE)
  12989. C***ROUTINES CALLED  R9ATN1, R9LN2R
  12990. C***REVISION HISTORY  (YYMMDD)
  12991. C   780401  DATE WRITTEN
  12992. C   890531  Changed all specific intrinsics to generic.  (WRB)
  12993. C   890531  REVISION DATE from Version 3.2
  12994. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  12995. C   900720  Routine changed from user-callable to subsidiary.  (WRB)
  12996. C***END PROLOGUE  C9LN2R
  12997.       COMPLEX Z
  12998. C***FIRST EXECUTABLE STATEMENT  C9LN2R
  12999.       X = REAL (Z)
  13000.       Y = AIMAG (Z)
  13001. C
  13002.       CABSZ = ABS(Z)
  13003.       IF (CABSZ.GT.0.8125) GO TO 20
  13004. C
  13005.       C9LN2R = CMPLX (1.0/3.0, 0.0)
  13006.       IF (CABSZ.EQ.0.0) RETURN
  13007. C
  13008.       XZ = X/CABSZ
  13009.       YZ = Y/CABSZ
  13010. C
  13011.       ARG = 2.0*XZ + CABSZ
  13012.       RPART = 0.5*ARG**3*R9LN2R(CABSZ*ARG) - XZ - 0.25*CABSZ
  13013.       Y1X = YZ/(1.0+X)
  13014.       AIPART = Y1X * (XZ**2 + Y1X**2*R9ATN1(CABSZ*Y1X) )
  13015. C
  13016.       C9LN2R = CMPLX(XZ,-YZ)**3 * CMPLX(RPART,AIPART)
  13017.       RETURN
  13018. C
  13019.  20   C9LN2R = (LOG(1.0+Z) - Z*(1.0-0.5*Z)) / Z**3
  13020.       RETURN
  13021. C
  13022.       END
  13023. *DECK CACOS
  13024.       COMPLEX FUNCTION CACOS (Z)
  13025. C***BEGIN PROLOGUE  CACOS
  13026. C***PURPOSE  Compute the complex arc cosine.
  13027. C***LIBRARY   SLATEC (FNLIB)
  13028. C***CATEGORY  C4A
  13029. C***TYPE      COMPLEX (CACOS-C)
  13030. C***KEYWORDS  ARC COSINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
  13031. C***AUTHOR  Fullerton, W., (LANL)
  13032. C***DESCRIPTION
  13033. C
  13034. C CACOS(Z) calculates the complex trigonometric arc cosine of Z.
  13035. C The result is in units of radians, and the real part is in the
  13036. C first or second quadrant.
  13037. C
  13038. C***REFERENCES  (NONE)
  13039. C***ROUTINES CALLED  CASIN
  13040. C***REVISION HISTORY  (YYMMDD)
  13041. C   770401  DATE WRITTEN
  13042. C   861211  REVISION DATE from Version 3.2
  13043. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13044. C***END PROLOGUE  CACOS
  13045.       COMPLEX Z, CASIN
  13046.       SAVE PI2
  13047.       DATA PI2 /1.5707963267 9489661923E0/
  13048. C***FIRST EXECUTABLE STATEMENT  CACOS
  13049.       CACOS = PI2 - CASIN (Z)
  13050. C
  13051.       RETURN
  13052.       END
  13053. *DECK CACOSH
  13054.       COMPLEX FUNCTION CACOSH (Z)
  13055. C***BEGIN PROLOGUE  CACOSH
  13056. C***PURPOSE  Compute the arc hyperbolic cosine.
  13057. C***LIBRARY   SLATEC (FNLIB)
  13058. C***CATEGORY  C4C
  13059. C***TYPE      COMPLEX (ACOSH-S, DACOSH-D, CACOSH-C)
  13060. C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
  13061. C             INVERSE HYPERBOLIC COSINE
  13062. C***AUTHOR  Fullerton, W., (LANL)
  13063. C***DESCRIPTION
  13064. C
  13065. C CACOSH(Z) calculates the complex arc hyperbolic cosine of Z.
  13066. C
  13067. C***REFERENCES  (NONE)
  13068. C***ROUTINES CALLED  CACOS
  13069. C***REVISION HISTORY  (YYMMDD)
  13070. C   770401  DATE WRITTEN
  13071. C   861211  REVISION DATE from Version 3.2
  13072. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13073. C***END PROLOGUE  CACOSH
  13074.       COMPLEX Z, CI, CACOS
  13075.       SAVE CI
  13076.       DATA CI /(0.,1.)/
  13077. C***FIRST EXECUTABLE STATEMENT  CACOSH
  13078.       CACOSH = CI*CACOS(Z)
  13079. C
  13080.       RETURN
  13081.       END
  13082. *DECK CARG
  13083.       FUNCTION CARG (Z)
  13084. C***BEGIN PROLOGUE  CARG
  13085. C***PURPOSE  Compute the argument of a complex number.
  13086. C***LIBRARY   SLATEC (FNLIB)
  13087. C***CATEGORY  A4A
  13088. C***TYPE      COMPLEX (CARG-C)
  13089. C***KEYWORDS  ARGUMENT OF A COMPLEX NUMBER, ELEMENTARY FUNCTIONS, FNLIB
  13090. C***AUTHOR  Fullerton, W., (LANL)
  13091. C***DESCRIPTION
  13092. C
  13093. C CARG(Z) calculates the argument of the complex number Z.  Note
  13094. C that CARG returns a real result.  If Z = X+iY, then CARG is ATAN(Y/X),
  13095. C except when both X and Y are zero, in which case the result
  13096. C will be zero.
  13097. C
  13098. C***REFERENCES  (NONE)
  13099. C***ROUTINES CALLED  (NONE)
  13100. C***REVISION HISTORY  (YYMMDD)
  13101. C   770401  DATE WRITTEN
  13102. C   861211  REVISION DATE from Version 3.2
  13103. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13104. C***END PROLOGUE  CARG
  13105.       COMPLEX Z
  13106. C***FIRST EXECUTABLE STATEMENT  CARG
  13107.       CARG = 0.0
  13108.       IF (REAL(Z).NE.0. .OR. AIMAG(Z).NE.0.) CARG =
  13109.      1  ATAN2 (AIMAG(Z), REAL(Z))
  13110. C
  13111.       RETURN
  13112.       END
  13113. *DECK CASIN
  13114.       COMPLEX FUNCTION CASIN (ZINP)
  13115. C***BEGIN PROLOGUE  CASIN
  13116. C***PURPOSE  Compute the complex arc sine.
  13117. C***LIBRARY   SLATEC (FNLIB)
  13118. C***CATEGORY  C4A
  13119. C***TYPE      COMPLEX (CASIN-C)
  13120. C***KEYWORDS  ARC SINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
  13121. C***AUTHOR  Fullerton, W., (LANL)
  13122. C***DESCRIPTION
  13123. C
  13124. C CASIN(ZINP) calculates the complex trigonometric arc sine of ZINP.
  13125. C The result is in units of radians, and the real part is in the first
  13126. C or fourth quadrant.
  13127. C
  13128. C***REFERENCES  (NONE)
  13129. C***ROUTINES CALLED  R1MACH
  13130. C***REVISION HISTORY  (YYMMDD)
  13131. C   770701  DATE WRITTEN
  13132. C   890531  Changed all specific intrinsics to generic.  (WRB)
  13133. C   890531  REVISION DATE from Version 3.2
  13134. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13135. C***END PROLOGUE  CASIN
  13136.       COMPLEX ZINP, Z, Z2, SQZP1, CI
  13137.       LOGICAL FIRST
  13138.       SAVE PI2, PI, CI, NTERMS, RMIN, FIRST
  13139.       DATA PI2 /1.5707963267 9489661923E0/
  13140.       DATA PI /3.1415926535 8979324E0/
  13141.       DATA CI /(0.,1.)/
  13142.       DATA FIRST /.TRUE./
  13143. C***FIRST EXECUTABLE STATEMENT  CASIN
  13144.       IF (FIRST) THEN
  13145. C NTERMS = LOG(EPS)/LOG(RMAX)  WHERE RMAX = 0.1
  13146.          NTERMS = -0.4343*LOG(R1MACH(3))
  13147.          RMIN = SQRT (6.0*R1MACH(3))
  13148.       ENDIF
  13149.       FIRST = .FALSE.
  13150. C
  13151.       Z = ZINP
  13152.       R = ABS (Z)
  13153.       IF (R.GT.0.1) GO TO 30
  13154. C
  13155.       CASIN = Z
  13156.       IF (R.LT.RMIN) RETURN
  13157. C
  13158.       CASIN = (0.0, 0.0)
  13159.       Z2 = Z*Z
  13160.       DO 20 I=1,NTERMS
  13161.         TWOI = 2*(NTERMS-I) + 1
  13162.         CASIN = 1.0/TWOI + TWOI*CASIN*Z2/(TWOI+1.0)
  13163.  20   CONTINUE
  13164.       CASIN = Z*CASIN
  13165.       RETURN
  13166. C
  13167.  30   IF (REAL(ZINP).LT.0.0) Z = -ZINP
  13168. C
  13169.       SQZP1 = SQRT (Z+1.0)
  13170.       IF (AIMAG(SQZP1).LT.0.) SQZP1 = -SQZP1
  13171.       CASIN = PI2 - CI * LOG (Z + SQZP1*SQRT(Z-1.0))
  13172. C
  13173.       IF (REAL(CASIN).GT.PI2) CASIN = PI - CASIN
  13174.       IF (REAL(CASIN).LE.(-PI2)) CASIN = -PI - CASIN
  13175.       IF (REAL(ZINP).LT.0.) CASIN = -CASIN
  13176. C
  13177.       RETURN
  13178.       END
  13179. *DECK CASINH
  13180.       COMPLEX FUNCTION CASINH (Z)
  13181. C***BEGIN PROLOGUE  CASINH
  13182. C***PURPOSE  Compute the arc hyperbolic sine.
  13183. C***LIBRARY   SLATEC (FNLIB)
  13184. C***CATEGORY  C4C
  13185. C***TYPE      COMPLEX (ASINH-S, DASINH-D, CASINH-C)
  13186. C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
  13187. C             INVERSE HYPERBOLIC SINE
  13188. C***AUTHOR  Fullerton, W., (LANL)
  13189. C***DESCRIPTION
  13190. C
  13191. C CASINH(Z) calculates the complex arc hyperbolic sine of Z.
  13192. C
  13193. C***REFERENCES  (NONE)
  13194. C***ROUTINES CALLED  CASIN
  13195. C***REVISION HISTORY  (YYMMDD)
  13196. C   770401  DATE WRITTEN
  13197. C   861211  REVISION DATE from Version 3.2
  13198. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13199. C***END PROLOGUE  CASINH
  13200.       COMPLEX Z, CI, CASIN
  13201.       SAVE CI
  13202.       DATA CI /(0.,1.)/
  13203. C***FIRST EXECUTABLE STATEMENT  CASINH
  13204.       CASINH = -CI*CASIN (CI*Z)
  13205. C
  13206.       RETURN
  13207.       END
  13208. *DECK CATAN
  13209.       COMPLEX FUNCTION CATAN (Z)
  13210. C***BEGIN PROLOGUE  CATAN
  13211. C***PURPOSE  Compute the complex arc tangent.
  13212. C***LIBRARY   SLATEC (FNLIB)
  13213. C***CATEGORY  C4A
  13214. C***TYPE      COMPLEX (CATAN-C)
  13215. C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
  13216. C***AUTHOR  Fullerton, W., (LANL)
  13217. C***DESCRIPTION
  13218. C
  13219. C CATAN(Z) calculates the complex trigonometric arc tangent of Z.
  13220. C The result is in units of radians, and the real part is in the first
  13221. C or fourth quadrant.
  13222. C
  13223. C***REFERENCES  (NONE)
  13224. C***ROUTINES CALLED  R1MACH, XERMSG
  13225. C***REVISION HISTORY  (YYMMDD)
  13226. C   770801  DATE WRITTEN
  13227. C   890531  Changed all specific intrinsics to generic.  (WRB)
  13228. C   890531  REVISION DATE from Version 3.2
  13229. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13230. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  13231. C   900326  Removed duplicate information from DESCRIPTION section.
  13232. C           (WRB)
  13233. C***END PROLOGUE  CATAN
  13234.       COMPLEX Z, Z2
  13235.       LOGICAL FIRST
  13236.       SAVE PI2, NTERMS, SQEPS, RMIN, RMAX, FIRST
  13237.       DATA PI2 / 1.5707963267 9489661923E0 /
  13238.       DATA FIRST /.TRUE./
  13239. C***FIRST EXECUTABLE STATEMENT  CATAN
  13240.       IF (FIRST) THEN
  13241. C NTERMS = LOG(EPS)/LOG(RBND) WHERE RBND = 0.1
  13242.          NTERMS = -0.4343*LOG(R1MACH(3)) + 1.0
  13243.          SQEPS = SQRT(R1MACH(4))
  13244.          RMIN = SQRT (3.0*R1MACH(3))
  13245.          RMAX = 1.0/R1MACH(3)
  13246.       ENDIF
  13247.       FIRST = .FALSE.
  13248. C
  13249.       R = ABS(Z)
  13250.       IF (R.GT.0.1) GO TO 30
  13251. C
  13252.       CATAN = Z
  13253.       IF (R.LT.RMIN) RETURN
  13254. C
  13255.       CATAN = (0.0, 0.0)
  13256.       Z2 = Z*Z
  13257.       DO 20 I=1,NTERMS
  13258.         TWOI = 2*(NTERMS-I) + 1
  13259.         CATAN = 1.0/TWOI - Z2*CATAN
  13260.  20   CONTINUE
  13261.       CATAN = Z*CATAN
  13262.       RETURN
  13263. C
  13264.  30   IF (R.GT.RMAX) GO TO 50
  13265.       X = REAL(Z)
  13266.       Y = AIMAG(Z)
  13267.       R2 = R*R
  13268.       IF (R2 .EQ. 1.0 .AND. X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CATAN',
  13269.      +   'Z IS +I OR -I', 2, 2)
  13270.       IF (ABS(R2-1.0).GT.SQEPS) GO TO 40
  13271.       IF (ABS(CMPLX(1.0, 0.0)+Z*Z) .LT. SQEPS) CALL XERMSG ('SLATEC',
  13272.      +   'CATAN', 'ANSWER LT HALF PRECISION, Z**2 CLOSE TO -1', 1, 1)
  13273. C
  13274.  40   XANS = 0.5*ATAN2(2.0*X, 1.0-R2)
  13275.       YANS = 0.25*LOG((R2+2.0*Y+1.0)/(R2-2.0*Y+1.0))
  13276.       CATAN = CMPLX (XANS, YANS)
  13277.       RETURN
  13278. C
  13279.  50   CATAN = CMPLX (PI2, 0.)
  13280.       IF (REAL(Z).LT.0.0) CATAN = CMPLX(-PI2,0.0)
  13281.       RETURN
  13282. C
  13283.       END
  13284. *DECK CATAN2
  13285.       COMPLEX FUNCTION CATAN2 (CSN, CCS)
  13286. C***BEGIN PROLOGUE  CATAN2
  13287. C***PURPOSE  Compute the complex arc tangent in the proper quadrant.
  13288. C***LIBRARY   SLATEC (FNLIB)
  13289. C***CATEGORY  C4A
  13290. C***TYPE      COMPLEX (CATAN2-C)
  13291. C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, POLAR ANGEL,
  13292. C             QUADRANT, TRIGONOMETRIC
  13293. C***AUTHOR  Fullerton, W., (LANL)
  13294. C***DESCRIPTION
  13295. C
  13296. C CATAN2(CSN,CCS) calculates the complex trigonometric arc
  13297. C tangent of the ratio CSN/CCS and returns a result whose real
  13298. C part is in the correct quadrant (within a multiple of 2*PI).  The
  13299. C result is in units of radians and the real part is between -PI
  13300. C and +PI.
  13301. C
  13302. C***REFERENCES  (NONE)
  13303. C***ROUTINES CALLED  CATAN, XERMSG
  13304. C***REVISION HISTORY  (YYMMDD)
  13305. C   770401  DATE WRITTEN
  13306. C   890531  Changed all specific intrinsics to generic.  (WRB)
  13307. C   890531  REVISION DATE from Version 3.2
  13308. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13309. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  13310. C   900326  Removed duplicate information from DESCRIPTION section.
  13311. C           (WRB)
  13312. C***END PROLOGUE  CATAN2
  13313.       COMPLEX CSN, CCS, CATAN
  13314.       SAVE PI
  13315.       DATA PI / 3.1415926535 8979323846E0 /
  13316. C***FIRST EXECUTABLE STATEMENT  CATAN2
  13317.       IF (ABS(CCS).EQ.0.) GO TO 10
  13318. C
  13319.       CATAN2 = CATAN (CSN/CCS)
  13320.       IF (REAL(CCS).LT.0.) CATAN2 = CATAN2 + PI
  13321.       IF (REAL(CATAN2).GT.PI) CATAN2 = CATAN2 - 2.0*PI
  13322.       RETURN
  13323. C
  13324.  10   IF (ABS(CSN) .EQ. 0.) CALL XERMSG ('SLATEC', 'CATAN2',
  13325.      +   'CALLED WITH BOTH ARGUMENTS ZERO', 1, 2)
  13326. C
  13327.       CATAN2 = CMPLX (SIGN(0.5*PI,REAL(CSN)), 0.0)
  13328. C
  13329.       RETURN
  13330.       END
  13331. *DECK CATANH
  13332.       COMPLEX FUNCTION CATANH (Z)
  13333. C***BEGIN PROLOGUE  CATANH
  13334. C***PURPOSE  Compute the arc hyperbolic tangent.
  13335. C***LIBRARY   SLATEC (FNLIB)
  13336. C***CATEGORY  C4C
  13337. C***TYPE      COMPLEX (ATANH-S, DATANH-D, CATANH-C)
  13338. C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
  13339. C             FNLIB, INVERSE HYPERBOLIC TANGENT
  13340. C***AUTHOR  Fullerton, W., (LANL)
  13341. C***DESCRIPTION
  13342. C
  13343. C CATANH(Z) calculates the complex arc hyperbolic tangent of Z.
  13344. C
  13345. C***REFERENCES  (NONE)
  13346. C***ROUTINES CALLED  CATAN
  13347. C***REVISION HISTORY  (YYMMDD)
  13348. C   770401  DATE WRITTEN
  13349. C   861211  REVISION DATE from Version 3.2
  13350. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13351. C***END PROLOGUE  CATANH
  13352.       COMPLEX Z, CI, CATAN
  13353.       SAVE CI
  13354.       DATA CI /(0.,1.)/
  13355. C***FIRST EXECUTABLE STATEMENT  CATANH
  13356.       CATANH = -CI*CATAN(CI*Z)
  13357. C
  13358.       RETURN
  13359.       END
  13360. *DECK CAXPY
  13361.       SUBROUTINE CAXPY (N, CA, CX, INCX, CY, INCY)
  13362. C***BEGIN PROLOGUE  CAXPY
  13363. C***PURPOSE  Compute a constant times a vector plus a vector.
  13364. C***LIBRARY   SLATEC (BLAS)
  13365. C***CATEGORY  D1A7
  13366. C***TYPE      COMPLEX (SAXPY-S, DAXPY-D, CAXPY-C)
  13367. C***KEYWORDS  BLAS, LINEAR ALGEBRA, TRIAD, VECTOR
  13368. C***AUTHOR  Lawson, C. L., (JPL)
  13369. C           Hanson, R. J., (SNLA)
  13370. C           Kincaid, D. R., (U. of Texas)
  13371. C           Krogh, F. T., (JPL)
  13372. C***DESCRIPTION
  13373. C
  13374. C                B L A S  Subprogram
  13375. C    Description of Parameters
  13376. C
  13377. C     --Input--
  13378. C        N  number of elements in input vector(s)
  13379. C       CA  complex scalar multiplier
  13380. C       CX  complex vector with N elements
  13381. C     INCX  storage spacing between elements of CX
  13382. C       CY  complex vector with N elements
  13383. C     INCY  storage spacing between elements of CY
  13384. C
  13385. C     --Output--
  13386. C       CY  complex result (unchanged if N .LE. 0)
  13387. C
  13388. C     Overwrite complex CY with complex  CA*CX + CY.
  13389. C     For I = 0 to N-1, replace  CY(LY+I*INCY) with CA*CX(LX+I*INCX) +
  13390. C       CY(LY+I*INCY),
  13391. C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
  13392. C     defined in a similar way using INCY.
  13393. C
  13394. C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
  13395. C                 Krogh, Basic linear algebra subprograms for Fortran
  13396. C                 usage, Algorithm No. 539, Transactions on Mathematical
  13397. C                 Software 5, 3 (September 1979), pp. 308-323.
  13398. C***ROUTINES CALLED  (NONE)
  13399. C***REVISION HISTORY  (YYMMDD)
  13400. C   791001  DATE WRITTEN
  13401. C   861211  REVISION DATE from Version 3.2
  13402. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13403. C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
  13404. C   920501  Reformatted the REFERENCES section.  (WRB)
  13405. C***END PROLOGUE  CAXPY
  13406.       COMPLEX CX(*),CY(*),CA
  13407. C***FIRST EXECUTABLE STATEMENT  CAXPY
  13408.       CANORM = ABS(REAL(CA)) + ABS(AIMAG(CA))
  13409.       IF (N.LE.0 .OR. CANORM.EQ.0.0E0) RETURN
  13410.       IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
  13411. C
  13412. C     Code for unequal or nonpositive increments.
  13413. C
  13414.       KX = 1
  13415.       KY = 1
  13416.       IF (INCX .LT. 0) KX = 1+(1-N)*INCX
  13417.       IF (INCY .LT. 0) KY = 1+(1-N)*INCY
  13418.       DO 10 I = 1,N
  13419.         CY(KY) = CY(KY) + CA*CX(KX)
  13420.         KX = KX + INCX
  13421.         KY = KY + INCY
  13422.    10 CONTINUE
  13423.       RETURN
  13424. C
  13425. C     Code for equal, positive, non-unit increments.
  13426. C
  13427.    20 NS = N*INCX
  13428.       DO 30 I = 1,NS,INCX
  13429.         CY(I) = CA*CX(I) + CY(I)
  13430.    30 CONTINUE
  13431.       RETURN
  13432.       END
  13433. *DECK CBABK2
  13434.       SUBROUTINE CBABK2 (NM, N, LOW, IGH, SCALE, M, ZR, ZI)
  13435. C***BEGIN PROLOGUE  CBABK2
  13436. C***PURPOSE  Form the eigenvectors of a complex general matrix from the
  13437. C            eigenvectors of matrix output from CBAL.
  13438. C***LIBRARY   SLATEC (EISPACK)
  13439. C***CATEGORY  D4C4
  13440. C***TYPE      COMPLEX (BALBAK-S, CBABK2-C)
  13441. C***KEYWORDS  EIGENVECTORS, EISPACK
  13442. C***AUTHOR  Smith, B. T., et al.
  13443. C***DESCRIPTION
  13444. C
  13445. C     This subroutine is a translation of the ALGOL procedure
  13446. C     CBABK2, which is a complex version of BALBAK,
  13447. C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
  13448. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  13449. C
  13450. C     This subroutine forms the eigenvectors of a COMPLEX GENERAL
  13451. C     matrix by back transforming those of the corresponding
  13452. C     balanced matrix determined by  CBAL.
  13453. C
  13454. C     On INPUT
  13455. C
  13456. C        NM must be set to the row dimension of the two-dimensional
  13457. C          array parameters, ZR and ZI, as declared in the calling
  13458. C          program dimension statement.  NM is an INTEGER variable.
  13459. C
  13460. C        N is the order of the matrix Z=(ZR,ZI).  N is an INTEGER
  13461. C          variable.  N must be less than or equal to NM.
  13462. C
  13463. C        LOW and IGH are INTEGER variables determined by  CBAL.
  13464. C
  13465. C        SCALE contains information determining the permutations and
  13466. C          scaling factors used by  CBAL.  SCALE is a one-dimensional
  13467. C          REAL array, dimensioned SCALE(N).
  13468. C
  13469. C        M is the number of eigenvectors to be back transformed.
  13470. C          M is an INTEGER variable.
  13471. C
  13472. C        ZR and ZI contain the real and imaginary parts, respectively,
  13473. C          of the eigenvectors to be back transformed in their first
  13474. C          M columns.  ZR and ZI are two-dimensional REAL arrays,
  13475. C          dimensioned ZR(NM,M) and ZI(NM,M).
  13476. C
  13477. C     On OUTPUT
  13478. C
  13479. C        ZR and ZI contain the real and imaginary parts,
  13480. C          respectively, of the transformed eigenvectors
  13481. C          in their first M columns.
  13482. C
  13483. C     Questions and comments should be directed to B. S. Garbow,
  13484. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  13485. C     ------------------------------------------------------------------
  13486. C
  13487. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  13488. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  13489. C                 system Routines - EISPACK Guide, Springer-Verlag,
  13490. C                 1976.
  13491. C***ROUTINES CALLED  (NONE)
  13492. C***REVISION HISTORY  (YYMMDD)
  13493. C   760101  DATE WRITTEN
  13494. C   890831  Modified array declarations.  (WRB)
  13495. C   890831  REVISION DATE from Version 3.2
  13496. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13497. C   920501  Reformatted the REFERENCES section.  (WRB)
  13498. C***END PROLOGUE  CBABK2
  13499. C
  13500.       INTEGER I,J,K,M,N,II,NM,IGH,LOW
  13501.       REAL SCALE(*),ZR(NM,*),ZI(NM,*)
  13502.       REAL S
  13503. C
  13504. C***FIRST EXECUTABLE STATEMENT  CBABK2
  13505.       IF (M .EQ. 0) GO TO 200
  13506.       IF (IGH .EQ. LOW) GO TO 120
  13507. C
  13508.       DO 110 I = LOW, IGH
  13509.          S = SCALE(I)
  13510. C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
  13511. C                IF THE FOREGOING STATEMENT IS REPLACED BY
  13512. C                S=1.0E0/SCALE(I). ..........
  13513.          DO 100 J = 1, M
  13514.             ZR(I,J) = ZR(I,J) * S
  13515.             ZI(I,J) = ZI(I,J) * S
  13516.   100    CONTINUE
  13517. C
  13518.   110 CONTINUE
  13519. C     .......... FOR I=LOW-1 STEP -1 UNTIL 1,
  13520. C                IGH+1 STEP 1 UNTIL N DO -- ..........
  13521.   120 DO 140 II = 1, N
  13522.          I = II
  13523.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
  13524.          IF (I .LT. LOW) I = LOW - II
  13525.          K = SCALE(I)
  13526.          IF (K .EQ. I) GO TO 140
  13527. C
  13528.          DO 130 J = 1, M
  13529.             S = ZR(I,J)
  13530.             ZR(I,J) = ZR(K,J)
  13531.             ZR(K,J) = S
  13532.             S = ZI(I,J)
  13533.             ZI(I,J) = ZI(K,J)
  13534.             ZI(K,J) = S
  13535.   130    CONTINUE
  13536. C
  13537.   140 CONTINUE
  13538. C
  13539.   200 RETURN
  13540.       END
  13541. *DECK CBAL
  13542.       SUBROUTINE CBAL (NM, N, AR, AI, LOW, IGH, SCALE)
  13543. C***BEGIN PROLOGUE  CBAL
  13544. C***PURPOSE  Balance a complex general matrix and isolate eigenvalues
  13545. C            whenever possible.
  13546. C***LIBRARY   SLATEC (EISPACK)
  13547. C***CATEGORY  D4C1A
  13548. C***TYPE      COMPLEX (BALANC-S, CBAL-C)
  13549. C***KEYWORDS  EIGENVECTORS, EISPACK
  13550. C***AUTHOR  Smith, B. T., et al.
  13551. C***DESCRIPTION
  13552. C
  13553. C     This subroutine is a translation of the ALGOL procedure
  13554. C     CBALANCE, which is a complex version of BALANCE,
  13555. C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
  13556. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  13557. C
  13558. C     This subroutine balances a COMPLEX matrix and isolates
  13559. C     eigenvalues whenever possible.
  13560. C
  13561. C     On INPUT
  13562. C
  13563. C        NM must be set to the row dimension of the two-dimensional
  13564. C          array parameters, AR and AI, as declared in the calling
  13565. C          program dimension statement.  NM is an INTEGER variable.
  13566. C
  13567. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  13568. C          variable.  N must be less than or equal to NM.
  13569. C
  13570. C        AR and AI contain the real and imaginary parts,
  13571. C          respectively, of the complex matrix to be balanced.
  13572. C          AR and AI are two-dimensional REAL arrays, dimensioned
  13573. C          AR(NM,N) and AI(NM,N).
  13574. C
  13575. C     On OUTPUT
  13576. C
  13577. C        AR and AI contain the real and imaginary parts,
  13578. C          respectively, of the balanced matrix.
  13579. C
  13580. C        LOW and IGH are two INTEGER variables such that AR(I,J)
  13581. C          and AI(I,J) are equal to zero if
  13582. C           (1) I is greater than J and
  13583. C           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
  13584. C
  13585. C        SCALE contains information determining the permutations and
  13586. C          scaling factors used.  SCALE is a one-dimensional REAL array,
  13587. C          dimensioned SCALE(N).
  13588. C
  13589. C     Suppose that the principal submatrix in rows LOW through IGH
  13590. C     has been balanced, that P(J) denotes the index interchanged
  13591. C     with J during the permutation step, and that the elements
  13592. C     of the diagonal matrix used are denoted by D(I,J).  Then
  13593. C        SCALE(J) = P(J),    for J = 1,...,LOW-1
  13594. C                 = D(J,J)       J = LOW,...,IGH
  13595. C                 = P(J)         J = IGH+1,...,N.
  13596. C     The order in which the interchanges are made is N to IGH+1,
  13597. C     then 1 to LOW-1.
  13598. C
  13599. C     Note that 1 is returned for IGH if IGH is zero formally.
  13600. C
  13601. C     The ALGOL procedure EXC contained in CBALANCE appears in
  13602. C     CBAL  in line.  (Note that the ALGOL roles of identifiers
  13603. C     K,L have been reversed.)
  13604. C
  13605. C     Questions and comments should be directed to B. S. Garbow,
  13606. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  13607. C     ------------------------------------------------------------------
  13608. C
  13609. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  13610. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  13611. C                 system Routines - EISPACK Guide, Springer-Verlag,
  13612. C                 1976.
  13613. C***ROUTINES CALLED  (NONE)
  13614. C***REVISION HISTORY  (YYMMDD)
  13615. C   760101  DATE WRITTEN
  13616. C   890831  Modified array declarations.  (WRB)
  13617. C   890831  REVISION DATE from Version 3.2
  13618. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13619. C   920501  Reformatted the REFERENCES section.  (WRB)
  13620. C***END PROLOGUE  CBAL
  13621. C
  13622.       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
  13623.       REAL AR(NM,*),AI(NM,*),SCALE(*)
  13624.       REAL C,F,G,R,S,B2,RADIX
  13625.       LOGICAL NOCONV
  13626. C
  13627. C     THE FOLLOWING PORTABLE VALUE OF RADIX WORKS WELL ENOUGH
  13628. C     FOR ALL MACHINES WHOSE BASE IS A POWER OF TWO.
  13629. C
  13630. C***FIRST EXECUTABLE STATEMENT  CBAL
  13631.       RADIX = 16
  13632. C
  13633.       B2 = RADIX * RADIX
  13634.       K = 1
  13635.       L = N
  13636.       GO TO 100
  13637. C     .......... IN-LINE PROCEDURE FOR ROW AND
  13638. C                COLUMN EXCHANGE ..........
  13639.    20 SCALE(M) = J
  13640.       IF (J .EQ. M) GO TO 50
  13641. C
  13642.       DO 30 I = 1, L
  13643.          F = AR(I,J)
  13644.          AR(I,J) = AR(I,M)
  13645.          AR(I,M) = F
  13646.          F = AI(I,J)
  13647.          AI(I,J) = AI(I,M)
  13648.          AI(I,M) = F
  13649.    30 CONTINUE
  13650. C
  13651.       DO 40 I = K, N
  13652.          F = AR(J,I)
  13653.          AR(J,I) = AR(M,I)
  13654.          AR(M,I) = F
  13655.          F = AI(J,I)
  13656.          AI(J,I) = AI(M,I)
  13657.          AI(M,I) = F
  13658.    40 CONTINUE
  13659. C
  13660.    50 GO TO (80,130), IEXC
  13661. C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
  13662. C                AND PUSH THEM DOWN ..........
  13663.    80 IF (L .EQ. 1) GO TO 280
  13664.       L = L - 1
  13665. C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  13666.   100 DO 120 JJ = 1, L
  13667.          J = L + 1 - JJ
  13668. C
  13669.          DO 110 I = 1, L
  13670.             IF (I .EQ. J) GO TO 110
  13671.             IF (AR(J,I) .NE. 0.0E0 .OR. AI(J,I) .NE. 0.0E0) GO TO 120
  13672.   110    CONTINUE
  13673. C
  13674.          M = L
  13675.          IEXC = 1
  13676.          GO TO 20
  13677.   120 CONTINUE
  13678. C
  13679.       GO TO 140
  13680. C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
  13681. C                AND PUSH THEM LEFT ..........
  13682.   130 K = K + 1
  13683. C
  13684.   140 DO 170 J = K, L
  13685. C
  13686.          DO 150 I = K, L
  13687.             IF (I .EQ. J) GO TO 150
  13688.             IF (AR(I,J) .NE. 0.0E0 .OR. AI(I,J) .NE. 0.0E0) GO TO 170
  13689.   150    CONTINUE
  13690. C
  13691.          M = K
  13692.          IEXC = 2
  13693.          GO TO 20
  13694.   170 CONTINUE
  13695. C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
  13696.       DO 180 I = K, L
  13697.   180 SCALE(I) = 1.0E0
  13698. C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  13699.   190 NOCONV = .FALSE.
  13700. C
  13701.       DO 270 I = K, L
  13702.          C = 0.0E0
  13703.          R = 0.0E0
  13704. C
  13705.          DO 200 J = K, L
  13706.             IF (J .EQ. I) GO TO 200
  13707.             C = C + ABS(AR(J,I)) + ABS(AI(J,I))
  13708.             R = R + ABS(AR(I,J)) + ABS(AI(I,J))
  13709.   200    CONTINUE
  13710. C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
  13711.          IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270
  13712.          G = R / RADIX
  13713.          F = 1.0E0
  13714.          S = C + R
  13715.   210    IF (C .GE. G) GO TO 220
  13716.          F = F * RADIX
  13717.          C = C * B2
  13718.          GO TO 210
  13719.   220    G = R * RADIX
  13720.   230    IF (C .LT. G) GO TO 240
  13721.          F = F / RADIX
  13722.          C = C / B2
  13723.          GO TO 230
  13724. C     .......... NOW BALANCE ..........
  13725.   240    IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270
  13726.          G = 1.0E0 / F
  13727.          SCALE(I) = SCALE(I) * F
  13728.          NOCONV = .TRUE.
  13729. C
  13730.          DO 250 J = K, N
  13731.             AR(I,J) = AR(I,J) * G
  13732.             AI(I,J) = AI(I,J) * G
  13733.   250    CONTINUE
  13734. C
  13735.          DO 260 J = 1, L
  13736.             AR(J,I) = AR(J,I) * F
  13737.             AI(J,I) = AI(J,I) * F
  13738.   260    CONTINUE
  13739. C
  13740.   270 CONTINUE
  13741. C
  13742.       IF (NOCONV) GO TO 190
  13743. C
  13744.   280 LOW = K
  13745.       IGH = L
  13746.       RETURN
  13747.       END
  13748. *DECK CBETA
  13749.       COMPLEX FUNCTION CBETA (A, B)
  13750. C***BEGIN PROLOGUE  CBETA
  13751. C***PURPOSE  Compute the complete Beta function.
  13752. C***LIBRARY   SLATEC (FNLIB)
  13753. C***CATEGORY  C7B
  13754. C***TYPE      COMPLEX (BETA-S, DBETA-D, CBETA-C)
  13755. C***KEYWORDS  COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS
  13756. C***AUTHOR  Fullerton, W., (LANL)
  13757. C***DESCRIPTION
  13758. C
  13759. C CBETA computes the complete beta function of complex parameters A
  13760. C and B.
  13761. C Input Parameters:
  13762. C       A   complex and the real part of A positive
  13763. C       B   complex and the real part of B positive
  13764. C
  13765. C***REFERENCES  (NONE)
  13766. C***ROUTINES CALLED  CGAMMA, CLBETA, GAMLIM, XERMSG
  13767. C***REVISION HISTORY  (YYMMDD)
  13768. C   770701  DATE WRITTEN
  13769. C   890206  REVISION DATE from Version 3.2
  13770. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13771. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  13772. C   900326  Removed duplicate information from DESCRIPTION section.
  13773. C           (WRB)
  13774. C   900727  Added EXTERNAL statement.  (WRB)
  13775. C***END PROLOGUE  CBETA
  13776.       COMPLEX A, B, CGAMMA, CLBETA
  13777.       EXTERNAL CGAMMA
  13778.       SAVE XMAX
  13779.       DATA XMAX / 0.0 /
  13780. C***FIRST EXECUTABLE STATEMENT  CBETA
  13781.       IF (XMAX.EQ.0.0) THEN
  13782.          CALL GAMLIM (XMIN, XMAXT)
  13783.          XMAX = XMAXT
  13784.       ENDIF
  13785. C
  13786.       IF (REAL(A) .LE. 0.0 .OR. REAL(B) .LE. 0.0) CALL XERMSG ('SLATEC',
  13787.      +   'CBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2)
  13788. C
  13789.       IF (REAL(A)+REAL(B).LT.XMAX) CBETA = CGAMMA(A) * (CGAMMA(B)/
  13790.      1  CGAMMA(A+B) )
  13791.       IF (REAL(A)+REAL(B).LT.XMAX) RETURN
  13792. C
  13793.       CBETA = EXP (CLBETA(A, B))
  13794. C
  13795.       RETURN
  13796.       END
  13797. *DECK CBLKT1
  13798.       SUBROUTINE CBLKT1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1,
  13799.      +   W2, W3, WD, WW, WU, PRDCT, CPRDCT)
  13800. C***BEGIN PROLOGUE  CBLKT1
  13801. C***SUBSIDIARY
  13802. C***PURPOSE  Subsidiary to CBLKTR
  13803. C***LIBRARY   SLATEC
  13804. C***TYPE      COMPLEX (BLKTR1-S, CBLKT1-C)
  13805. C***AUTHOR  (UNKNOWN)
  13806. C***DESCRIPTION
  13807. C
  13808. C CBLKT1 solves the linear system of routine CBLKTR.
  13809. C
  13810. C B  contains the roots of all the B polynomials.
  13811. C W1,W2,W3,WD,WW,WU  are all working arrays.
  13812. C PRDCT is either PROCP or PROC depending on whether the boundary
  13813. C conditions in the M direction are periodic or not.
  13814. C CPRDCT is either CPROCP or CPROC which are called if some of the zeros
  13815. C of the B polynomials are complex.
  13816. C
  13817. C***SEE ALSO  CBLKTR
  13818. C***ROUTINES CALLED  INXCA, INXCB, INXCC
  13819. C***COMMON BLOCKS    CCBLK
  13820. C***REVISION HISTORY  (YYMMDD)
  13821. C   801001  DATE WRITTEN
  13822. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  13823. C   900402  Added TYPE section.  (WRB)
  13824. C***END PROLOGUE  CBLKT1
  13825. C
  13826.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
  13827.      1                BM(*)      ,CM(*)      ,B(*)       ,W1(*)      ,
  13828.      2                W2(*)      ,W3(*)      ,WD(*)      ,WW(*)      ,
  13829.      3                WU(*)      ,Y(IDIMY,*)
  13830.       COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
  13831.      1                NM         ,NCMPLX     ,IK
  13832.       COMPLEX         AM         ,BM         ,CM         ,Y          ,
  13833.      1                W1         ,W2         ,W3         ,WD         ,
  13834.      2                WW         ,WU
  13835. C***FIRST EXECUTABLE STATEMENT  CBLKT1
  13836.       KDO = K-1
  13837.       DO 109 L=1,KDO
  13838.          IR = L-1
  13839.          I2 = 2**IR
  13840.          I1 = I2/2
  13841.          I3 = I2+I1
  13842.          I4 = I2+I2
  13843.          IRM1 = IR-1
  13844.          CALL INXCB (I2,IR,IM2,NM2)
  13845.          CALL INXCB (I1,IRM1,IM3,NM3)
  13846.          CALL INXCB (I3,IRM1,IM1,NM1)
  13847.          CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3,
  13848.      1               M,AM,BM,CM,WD,WW,WU)
  13849.          IF = 2**K
  13850.          DO 108 I=I4,IF,I4
  13851.             IF (I-NM) 101,101,108
  13852.   101       IPI1 = I+I1
  13853.             IPI2 = I+I2
  13854.             IPI3 = I+I3
  13855.             CALL INXCC (I,IR,IDXC,NC)
  13856.             IF (I-IF) 102,108,108
  13857.   102       CALL INXCA (I,IR,IDXA,NA)
  13858.             CALL INXCB (I-I1,IRM1,IM1,NM1)
  13859.             CALL INXCB (IPI2,IR,IP2,NP2)
  13860.             CALL INXCB (IPI1,IRM1,IP1,NP1)
  13861.             CALL INXCB (IPI3,IRM1,IP3,NP3)
  13862.             CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM,
  13863.      1                  BM,CM,WD,WW,WU)
  13864.             IF (IPI2-NM) 105,105,103
  13865.   103       DO 104 J=1,M
  13866.                W3(J) = (0.,0.)
  13867.                W2(J) = (0.,0.)
  13868.   104       CONTINUE
  13869.             GO TO 106
  13870.   105       CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,
  13871.      1                  Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU)
  13872.             CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM,
  13873.      1                  BM,CM,WD,WW,WU)
  13874.   106       DO 107 J=1,M
  13875.                Y(J,I) = W1(J)+W2(J)+Y(J,I)
  13876.   107       CONTINUE
  13877.   108    CONTINUE
  13878.   109 CONTINUE
  13879.       IF (NPP) 132,110,132
  13880. C
  13881. C     THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD
  13882. C
  13883.   110 IF = 2**K
  13884.       I = IF/2
  13885.       I1 = I/2
  13886.       CALL INXCB (I-I1,K-2,IM1,NM1)
  13887.       CALL INXCB (I+I1,K-2,IP1,NP1)
  13888.       CALL INXCB (I,K-1,IZ,NZ)
  13889.       CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM,
  13890.      1            BM,CM,WD,WW,WU)
  13891.       IZR = I
  13892.       DO 111 J=1,M
  13893.          W2(J) = W1(J)
  13894.   111 CONTINUE
  13895.       DO 113 LL=2,K
  13896.          L = K-LL+1
  13897.          IR = L-1
  13898.          I2 = 2**IR
  13899.          I1 = I2/2
  13900.          I = I2
  13901.          CALL INXCC (I,IR,IDXC,NC)
  13902.          CALL INXCB (I,IR,IZ,NZ)
  13903.          CALL INXCB (I-I1,IR-1,IM1,NM1)
  13904.          CALL INXCB (I+I1,IR-1,IP1,NP1)
  13905.          CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM,
  13906.      1               CM,WD,WW,WU)
  13907.          DO 112 J=1,M
  13908.             W1(J) = Y(J,I)+W1(J)
  13909.   112    CONTINUE
  13910.          CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM,
  13911.      1               BM,CM,WD,WW,WU)
  13912.   113 CONTINUE
  13913.       DO 118 LL=2,K
  13914.          L = K-LL+1
  13915.          IR = L-1
  13916.          I2 = 2**IR
  13917.          I1 = I2/2
  13918.          I4 = I2+I2
  13919.          IFD = IF-I2
  13920.          DO 117 I=I2,IFD,I4
  13921.             IF (I-I2-IZR) 117,114,117
  13922.   114       IF (I-NM) 115,115,118
  13923.   115       CALL INXCA (I,IR,IDXA,NA)
  13924.             CALL INXCB (I,IR,IZ,NZ)
  13925.             CALL INXCB (I-I1,IR-1,IM1,NM1)
  13926.             CALL INXCB (I+I1,IR-1,IP1,NP1)
  13927.             CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM,
  13928.      1                  BM,CM,WD,WW,WU)
  13929.             DO 116 J=1,M
  13930.                W2(J) = Y(J,I)+W2(J)
  13931.   116       CONTINUE
  13932.             CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M,
  13933.      1                  AM,BM,CM,WD,WW,WU)
  13934.             IZR = I
  13935.             IF (I-NM) 117,119,117
  13936.   117    CONTINUE
  13937.   118 CONTINUE
  13938.   119 DO 120 J=1,M
  13939.          Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J)
  13940.   120 CONTINUE
  13941.       CALL INXCB (IF/2,K-1,IM1,NM1)
  13942.       CALL INXCB (IF,K-1,IP,NP)
  13943.       IF (NCMPLX) 121,122,121
  13944.   121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
  13945.      1             Y(1,NM+1),M,AM,BM,CM,W1,W3,WW)
  13946.       GO TO 123
  13947.   122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
  13948.      1            Y(1,NM+1),M,AM,BM,CM,WD,WW,WU)
  13949.   123 DO 124 J=1,M
  13950.          W1(J) = AN(1)*Y(J,NM+1)
  13951.          W2(J) = CN(NM)*Y(J,NM+1)
  13952.          Y(J,1) = Y(J,1)-W1(J)
  13953.          Y(J,NM) = Y(J,NM)-W2(J)
  13954.   124 CONTINUE
  13955.       DO 126 L=1,KDO
  13956.          IR = L-1
  13957.          I2 = 2**IR
  13958.          I4 = I2+I2
  13959.          I1 = I2/2
  13960.          I = I4
  13961.          CALL INXCA (I,IR,IDXA,NA)
  13962.          CALL INXCB (I-I2,IR,IM2,NM2)
  13963.          CALL INXCB (I-I2-I1,IR-1,IM3,NM3)
  13964.          CALL INXCB (I-I1,IR-1,IM1,NM1)
  13965.          CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM,
  13966.      1               BM,CM,WD,WW,WU)
  13967.          CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM,
  13968.      1               CM,WD,WW,WU)
  13969.          DO 125 J=1,M
  13970.             Y(J,I) = Y(J,I)-W1(J)
  13971.   125    CONTINUE
  13972.   126 CONTINUE
  13973. C
  13974.       IZR = NM
  13975.       DO 131 L=1,KDO
  13976.          IR = L-1
  13977.          I2 = 2**IR
  13978.          I1 = I2/2
  13979.          I3 = I2+I1
  13980.          I4 = I2+I2
  13981.          IRM1 = IR-1
  13982.          DO 130 I=I4,IF,I4
  13983.             IPI1 = I+I1
  13984.             IPI2 = I+I2
  13985.             IPI3 = I+I3
  13986.             IF (IPI2-IZR) 127,128,127
  13987.   127       IF (I-IZR) 130,131,130
  13988.   128       CALL INXCC (I,IR,IDXC,NC)
  13989.             CALL INXCB (IPI2,IR,IP2,NP2)
  13990.             CALL INXCB (IPI1,IRM1,IP1,NP1)
  13991.             CALL INXCB (IPI3,IRM1,IP3,NP3)
  13992.             CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M,
  13993.      1                  AM,BM,CM,WD,WW,WU)
  13994.             CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM,
  13995.      1                  BM,CM,WD,WW,WU)
  13996.             DO 129 J=1,M
  13997.                Y(J,I) = Y(J,I)-W2(J)
  13998.   129       CONTINUE
  13999.             IZR = I
  14000.             GO TO 131
  14001.   130    CONTINUE
  14002.   131 CONTINUE
  14003. C
  14004. C BEGIN BACK SUBSTITUTION PHASE
  14005. C
  14006.   132 DO 144 LL=1,K
  14007.          L = K-LL+1
  14008.          IR = L-1
  14009.          IRM1 = IR-1
  14010.          I2 = 2**IR
  14011.          I1 = I2/2
  14012.          I4 = I2+I2
  14013.          IFD = IF-I2
  14014.          DO 143 I=I2,IFD,I4
  14015.             IF (I-NM) 133,133,143
  14016.   133       IMI1 = I-I1
  14017.             IMI2 = I-I2
  14018.             IPI1 = I+I1
  14019.             IPI2 = I+I2
  14020.             CALL INXCA (I,IR,IDXA,NA)
  14021.             CALL INXCC (I,IR,IDXC,NC)
  14022.             CALL INXCB (I,IR,IZ,NZ)
  14023.             CALL INXCB (IMI1,IRM1,IM1,NM1)
  14024.             CALL INXCB (IPI1,IRM1,IP1,NP1)
  14025.             IF (I-I2) 134,134,136
  14026.   134       DO 135 J=1,M
  14027.                W1(J) = (0.,0.)
  14028.   135       CONTINUE
  14029.             GO TO 137
  14030.   136       CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2),
  14031.      1                  W1,M,AM,BM,CM,WD,WW,WU)
  14032.   137       IF (IPI2-NM) 140,140,138
  14033.   138       DO 139 J=1,M
  14034.                W2(J) = (0.,0.)
  14035.   139       CONTINUE
  14036.             GO TO 141
  14037.   140       CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2),
  14038.      1                  W2,M,AM,BM,CM,WD,WW,WU)
  14039.   141       DO 142 J=1,M
  14040.                W1(J) = Y(J,I)+W1(J)+W2(J)
  14041.   142       CONTINUE
  14042.             CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I),
  14043.      1                  M,AM,BM,CM,WD,WW,WU)
  14044.   143    CONTINUE
  14045.   144 CONTINUE
  14046.       RETURN
  14047.       END
  14048. *DECK CBLKTR
  14049.       SUBROUTINE CBLKTR (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
  14050.      +   IDIMY, Y, IERROR, W)
  14051. C***BEGIN PROLOGUE  CBLKTR
  14052. C***PURPOSE  Solve a block tridiagonal system of linear equations
  14053. C            (usually resulting from the discretization of separable
  14054. C            two-dimensional elliptic equations).
  14055. C***LIBRARY   SLATEC (FISHPACK)
  14056. C***CATEGORY  I2B4B
  14057. C***TYPE      COMPLEX (BLKTRI-S, CBLKTR-C)
  14058. C***KEYWORDS  ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM
  14059. C***AUTHOR  Adams, J., (NCAR)
  14060. C           Swarztrauber, P. N., (NCAR)
  14061. C           Sweet, R., (NCAR)
  14062. C***DESCRIPTION
  14063. C
  14064. C     Subroutine CBLKTR is a complex version of subroutine BLKTRI.
  14065. C     Both subroutines solve a system of linear equations of the form
  14066. C
  14067. C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
  14068. C
  14069. C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
  14070. C
  14071. C               For I = 1,2,...,M  and  J = 1,2,...,N.
  14072. C
  14073. C     I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e.,
  14074. C
  14075. C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
  14076. C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
  14077. C
  14078. C     These equations usually result from the discretization of
  14079. C     separable elliptic equations.  Boundary conditions may be
  14080. C     Dirichlet, Neumann, or periodic.
  14081. C
  14082. C
  14083. C     * * * * * * * * * *     On INPUT     * * * * * * * * * *
  14084. C
  14085. C     IFLG
  14086. C       = 0  Initialization only.  Certain quantities that depend on NP,
  14087. C            N, AN, BN, and CN are computed and stored in the work
  14088. C            array  W.
  14089. C       = 1  The quantities that were computed in the initialization are
  14090. C            used to obtain the solution X(I,J).
  14091. C
  14092. C       NOTE   A call with IFLG=0 takes approximately one half the time
  14093. C              time as a call with IFLG = 1.  However, the
  14094. C              initialization does not have to be repeated unless NP, N,
  14095. C              AN, BN, or CN change.
  14096. C
  14097. C     NP
  14098. C       = 0  If AN(1) and CN(N) are not zero, which corresponds to
  14099. C            periodic boundary conditions.
  14100. C       = 1  If AN(1) and CN(N) are zero.
  14101. C
  14102. C     N
  14103. C       The number of unknowns in the J-direction. N must be greater
  14104. C       than 4. The operation count is proportional to MNlog2(N), hence
  14105. C       N should be selected less than or equal to M.
  14106. C
  14107. C     AN,BN,CN
  14108. C       Real one-dimensional arrays of length N that specify the
  14109. C       coefficients in the linear equations given above.
  14110. C
  14111. C     MP
  14112. C       = 0  If AM(1) and CM(M) are not zero, which corresponds to
  14113. C            periodic boundary conditions.
  14114. C       = 1  If AM(1) = CM(M) = 0  .
  14115. C
  14116. C     M
  14117. C       The number of unknowns in the I-direction. M must be greater
  14118. C       than 4.
  14119. C
  14120. C     AM,BM,CM
  14121. C       Complex one-dimensional arrays of length M that specify the
  14122. C       coefficients in the linear equations given above.
  14123. C
  14124. C     IDIMY
  14125. C       The row (or first) dimension of the two-dimensional array Y as
  14126. C       it appears in the program calling BLKTRI.  This parameter is
  14127. C       used to specify the variable dimension of Y.  IDIMY must be at
  14128. C       least M.
  14129. C
  14130. C     Y
  14131. C       A complex two-dimensional array that specifies the values of
  14132. C       the right side of the linear system of equations given above.
  14133. C       Y must be dimensioned Y(IDIMY,N) with IDIMY .GE. M.
  14134. C
  14135. C     W
  14136. C       A one-dimensional array that must be provided by the user for
  14137. C       work space.
  14138. C             If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then
  14139. C                     W must have dimension (K-2)*L+K+5+MAX(2N,12M)
  14140. C
  14141. C             If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then
  14142. C                     W must have dimension (K-2)*L+K+5+2N+MAX(2N,12M)
  14143. C
  14144. C       **IMPORTANT** For purposes of checking, the required dimension
  14145. C                     of W is computed by BLKTRI and stored in W(1)
  14146. C                     in floating point format.
  14147. C
  14148. C     * * * * * * * * * *     On Output     * * * * * * * * * *
  14149. C
  14150. C     Y
  14151. C       Contains the solution X.
  14152. C
  14153. C     IERROR
  14154. C       An error flag that indicates invalid input parameters.  Except
  14155. C       for number zero, a solution is not attempted.
  14156. C
  14157. C       = 0  No error.
  14158. C       = 1  M is less than 5.
  14159. C       = 2  N is less than 5.
  14160. C       = 3  IDIMY is less than M.
  14161. C       = 4  BLKTRI failed while computing results that depend on the
  14162. C            coefficient arrays AN, BN, CN.  Check these arrays.
  14163. C       = 5  AN(J)*CN(J-1) is less than 0 for some J. Possible reasons
  14164. C            for this condition are
  14165. C            1. The arrays AN and CN are not correct.
  14166. C            2. Too large a grid spacing was used in the discretization
  14167. C               of the elliptic equation.
  14168. C            3. The linear equations resulted from a partial
  14169. C               differential equation which was not elliptic.
  14170. C
  14171. C     W
  14172. C       Contains intermediate values that must not be destroyed if
  14173. C       CBLKTR will be called again with IFLG=1.  W(1) contains the
  14174. C       number of locations required by W in floating point format.
  14175. C
  14176. C *Long Description:
  14177. C
  14178. C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
  14179. C
  14180. C     Dimension of   AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N)
  14181. C     Arguments      W(see argument list)
  14182. C
  14183. C     Latest         June 1979
  14184. C     Revision
  14185. C
  14186. C     Required       CBLKTR,CBLKT1,PROC,PROCP,CPROC,CPROCP,CCMPB,INXCA,
  14187. C     Subprograms    INXCB,INXCC,CPADD,PGSF,PPGSF,PPPSF,BCRH,TEVLC,
  14188. C                    R1MACH
  14189. C
  14190. C     Special        The algorithm may fail if ABS(BM(I)+BN(J)) is less
  14191. C     Conditions     than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J))
  14192. C                    for some I and J. The algorithm will also fail if
  14193. C                    AN(J)*CN(J-1) is less than zero for some J.
  14194. C                    See the description of the output parameter IERROR.
  14195. C
  14196. C     Common         CCBLK
  14197. C     Blocks
  14198. C
  14199. C     I/O            NONE
  14200. C
  14201. C     Precision      Single
  14202. C
  14203. C     Specialist     Paul Swarztrauber
  14204. C
  14205. C     Language       FORTRAN
  14206. C
  14207. C     History        CBLKTR is a complex version of BLKTRI (version 3)
  14208. C
  14209. C     Algorithm      Generalized Cyclic Reduction (see reference below)
  14210. C
  14211. C     Space
  14212. C     Required       CONTROL DATA 7600
  14213. C
  14214. C     Portability    American National Standards Institute FORTRAN.
  14215. C                    The machine accuracy is set using function R1MACH.
  14216. C
  14217. C     Required       NONE
  14218. C     Resident
  14219. C     Routines
  14220. C
  14221. C     References     Swarztrauber,P. and R. SWEET, 'Efficient Fortran
  14222. C                    Subprograms for the solution of elliptic equations'
  14223. C                    NCAR TN/IA-109, July, 1975, 138 PP.
  14224. C
  14225. C                    SWARZTRAUBER P. ,'A Direct Method for The Discrete
  14226. C                    Solution of Separable Elliptic Equations', SIAM
  14227. C                    J. Numer. Anal.,11(1974) PP. 1136-1150.
  14228. C
  14229. C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  14230. C
  14231. C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
  14232. C                 subprograms for the solution of elliptic equations,
  14233. C                 NCAR TN/IA-109, July 1975, 138 pp.
  14234. C               P. N. Swarztrauber, A direct method for the discrete
  14235. C                 solution of separable elliptic equations, SIAM Journal
  14236. C                 on Numerical Analysis 11, (1974), pp. 1136-1150.
  14237. C***ROUTINES CALLED  CBLKT1, CCMPB, CPROC, CPROCP, PROC, PROCP
  14238. C***COMMON BLOCKS    CCBLK
  14239. C***REVISION HISTORY  (YYMMDD)
  14240. C   801001  DATE WRITTEN
  14241. C   890531  Changed all specific intrinsics to generic.  (WRB)
  14242. C   890531  REVISION DATE from Version 3.2
  14243. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14244. C   920501  Reformatted the REFERENCES section.  (WRB)
  14245. C***END PROLOGUE  CBLKTR
  14246. C
  14247.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
  14248.      1                BM(*)      ,CM(*)      ,Y(IDIMY,*) ,W(*)
  14249.       EXTERNAL        PROC       ,PROCP      ,CPROC      ,CPROCP
  14250.       COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
  14251.      1                NM         ,NCMPLX     ,IK
  14252.       COMPLEX         AM         ,BM         ,CM         ,Y
  14253. C***FIRST EXECUTABLE STATEMENT  CBLKTR
  14254.       NM = N
  14255.       M2 = M+M
  14256.       IERROR = 0
  14257.       IF (M-5) 101,102,102
  14258.   101 IERROR = 1
  14259.       GO TO 119
  14260.   102 IF (NM-3) 103,104,104
  14261.   103 IERROR = 2
  14262.       GO TO 119
  14263.   104 IF (IDIMY-M) 105,106,106
  14264.   105 IERROR = 3
  14265.       GO TO 119
  14266.   106 NH = N
  14267.       NPP = NP
  14268.       IF (NPP) 107,108,107
  14269.   107 NH = NH+1
  14270.   108 IK = 2
  14271.       K = 1
  14272.   109 IK = IK+IK
  14273.       K = K+1
  14274.       IF (NH-IK) 110,110,109
  14275.   110 NL = IK
  14276.       IK = IK+IK
  14277.       NL = NL-1
  14278.       IWAH = (K-2)*IK+K+6
  14279.       IF (NPP) 111,112,111
  14280. C
  14281. C     DIVIDE W INTO WORKING SUB ARRAYS
  14282. C
  14283.   111 IW1 = IWAH
  14284.       IWBH = IW1+NM
  14285.       W(1) = IW1-1+MAX(2*NM,12*M)
  14286.       GO TO 113
  14287.   112 IWBH = IWAH+NM+NM
  14288.       IW1 = IWBH
  14289.       W(1) = IW1-1+MAX(2*NM,12*M)
  14290.       NM = NM-1
  14291. C
  14292. C SUBROUTINE CCMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS
  14293. C
  14294.   113 IF (IERROR) 119,114,119
  14295.   114 IW2 = IW1+M2
  14296.       IW3 = IW2+M2
  14297.       IWD = IW3+M2
  14298.       IWW = IWD+M2
  14299.       IWU = IWW+M2
  14300.       IF (IFLG) 116,115,116
  14301.   115 CALL CCMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
  14302.       GO TO 119
  14303.   116 IF (MP) 117,118,117
  14304. C
  14305. C SUBROUTINE CBLKT1 SOLVES THE LINEAR SYSTEM
  14306. C
  14307.   117 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
  14308.      1             W(IW3),W(IWD),W(IWW),W(IWU),PROC,CPROC)
  14309.       GO TO 119
  14310.   118 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
  14311.      1             W(IW3),W(IWD),W(IWW),W(IWU),PROCP,CPROCP)
  14312.   119 CONTINUE
  14313.       RETURN
  14314.       END
  14315. *DECK CBRT
  14316.       FUNCTION CBRT (X)
  14317. C***BEGIN PROLOGUE  CBRT
  14318. C***PURPOSE  Compute the cube root.
  14319. C***LIBRARY   SLATEC (FNLIB)
  14320. C***CATEGORY  C2
  14321. C***TYPE      SINGLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C)
  14322. C***KEYWORDS  CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS
  14323. C***AUTHOR  Fullerton, W., (LANL)
  14324. C***DESCRIPTION
  14325. C
  14326. C CBRT(X) calculates the cube root of X.
  14327. C
  14328. C***REFERENCES  (NONE)
  14329. C***ROUTINES CALLED  R1MACH, R9PAK, R9UPAK
  14330. C***REVISION HISTORY  (YYMMDD)
  14331. C   770601  DATE WRITTEN
  14332. C   890531  Changed all specific intrinsics to generic.  (WRB)
  14333. C   890531  REVISION DATE from Version 3.2
  14334. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14335. C***END PROLOGUE  CBRT
  14336.       DIMENSION CBRT2(5)
  14337.       SAVE CBRT2, NITER
  14338.       DATA CBRT2(1) / 0.6299605249 4743658E0 /
  14339.       DATA CBRT2(2) / 0.7937005259 8409974E0 /
  14340.       DATA CBRT2(3) / 1.0E0 /
  14341.       DATA CBRT2(4) / 1.2599210498 9487316E0 /
  14342.       DATA CBRT2(5) / 1.5874010519 6819947E0 /
  14343.       DATA NITER / 0 /
  14344. C***FIRST EXECUTABLE STATEMENT  CBRT
  14345.       IF (NITER.EQ.0) NITER = 1.443*LOG(-.106*LOG(0.1*R1MACH(3))) + 1.
  14346. C
  14347.       CBRT = 0.0
  14348.       IF (X.EQ.0.) RETURN
  14349. C
  14350.       CALL R9UPAK (ABS(X), Y, N)
  14351.       IXPNT = N/3
  14352.       IREM = N - 3*IXPNT + 3
  14353. C
  14354. C THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED
  14355. C TO POLYNOMIAL FORM.  THE APPROX IS NEARLY BEST IN THE SENSE OF
  14356. C RELATIVE ERROR WITH 4.085 DIGITS ACCURACY.
  14357. C
  14358.       CBRT = .439581E0 + Y*(.928549E0 + Y*(-.512653E0 + Y*.144586E0))
  14359. C
  14360.       DO 10 ITER=1,NITER
  14361.         CBRTSQ = CBRT*CBRT
  14362.         CBRT = CBRT + (Y-CBRT*CBRTSQ)/(3.0*CBRTSQ)
  14363.  10   CONTINUE
  14364. C
  14365.       CBRT = R9PAK (CBRT2(IREM)*SIGN(CBRT,X), IXPNT)
  14366.       RETURN
  14367. C
  14368.       END
  14369. *DECK CCBRT
  14370.       COMPLEX FUNCTION CCBRT (Z)
  14371. C***BEGIN PROLOGUE  CCBRT
  14372. C***PURPOSE  Compute the cube root.
  14373. C***LIBRARY   SLATEC (FNLIB)
  14374. C***CATEGORY  C2
  14375. C***TYPE      COMPLEX (CBRT-S, DCBRT-D, CCBRT-C)
  14376. C***KEYWORDS  CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS
  14377. C***AUTHOR  Fullerton, W., (LANL)
  14378. C***DESCRIPTION
  14379. C
  14380. C CCBRT(Z) calculates the complex cube root of Z.  The principal root
  14381. C for which -PI .LT. arg(Z) .LE. +PI is returned.
  14382. C
  14383. C***REFERENCES  (NONE)
  14384. C***ROUTINES CALLED  CARG, CBRT
  14385. C***REVISION HISTORY  (YYMMDD)
  14386. C   770401  DATE WRITTEN
  14387. C   890531  Changed all specific intrinsics to generic.  (WRB)
  14388. C   890531  REVISION DATE from Version 3.2
  14389. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14390. C***END PROLOGUE  CCBRT
  14391.       COMPLEX Z
  14392. C***FIRST EXECUTABLE STATEMENT  CCBRT
  14393.       THETA = CARG(Z) / 3.0
  14394.       R = CBRT (ABS(Z))
  14395. C
  14396.       CCBRT = CMPLX (R*COS(THETA), R*SIN(THETA))
  14397. C
  14398.       RETURN
  14399.       END
  14400. *DECK CCHDC
  14401.       SUBROUTINE CCHDC (A, LDA, P, WORK, JPVT, JOB, INFO)
  14402. C***BEGIN PROLOGUE  CCHDC
  14403. C***PURPOSE  Compute the Cholesky decomposition of a positive definite
  14404. C            matrix.  A pivoting option allows the user to estimate the
  14405. C            condition number of a positive definite matrix or determine
  14406. C            the rank of a positive semidefinite matrix.
  14407. C***LIBRARY   SLATEC (LINPACK)
  14408. C***CATEGORY  D2D1B
  14409. C***TYPE      COMPLEX (SCHDC-S, DCHDC-D, CCHDC-C)
  14410. C***KEYWORDS  CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX,
  14411. C             POSITIVE DEFINITE
  14412. C***AUTHOR  Dongarra, J., (ANL)
  14413. C           Stewart, G. W., (U. of Maryland)
  14414. C***DESCRIPTION
  14415. C
  14416. C     CCHDC computes the Cholesky decomposition of a positive definite
  14417. C     matrix.  A pivoting option allows the user to estimate the
  14418. C     condition of a positive definite matrix or determine the rank
  14419. C     of a positive semidefinite matrix.
  14420. C
  14421. C     On Entry
  14422. C
  14423. C         A      COMPLEX(LDA,P).
  14424. C                A contains the matrix whose decomposition is to
  14425. C                be computed.  Only the upper half of A need be stored.
  14426. C                The lower part of The array A is not referenced.
  14427. C
  14428. C         LDA    INTEGER.
  14429. C                LDA is the leading dimension of the array A.
  14430. C
  14431. C         P      INTEGER.
  14432. C                P is the order of the matrix.
  14433. C
  14434. C         WORK   COMPLEX.
  14435. C                WORK is a work array.
  14436. C
  14437. C         JPVT   INTEGER(P).
  14438. C                JPVT contains integers that control the selection
  14439. C                of the pivot elements, if pivoting has been requested.
  14440. C                Each diagonal element A(K,K)
  14441. C                is placed in one of three classes according to the
  14442. C                value of JPVT(K)).
  14443. C
  14444. C                   If JPVT(K)) .GT. 0, then X(K) is an initial
  14445. C                                      element.
  14446. C
  14447. C                   If JPVT(K)) .EQ. 0, then X(K) is a free element.
  14448. C
  14449. C                   If JPVT(K)) .LT. 0, then X(K) is a final element.
  14450. C
  14451. C                Before the decomposition is computed, initial elements
  14452. C                are moved by symmetric row and column interchanges to
  14453. C                the beginning of the array A and final
  14454. C                elements to the end.  Both initial and final elements
  14455. C                are frozen in place during the computation and only
  14456. C                free elements are moved.  At the K-th stage of the
  14457. C                reduction, if A(K,K) is occupied by a free element
  14458. C                it is interchanged with the largest free element
  14459. C                A(L,L) with L .GE. K.  JPVT is not referenced if
  14460. C                JOB .EQ. 0.
  14461. C
  14462. C        JOB     INTEGER.
  14463. C                JOB is an integer that initiates column pivoting.
  14464. C                IF JOB .EQ. 0, no pivoting is done.
  14465. C                IF JOB .NE. 0, pivoting is done.
  14466. C
  14467. C     On Return
  14468. C
  14469. C         A      A contains in its upper half the Cholesky factor
  14470. C                of the matrix A as it has been permuted by pivoting.
  14471. C
  14472. C         JPVT   JPVT(J) contains the index of the diagonal element
  14473. C                of A that was moved into the J-th position,
  14474. C                provided pivoting was requested.
  14475. C
  14476. C         INFO   contains the index of the last positive diagonal
  14477. C                element of the Cholesky factor.
  14478. C
  14479. C     For positive definite matrices INFO = P is the normal return.
  14480. C     For pivoting with positive semidefinite matrices INFO will
  14481. C     in general be less than P.  However, INFO may be greater than
  14482. C     the rank of A, since rounding error can cause an otherwise zero
  14483. C     element to be positive.  Indefinite systems will always cause
  14484. C     INFO to be less than P.
  14485. C
  14486. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  14487. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  14488. C***ROUTINES CALLED  CAXPY, CSWAP
  14489. C***REVISION HISTORY  (YYMMDD)
  14490. C   790319  DATE WRITTEN
  14491. C   890831  Modified array declarations.  (WRB)
  14492. C   890831  REVISION DATE from Version 3.2
  14493. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14494. C   900326  Removed duplicate information from DESCRIPTION section.
  14495. C           (WRB)
  14496. C   920501  Reformatted the REFERENCES section.  (WRB)
  14497. C***END PROLOGUE  CCHDC
  14498.       INTEGER LDA,P,JPVT(*),JOB,INFO
  14499.       COMPLEX A(LDA,*),WORK(*)
  14500. C
  14501.       INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL
  14502.       COMPLEX TEMP
  14503.       REAL MAXDIA
  14504.       LOGICAL SWAPK,NEGK
  14505. C***FIRST EXECUTABLE STATEMENT  CCHDC
  14506.       PL = 1
  14507.       PU = 0
  14508.       INFO = P
  14509.       IF (JOB .EQ. 0) GO TO 160
  14510. C
  14511. C        PIVOTING HAS BEEN REQUESTED. REARRANGE THE
  14512. C        THE ELEMENTS ACCORDING TO JPVT.
  14513. C
  14514.          DO 70 K = 1, P
  14515.             SWAPK = JPVT(K) .GT. 0
  14516.             NEGK = JPVT(K) .LT. 0
  14517.             JPVT(K) = K
  14518.             IF (NEGK) JPVT(K) = -JPVT(K)
  14519.             IF (.NOT.SWAPK) GO TO 60
  14520.                IF (K .EQ. PL) GO TO 50
  14521.                   CALL CSWAP(PL-1,A(1,K),1,A(1,PL),1)
  14522.                   TEMP = A(K,K)
  14523.                   A(K,K) = A(PL,PL)
  14524.                   A(PL,PL) = TEMP
  14525.                   A(PL,K) = CONJG(A(PL,K))
  14526.                   PLP1 = PL + 1
  14527.                   IF (P .LT. PLP1) GO TO 40
  14528.                   DO 30 J = PLP1, P
  14529.                      IF (J .GE. K) GO TO 10
  14530.                         TEMP = CONJG(A(PL,J))
  14531.                         A(PL,J) = CONJG(A(J,K))
  14532.                         A(J,K) = TEMP
  14533.                      GO TO 20
  14534.    10                CONTINUE
  14535.                      IF (J .EQ. K) GO TO 20
  14536.                         TEMP = A(K,J)
  14537.                         A(K,J) = A(PL,J)
  14538.                         A(PL,J) = TEMP
  14539.    20                CONTINUE
  14540.    30             CONTINUE
  14541.    40             CONTINUE
  14542.                   JPVT(K) = JPVT(PL)
  14543.                   JPVT(PL) = K
  14544.    50          CONTINUE
  14545.                PL = PL + 1
  14546.    60       CONTINUE
  14547.    70    CONTINUE
  14548.          PU = P
  14549.          IF (P .LT. PL) GO TO 150
  14550.          DO 140 KB = PL, P
  14551.             K = P - KB + PL
  14552.             IF (JPVT(K) .GE. 0) GO TO 130
  14553.                JPVT(K) = -JPVT(K)
  14554.                IF (PU .EQ. K) GO TO 120
  14555.                   CALL CSWAP(K-1,A(1,K),1,A(1,PU),1)
  14556.                   TEMP = A(K,K)
  14557.                   A(K,K) = A(PU,PU)
  14558.                   A(PU,PU) = TEMP
  14559.                   A(K,PU) = CONJG(A(K,PU))
  14560.                   KP1 = K + 1
  14561.                   IF (P .LT. KP1) GO TO 110
  14562.                   DO 100 J = KP1, P
  14563.                      IF (J .GE. PU) GO TO 80
  14564.                         TEMP = CONJG(A(K,J))
  14565.                         A(K,J) = CONJG(A(J,PU))
  14566.                         A(J,PU) = TEMP
  14567.                      GO TO 90
  14568.    80                CONTINUE
  14569.                      IF (J .EQ. PU) GO TO 90
  14570.                         TEMP = A(K,J)
  14571.                         A(K,J) = A(PU,J)
  14572.                         A(PU,J) = TEMP
  14573.    90                CONTINUE
  14574.   100             CONTINUE
  14575.   110             CONTINUE
  14576.                   JT = JPVT(K)
  14577.                   JPVT(K) = JPVT(PU)
  14578.                   JPVT(PU) = JT
  14579.   120          CONTINUE
  14580.                PU = PU - 1
  14581.   130       CONTINUE
  14582.   140    CONTINUE
  14583.   150    CONTINUE
  14584.   160 CONTINUE
  14585.       DO 270 K = 1, P
  14586. C
  14587. C        REDUCTION LOOP.
  14588. C
  14589.          MAXDIA = REAL(A(K,K))
  14590.          KP1 = K + 1
  14591.          MAXL = K
  14592. C
  14593. C        DETERMINE THE PIVOT ELEMENT.
  14594. C
  14595.          IF (K .LT. PL .OR. K .GE. PU) GO TO 190
  14596.             DO 180 L = KP1, PU
  14597.                IF (REAL(A(L,L)) .LE. MAXDIA) GO TO 170
  14598.                   MAXDIA = REAL(A(L,L))
  14599.                   MAXL = L
  14600.   170          CONTINUE
  14601.   180       CONTINUE
  14602.   190    CONTINUE
  14603. C
  14604. C        QUIT IF THE PIVOT ELEMENT IS NOT POSITIVE.
  14605. C
  14606.          IF (MAXDIA .GT. 0.0E0) GO TO 200
  14607.             INFO = K - 1
  14608.             GO TO 280
  14609.   200    CONTINUE
  14610.          IF (K .EQ. MAXL) GO TO 210
  14611. C
  14612. C           START THE PIVOTING AND UPDATE JPVT.
  14613. C
  14614.             KM1 = K - 1
  14615.             CALL CSWAP(KM1,A(1,K),1,A(1,MAXL),1)
  14616.             A(MAXL,MAXL) = A(K,K)
  14617.             A(K,K) = CMPLX(MAXDIA,0.0E0)
  14618.             JP = JPVT(MAXL)
  14619.             JPVT(MAXL) = JPVT(K)
  14620.             JPVT(K) = JP
  14621.             A(K,MAXL) = CONJG(A(K,MAXL))
  14622.   210    CONTINUE
  14623. C
  14624. C        REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS.
  14625. C
  14626.          WORK(K) = CMPLX(SQRT(REAL(A(K,K))),0.0E0)
  14627.          A(K,K) = WORK(K)
  14628.          IF (P .LT. KP1) GO TO 260
  14629.          DO 250 J = KP1, P
  14630.             IF (K .EQ. MAXL) GO TO 240
  14631.                IF (J .GE. MAXL) GO TO 220
  14632.                   TEMP = CONJG(A(K,J))
  14633.                   A(K,J) = CONJG(A(J,MAXL))
  14634.                   A(J,MAXL) = TEMP
  14635.                GO TO 230
  14636.   220          CONTINUE
  14637.                IF (J .EQ. MAXL) GO TO 230
  14638.                   TEMP = A(K,J)
  14639.                   A(K,J) = A(MAXL,J)
  14640.                   A(MAXL,J) = TEMP
  14641.   230          CONTINUE
  14642.   240       CONTINUE
  14643.             A(K,J) = A(K,J)/WORK(K)
  14644.             WORK(J) = CONJG(A(K,J))
  14645.             TEMP = -A(K,J)
  14646.             CALL CAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1)
  14647.   250    CONTINUE
  14648.   260    CONTINUE
  14649.   270 CONTINUE
  14650.   280 CONTINUE
  14651.       RETURN
  14652.       END
  14653. *DECK CCHDD
  14654.       SUBROUTINE CCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO)
  14655. C***BEGIN PROLOGUE  CCHDD
  14656. C***PURPOSE  Downdate an augmented Cholesky decomposition or the
  14657. C            triangular factor of an augmented QR decomposition.
  14658. C***LIBRARY   SLATEC (LINPACK)
  14659. C***CATEGORY  D7B
  14660. C***TYPE      COMPLEX (SCHDD-S, DCHDD-D, CCHDD-C)
  14661. C***KEYWORDS  CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK,
  14662. C             MATRIX
  14663. C***AUTHOR  Stewart, G. W., (U. of Maryland)
  14664. C***DESCRIPTION
  14665. C
  14666. C     CCHDD downdates an augmented Cholesky decomposition or the
  14667. C     triangular factor of an augmented QR decomposition.
  14668. C     Specifically, given an upper triangular matrix R of order P,  a
  14669. C     row vector X, a column vector Z, and a scalar Y, CCHDD
  14670. C     determines a unitary matrix U and a scalar ZETA such that
  14671. C
  14672. C                        (R   Z )     (RR  ZZ)
  14673. C                    U * (      )  =  (      ) ,
  14674. C                        (0 ZETA)     ( X   Y)
  14675. C
  14676. C     where RR is upper triangular.  If R and Z have been obtained
  14677. C     from the factorization of a least squares problem, then
  14678. C     RR and ZZ are the factors corresponding to the problem
  14679. C     with the observation (X,Y) removed.  In this case, if RHO
  14680. C     is the norm of the residual vector, then the norm of
  14681. C     the residual vector of the downdated problem is
  14682. C     SQRT(RHO**2 - ZETA**2).  CCHDD will simultaneously downdate
  14683. C     several triplets (Z,Y,RHO) along with R.
  14684. C     For a less terse description of what CCHDD does and how
  14685. C     it may be applied, see the LINPACK Guide.
  14686. C
  14687. C     The matrix U is determined as the product U(1)*...*U(P)
  14688. C     where U(I) is a rotation in the (P+1,I)-plane of the
  14689. C     form
  14690. C
  14691. C                       ( C(I)  -CONJG(S(I)) )
  14692. C                       (                    ) .
  14693. C                       ( S(I)       C(I)    )
  14694. C
  14695. C     the rotations are chosen so that C(I) is real.
  14696. C
  14697. C     The user is warned that a given downdating problem may
  14698. C     be impossible to accomplish or may produce
  14699. C     inaccurate results.  For example, this can happen
  14700. C     if X is near a vector whose removal will reduce the
  14701. C     rank of R.  Beware.
  14702. C
  14703. C     On Entry
  14704. C
  14705. C         R      COMPLEX(LDR,P), where LDR .GE. P.
  14706. C                R contains the upper triangular matrix
  14707. C                that is to be downdated.  The part of R
  14708. C                below the diagonal is not referenced.
  14709. C
  14710. C         LDR    INTEGER.
  14711. C                LDR is the leading dimension of the array R.
  14712. C
  14713. C         p      INTEGER.
  14714. C                P is the order of the matrix R.
  14715. C
  14716. C         X      COMPLEX(P).
  14717. C                X contains the row vector that is to
  14718. C                be removed from R.  X is not altered by CCHDD.
  14719. C
  14720. C         Z      COMPLEX(LDZ,NZ), where LDZ .GE. P.
  14721. C                Z is an array of NZ P-vectors which
  14722. C                are to be downdated along with R.
  14723. C
  14724. C         LDZ    INTEGER.
  14725. C                LDZ is the leading dimension of the array Z.
  14726. C
  14727. C         NZ     INTEGER.
  14728. C                NZ is the number of vectors to be downdated
  14729. C                NZ may be zero, in which case Z, Y, and RHO
  14730. C                are not referenced.
  14731. C
  14732. C         Y      COMPLEX(NZ).
  14733. C                Y contains the scalars for the downdating
  14734. C                of the vectors Z.  Y is not altered by CCHDD.
  14735. C
  14736. C         RHO    REAL(NZ).
  14737. C                RHO contains the norms of the residual
  14738. C                vectors that are to be downdated.
  14739. C
  14740. C     On Return
  14741. C
  14742. C         R
  14743. C         Z      contain the downdated quantities.
  14744. C         RHO
  14745. C
  14746. C         C      REAL(P).
  14747. C                C contains the cosines of the transforming
  14748. C                rotations.
  14749. C
  14750. C         S      COMPLEX(P).
  14751. C                S contains the sines of the transforming
  14752. C                rotations.
  14753. C
  14754. C         INFO   INTEGER.
  14755. C                INFO is set as follows.
  14756. C
  14757. C                   INFO = 0  if the entire downdating
  14758. C                             was successful.
  14759. C
  14760. C                   INFO =-1  if R could not be downdated.
  14761. C                             in this case, all quantities
  14762. C                             are left unaltered.
  14763. C
  14764. C                   INFO = 1  if some RHO could not be
  14765. C                             downdated.  The offending RHO's are
  14766. C                             set to -1.
  14767. C
  14768. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  14769. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  14770. C***ROUTINES CALLED  CDOTC, SCNRM2
  14771. C***REVISION HISTORY  (YYMMDD)
  14772. C   780814  DATE WRITTEN
  14773. C   890531  Changed all specific intrinsics to generic.  (WRB)
  14774. C   890831  Modified array declarations.  (WRB)
  14775. C   890831  REVISION DATE from Version 3.2
  14776. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14777. C   900326  Removed duplicate information from DESCRIPTION section.
  14778. C           (WRB)
  14779. C   920501  Reformatted the REFERENCES section.  (WRB)
  14780. C***END PROLOGUE  CCHDD
  14781.       INTEGER LDR,P,LDZ,NZ,INFO
  14782.       COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*)
  14783.       REAL RHO(*),C(*)
  14784. C
  14785.       INTEGER I,II,J
  14786.       REAL A,ALPHA,AZETA,NORM,SCNRM2
  14787.       COMPLEX CDOTC,T,ZETA,B,XX
  14788. C
  14789. C     SOLVE THE SYSTEM CTRANS(R)*A = X, PLACING THE RESULT
  14790. C     IN THE ARRAY S.
  14791. C
  14792. C***FIRST EXECUTABLE STATEMENT  CCHDD
  14793.       INFO = 0
  14794.       S(1) = CONJG(X(1))/CONJG(R(1,1))
  14795.       IF (P .LT. 2) GO TO 20
  14796.       DO 10 J = 2, P
  14797.          S(J) = CONJG(X(J)) - CDOTC(J-1,R(1,J),1,S,1)
  14798.          S(J) = S(J)/CONJG(R(J,J))
  14799.    10 CONTINUE
  14800.    20 CONTINUE
  14801.       NORM = SCNRM2(P,S,1)
  14802.       IF (NORM .LT. 1.0E0) GO TO 30
  14803.          INFO = -1
  14804.       GO TO 120
  14805.    30 CONTINUE
  14806.          ALPHA = SQRT(1.0E0-NORM**2)
  14807. C
  14808. C        DETERMINE THE TRANSFORMATIONS.
  14809. C
  14810.          DO 40 II = 1, P
  14811.             I = P - II + 1
  14812.             SCALE = ALPHA + ABS(S(I))
  14813.             A = ALPHA/SCALE
  14814.             B = S(I)/SCALE
  14815.             NORM = SQRT(A**2+REAL(B)**2+AIMAG(B)**2)
  14816.             C(I) = A/NORM
  14817.             S(I) = CONJG(B)/NORM
  14818.             ALPHA = SCALE*NORM
  14819.    40    CONTINUE
  14820. C
  14821. C        APPLY THE TRANSFORMATIONS TO R.
  14822. C
  14823.          DO 60 J = 1, P
  14824.             XX = (0.0E0,0.0E0)
  14825.             DO 50 II = 1, J
  14826.                I = J - II + 1
  14827.                T = C(I)*XX + S(I)*R(I,J)
  14828.                R(I,J) = C(I)*R(I,J) - CONJG(S(I))*XX
  14829.                XX = T
  14830.    50       CONTINUE
  14831.    60    CONTINUE
  14832. C
  14833. C        IF REQUIRED, DOWNDATE Z AND RHO.
  14834. C
  14835.          IF (NZ .LT. 1) GO TO 110
  14836.          DO 100 J = 1, NZ
  14837.             ZETA = Y(J)
  14838.             DO 70 I = 1, P
  14839.                Z(I,J) = (Z(I,J) - CONJG(S(I))*ZETA)/C(I)
  14840.                ZETA = C(I)*ZETA - S(I)*Z(I,J)
  14841.    70       CONTINUE
  14842.             AZETA = ABS(ZETA)
  14843.             IF (AZETA .LE. RHO(J)) GO TO 80
  14844.                INFO = 1
  14845.                RHO(J) = -1.0E0
  14846.             GO TO 90
  14847.    80       CONTINUE
  14848.                RHO(J) = RHO(J)*SQRT(1.0E0-(AZETA/RHO(J))**2)
  14849.    90       CONTINUE
  14850.   100    CONTINUE
  14851.   110    CONTINUE
  14852.   120 CONTINUE
  14853.       RETURN
  14854.       END
  14855. *DECK CCHEX
  14856.       SUBROUTINE CCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB)
  14857. C***BEGIN PROLOGUE  CCHEX
  14858. C***PURPOSE  Update the Cholesky factorization  A=TRANS(R)*R  of a
  14859. C            positive definite matrix A of order P under diagonal
  14860. C            permutations of the form  TRANS(E)*A*E, where E is a
  14861. C            permutation matrix.
  14862. C***LIBRARY   SLATEC (LINPACK)
  14863. C***CATEGORY  D7B
  14864. C***TYPE      COMPLEX (SCHEX-S, DCHEX-D, CCHEX-C)
  14865. C***KEYWORDS  CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK,
  14866. C             MATRIX, POSITIVE DEFINITE
  14867. C***AUTHOR  Stewart, G. W., (U. of Maryland)
  14868. C***DESCRIPTION
  14869. C
  14870. C     CCHEX updates the Cholesky factorization
  14871. C
  14872. C                   A = CTRANS(R)*R
  14873. C
  14874. C     of a positive definite matrix A of order P under diagonal
  14875. C     permutations of the form
  14876. C
  14877. C                   TRANS(E)*A*E
  14878. C
  14879. C     where E is a permutation matrix.  Specifically, given
  14880. C     an upper triangular matrix R and a permutation matrix
  14881. C     E (which is specified by K, L, and JOB), CCHEX determines
  14882. C     a unitary matrix U such that
  14883. C
  14884. C                           U*R*E = RR,
  14885. C
  14886. C     where RR is upper triangular.  At the users option, the
  14887. C     transformation U will be multiplied into the array Z.
  14888. C     If A = CTRANS(X)*X, so that R is the triangular part of the
  14889. C     QR factorization of X, then RR is the triangular part of the
  14890. C     QR factorization of X*E, i.e. X with its columns permuted.
  14891. C     For a less terse description of what CCHEX does and how
  14892. C     it may be applied, see the LINPACK Guide.
  14893. C
  14894. C     The matrix Q is determined as the product U(L-K)*...*U(1)
  14895. C     of plane rotations of the form
  14896. C
  14897. C                           (    C(I)       S(I) )
  14898. C                           (                    ) ,
  14899. C                           ( -CONJG(S(I))  C(I) )
  14900. C
  14901. C     where C(I) is real.  The rows these rotations operate on
  14902. C     are described below.
  14903. C
  14904. C     There are two types of permutations, which are determined
  14905. C     by the value of JOB.
  14906. C
  14907. C     1. Right circular shift (JOB = 1).
  14908. C
  14909. C         The columns are rearranged in the following order.
  14910. C
  14911. C                1,...,K-1,L,K,K+1,...,L-1,L+1,...,P.
  14912. C
  14913. C         U is the product of L-K rotations U(I), where U(I)
  14914. C         acts in the (L-I,L-I+1)-plane.
  14915. C
  14916. C     2. Left circular shift (JOB = 2).
  14917. C         The columns are rearranged in the following order
  14918. C
  14919. C                1,...,K-1,K+1,K+2,...,L,K,L+1,...,P.
  14920. C
  14921. C         U is the product of L-K rotations U(I), where U(I)
  14922. C         acts in the (K+I-1,K+I)-plane.
  14923. C
  14924. C     On Entry
  14925. C
  14926. C         R      COMPLEX(LDR,P), where LDR .GE. P.
  14927. C                R contains the upper triangular factor
  14928. C                that is to be updated.  Elements of R
  14929. C                below the diagonal are not referenced.
  14930. C
  14931. C         LDR    INTEGER.
  14932. C                LDR is the leading dimension of the array R.
  14933. C
  14934. C         P      INTEGER.
  14935. C                P is the order of the matrix R.
  14936. C
  14937. C         K      INTEGER.
  14938. C                K is the first column to be permuted.
  14939. C
  14940. C         L      INTEGER.
  14941. C                L is the last column to be permuted.
  14942. C                L must be strictly greater than K.
  14943. C
  14944. C         Z      COMPLEX(LDZ,NZ), where LDZ .GE. P.
  14945. C                Z is an array of NZ P-vectors into which the
  14946. C                transformation U is multiplied.  Z is
  14947. C                not referenced if NZ = 0.
  14948. C
  14949. C         LDZ    INTEGER.
  14950. C                LDZ is the leading dimension of the array Z.
  14951. C
  14952. C         NZ     INTEGER.
  14953. C                NZ is the number of columns of the matrix Z.
  14954. C
  14955. C         JOB    INTEGER.
  14956. C                JOB determines the type of permutation.
  14957. C                       JOB = 1  right circular shift.
  14958. C                       JOB = 2  left circular shift.
  14959. C
  14960. C     On Return
  14961. C
  14962. C         R      contains the updated factor.
  14963. C
  14964. C         Z      contains the updated matrix Z.
  14965. C
  14966. C         C      REAL(P).
  14967. C                C contains the cosines of the transforming rotations.
  14968. C
  14969. C         S      COMPLEX(P).
  14970. C                S contains the sines of the transforming rotations.
  14971. C
  14972. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  14973. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  14974. C***ROUTINES CALLED  CROTG
  14975. C***REVISION HISTORY  (YYMMDD)
  14976. C   780814  DATE WRITTEN
  14977. C   890531  Changed all specific intrinsics to generic.  (WRB)
  14978. C   890831  Modified array declarations.  (WRB)
  14979. C   890831  REVISION DATE from Version 3.2
  14980. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  14981. C   900326  Removed duplicate information from DESCRIPTION section.
  14982. C           (WRB)
  14983. C   920501  Reformatted the REFERENCES section.  (WRB)
  14984. C***END PROLOGUE  CCHEX
  14985.       INTEGER LDR,P,K,L,LDZ,NZ,JOB
  14986.       COMPLEX R(LDR,*),Z(LDZ,*),S(*)
  14987.       REAL C(*)
  14988. C
  14989.       INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1
  14990.       COMPLEX T
  14991. C
  14992. C     INITIALIZE
  14993. C
  14994. C***FIRST EXECUTABLE STATEMENT  CCHEX
  14995.       KM1 = K - 1
  14996.       KP1 = K + 1
  14997.       LMK = L - K
  14998.       LM1 = L - 1
  14999. C
  15000. C     PERFORM THE APPROPRIATE TASK.
  15001. C
  15002.       GO TO (10,130), JOB
  15003. C
  15004. C     RIGHT CIRCULAR SHIFT.
  15005. C
  15006.    10 CONTINUE
  15007. C
  15008. C        REORDER THE COLUMNS.
  15009. C
  15010.          DO 20 I = 1, L
  15011.             II = L - I + 1
  15012.             S(I) = R(II,L)
  15013.    20    CONTINUE
  15014.          DO 40 JJ = K, LM1
  15015.             J = LM1 - JJ + K
  15016.             DO 30 I = 1, J
  15017.                R(I,J+1) = R(I,J)
  15018.    30       CONTINUE
  15019.             R(J+1,J+1) = (0.0E0,0.0E0)
  15020.    40    CONTINUE
  15021.          IF (K .EQ. 1) GO TO 60
  15022.             DO 50 I = 1, KM1
  15023.                II = L - I + 1
  15024.                R(I,K) = S(II)
  15025.    50       CONTINUE
  15026.    60    CONTINUE
  15027. C
  15028. C        CALCULATE THE ROTATIONS.
  15029. C
  15030.          T = S(1)
  15031.          DO 70 I = 1, LMK
  15032.             CALL CROTG(S(I+1),T,C(I),S(I))
  15033.             T = S(I+1)
  15034.    70    CONTINUE
  15035.          R(K,K) = T
  15036.          DO 90 J = KP1, P
  15037.             IL = MAX(1,L-J+1)
  15038.             DO 80 II = IL, LMK
  15039.                I = L - II
  15040.                T = C(II)*R(I,J) + S(II)*R(I+1,J)
  15041.                R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J)
  15042.                R(I,J) = T
  15043.    80       CONTINUE
  15044.    90    CONTINUE
  15045. C
  15046. C        IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z.
  15047. C
  15048.          IF (NZ .LT. 1) GO TO 120
  15049.          DO 110 J = 1, NZ
  15050.             DO 100 II = 1, LMK
  15051.                I = L - II
  15052.                T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
  15053.                Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J)
  15054.                Z(I,J) = T
  15055.   100       CONTINUE
  15056.   110    CONTINUE
  15057.   120    CONTINUE
  15058.       GO TO 260
  15059. C
  15060. C     LEFT CIRCULAR SHIFT
  15061. C
  15062.   130 CONTINUE
  15063. C
  15064. C        REORDER THE COLUMNS
  15065. C
  15066.          DO 140 I = 1, K
  15067.             II = LMK + I
  15068.             S(II) = R(I,K)
  15069.   140    CONTINUE
  15070.          DO 160 J = K, LM1
  15071.             DO 150 I = 1, J
  15072.                R(I,J) = R(I,J+1)
  15073.   150       CONTINUE
  15074.             JJ = J - KM1
  15075.             S(JJ) = R(J+1,J+1)
  15076.   160    CONTINUE
  15077.          DO 170 I = 1, K
  15078.             II = LMK + I
  15079.             R(I,L) = S(II)
  15080.   170    CONTINUE
  15081.          DO 180 I = KP1, L
  15082.             R(I,L) = (0.0E0,0.0E0)
  15083.   180    CONTINUE
  15084. C
  15085. C        REDUCTION LOOP.
  15086. C
  15087.          DO 220 J = K, P
  15088.             IF (J .EQ. K) GO TO 200
  15089. C
  15090. C              APPLY THE ROTATIONS.
  15091. C
  15092.                IU = MIN(J-1,L-1)
  15093.                DO 190 I = K, IU
  15094.                   II = I - K + 1
  15095.                   T = C(II)*R(I,J) + S(II)*R(I+1,J)
  15096.                   R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J)
  15097.                   R(I,J) = T
  15098.   190          CONTINUE
  15099.   200       CONTINUE
  15100.             IF (J .GE. L) GO TO 210
  15101.                JJ = J - K + 1
  15102.                T = S(JJ)
  15103.                CALL CROTG(R(J,J),T,C(JJ),S(JJ))
  15104.   210       CONTINUE
  15105.   220    CONTINUE
  15106. C
  15107. C        APPLY THE ROTATIONS TO Z.
  15108. C
  15109.          IF (NZ .LT. 1) GO TO 250
  15110.          DO 240 J = 1, NZ
  15111.             DO 230 I = K, LM1
  15112.                II = I - KM1
  15113.                T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
  15114.                Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J)
  15115.                Z(I,J) = T
  15116.   230       CONTINUE
  15117.   240    CONTINUE
  15118.   250    CONTINUE
  15119.   260 CONTINUE
  15120.       RETURN
  15121.       END
  15122. *DECK CCHUD
  15123.       SUBROUTINE CCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S)
  15124. C***BEGIN PROLOGUE  CCHUD
  15125. C***PURPOSE  Update an augmented Cholesky decomposition of the
  15126. C            triangular part of an augmented QR decomposition.
  15127. C***LIBRARY   SLATEC (LINPACK)
  15128. C***CATEGORY  D7B
  15129. C***TYPE      COMPLEX (SCHUD-S, DCHUD-D, CCHUD-C)
  15130. C***KEYWORDS  CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX,
  15131. C             UPDATE
  15132. C***AUTHOR  Stewart, G. W., (U. of Maryland)
  15133. C***DESCRIPTION
  15134. C
  15135. C     CCHUD updates an augmented Cholesky decomposition of the
  15136. C     triangular part of an augmented QR decomposition.  Specifically,
  15137. C     given an upper triangular matrix R of order P, a row vector
  15138. C     X, a column vector Z, and a scalar Y, CCHUD determines a
  15139. C     unitary matrix U and a scalar ZETA such that
  15140. C
  15141. C
  15142. C                              (R  Z)     (RR   ZZ )
  15143. C                         U  * (    )  =  (        ) ,
  15144. C                              (X  Y)     ( 0  ZETA)
  15145. C
  15146. C     where RR is upper triangular.  If R and Z have been
  15147. C     obtained from the factorization of a least squares
  15148. C     problem, then RR and ZZ are the factors corresponding to
  15149. C     the problem with the observation (X,Y) appended.  In this
  15150. C     case, if RHO is the norm of the residual vector, then the
  15151. C     norm of the residual vector of the updated problem is
  15152. C     SQRT(RHO**2 + ZETA**2).  CCHUD will simultaneously update
  15153. C     several triplets (Z,Y,RHO).
  15154. C
  15155. C     For a less terse description of what CCHUD does and how
  15156. C     it may be applied see the LINPACK Guide.
  15157. C
  15158. C     The matrix U is determined as the product U(P)*...*U(1),
  15159. C     where U(I) is a rotation in the (I,P+1) plane of the
  15160. C     form
  15161. C
  15162. C                       (     (CI)      S(I) )
  15163. C                       (                    ) .
  15164. C                       ( -CONJG(S(I))  (CI) )
  15165. C
  15166. C     The rotations are chosen so that C(I) is real.
  15167. C
  15168. C     On Entry
  15169. C
  15170. C         R      COMPLEX(LDR,P), where LDR .GE. P.
  15171. C                R contains the upper triangular matrix
  15172. C                that is to be updated.  The part of R
  15173. C                below the diagonal is not referenced.
  15174. C
  15175. C         LDR    INTEGER.
  15176. C                LDR is the leading dimension of the array R.
  15177. C
  15178. C         P      INTEGER.
  15179. C                P is the order of the matrix R.
  15180. C
  15181. C         X      COMPLEX(P).
  15182. C                X contains the row to be added to R.  X is
  15183. C                not altered by CCHUD.
  15184. C
  15185. C         Z      COMPLEX(LDZ,NZ), where LDZ .GE. P.
  15186. C                Z is an array containing NZ P-vectors to
  15187. C                be updated with R.
  15188. C
  15189. C         LDZ    INTEGER.
  15190. C                LDZ is the leading dimension of the array Z.
  15191. C
  15192. C         NZ     INTEGER.
  15193. C                NZ is the number of vectors to be updated
  15194. C                NZ may be zero, in which case Z, Y, and RHO
  15195. C                are not referenced.
  15196. C
  15197. C         Y      COMPLEX(NZ).
  15198. C                Y contains the scalars for updating the vectors
  15199. C                Z.  Y is not altered by CCHUD.
  15200. C
  15201. C         RHO    REAL(NZ).
  15202. C                RHO contains the norms of the residual
  15203. C                vectors that are to be updated.  If RHO(J)
  15204. C                is negative, it is left unaltered.
  15205. C
  15206. C     On Return
  15207. C
  15208. C         RC
  15209. C         RHO    contain the updated quantities.
  15210. C         Z
  15211. C
  15212. C         C      REAL(P).
  15213. C                C contains the cosines of the transforming
  15214. C                rotations.
  15215. C
  15216. C         S      COMPLEX(P).
  15217. C                S contains the sines of the transforming
  15218. C                rotations.
  15219. C
  15220. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  15221. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  15222. C***ROUTINES CALLED  CROTG
  15223. C***REVISION HISTORY  (YYMMDD)
  15224. C   780814  DATE WRITTEN
  15225. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15226. C   890831  Modified array declarations.  (WRB)
  15227. C   890831  REVISION DATE from Version 3.2
  15228. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15229. C   900326  Removed duplicate information from DESCRIPTION section.
  15230. C           (WRB)
  15231. C   920501  Reformatted the REFERENCES section.  (WRB)
  15232. C***END PROLOGUE  CCHUD
  15233.       INTEGER LDR,P,LDZ,NZ
  15234.       REAL RHO(*),C(*)
  15235.       COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*)
  15236. C
  15237.       INTEGER I,J,JM1
  15238.       REAL AZETA,SCALE
  15239.       COMPLEX T,XJ,ZETA
  15240. C
  15241. C     UPDATE R.
  15242. C
  15243. C***FIRST EXECUTABLE STATEMENT  CCHUD
  15244.       DO 30 J = 1, P
  15245.          XJ = X(J)
  15246. C
  15247. C        APPLY THE PREVIOUS ROTATIONS.
  15248. C
  15249.          JM1 = J - 1
  15250.          IF (JM1 .LT. 1) GO TO 20
  15251.          DO 10 I = 1, JM1
  15252.             T = C(I)*R(I,J) + S(I)*XJ
  15253.             XJ = C(I)*XJ - CONJG(S(I))*R(I,J)
  15254.             R(I,J) = T
  15255.    10    CONTINUE
  15256.    20    CONTINUE
  15257. C
  15258. C        COMPUTE THE NEXT ROTATION.
  15259. C
  15260.          CALL CROTG(R(J,J),XJ,C(J),S(J))
  15261.    30 CONTINUE
  15262. C
  15263. C     IF REQUIRED, UPDATE Z AND RHO.
  15264. C
  15265.       IF (NZ .LT. 1) GO TO 70
  15266.       DO 60 J = 1, NZ
  15267.          ZETA = Y(J)
  15268.          DO 40 I = 1, P
  15269.             T = C(I)*Z(I,J) + S(I)*ZETA
  15270.             ZETA = C(I)*ZETA - CONJG(S(I))*Z(I,J)
  15271.             Z(I,J) = T
  15272.    40    CONTINUE
  15273.          AZETA = ABS(ZETA)
  15274.          IF (AZETA .EQ. 0.0E0 .OR. RHO(J) .LT. 0.0E0) GO TO 50
  15275.             SCALE = AZETA + RHO(J)
  15276.             RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2)
  15277.    50    CONTINUE
  15278.    60 CONTINUE
  15279.    70 CONTINUE
  15280.       RETURN
  15281.       END
  15282. *DECK CCMPB
  15283.       SUBROUTINE CCMPB (N, IERROR, AN, BN, CN, B, AH, BH)
  15284. C***BEGIN PROLOGUE  CCMPB
  15285. C***SUBSIDIARY
  15286. C***PURPOSE  Subsidiary to CBLKTR
  15287. C***LIBRARY   SLATEC
  15288. C***TYPE      COMPLEX (COMPB-S, CCMPB-C)
  15289. C***AUTHOR  (UNKNOWN)
  15290. C***DESCRIPTION
  15291. C
  15292. C     CCMPB computes the roots of the B polynomials using subroutine
  15293. C     TEVLC which is a modification the EISPACK program TQLRAT.
  15294. C     IERROR is set to 4 if either TEVLC fails or if A(J+1)*C(J) is
  15295. C     less than zero for some J.  AH,BH are temporary work arrays.
  15296. C
  15297. C***SEE ALSO  CBLKTR
  15298. C***ROUTINES CALLED  CPADD, INXCB, R1MACH, TEVLC
  15299. C***COMMON BLOCKS    CCBLK
  15300. C***REVISION HISTORY  (YYMMDD)
  15301. C   801001  DATE WRITTEN
  15302. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15303. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15304. C   900402  Added TYPE section.  (WRB)
  15305. C***END PROLOGUE  CCMPB
  15306. C
  15307.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,B(*)       ,
  15308.      1                AH(*)      ,BH(*)
  15309.       COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
  15310.      1                NM         ,NCMPLX     ,IK
  15311. C***FIRST EXECUTABLE STATEMENT  CCMPB
  15312.       EPS = R1MACH(4)
  15313.       BNORM = ABS(BN(1))
  15314.       DO 102 J=2,NM
  15315.          BNORM = MAX(BNORM,ABS(BN(J)))
  15316.          ARG = AN(J)*CN(J-1)
  15317.          IF (ARG) 119,101,101
  15318.   101    B(J) = SIGN(SQRT(ARG),AN(J))
  15319.   102 CONTINUE
  15320.       CNV = EPS*BNORM
  15321.       IF = 2**K
  15322.       KDO = K-1
  15323.       DO 108 L=1,KDO
  15324.          IR = L-1
  15325.          I2 = 2**IR
  15326.          I4 = I2+I2
  15327.          IPL = I4-1
  15328.          IFD = IF-I4
  15329.          DO 107 I=I4,IFD,I4
  15330.             CALL INXCB (I,L,IB,NB)
  15331.             IF (NB) 108,108,103
  15332.   103       JS = I-IPL
  15333.             JF = JS+NB-1
  15334.             LS = 0
  15335.             DO 104 J=JS,JF
  15336.                LS = LS+1
  15337.                BH(LS) = BN(J)
  15338.                AH(LS) = B(J)
  15339.   104       CONTINUE
  15340.             CALL TEVLC (NB,BH,AH,IERROR)
  15341.             IF (IERROR) 118,105,118
  15342.   105       LH = IB-1
  15343.             DO 106 J=1,NB
  15344.                LH = LH+1
  15345.                B(LH) = -BH(J)
  15346.   106       CONTINUE
  15347.   107    CONTINUE
  15348.   108 CONTINUE
  15349.       DO 109 J=1,NM
  15350.          B(J) = -BN(J)
  15351.   109 CONTINUE
  15352.       IF (NPP) 117,110,117
  15353.   110 NMP = NM+1
  15354.       NB = NM+NMP
  15355.       DO 112 J=1,NB
  15356.          L1 = MOD(J-1,NMP)+1
  15357.          L2 = MOD(J+NM-1,NMP)+1
  15358.          ARG = AN(L1)*CN(L2)
  15359.          IF (ARG) 119,111,111
  15360.   111    BH(J) = SIGN(SQRT(ARG),-AN(L1))
  15361.          AH(J) = -BN(L1)
  15362.   112 CONTINUE
  15363.       CALL TEVLC (NB,AH,BH,IERROR)
  15364.       IF (IERROR) 118,113,118
  15365.   113 CALL INXCB (IF,K-1,J2,LH)
  15366.       CALL INXCB (IF/2,K-1,J1,LH)
  15367.       J2 = J2+1
  15368.       LH = J2
  15369.       N2M2 = J2+NM+NM-2
  15370.   114 D1 = ABS(B(J1)-B(J2-1))
  15371.       D2 = ABS(B(J1)-B(J2))
  15372.       D3 = ABS(B(J1)-B(J2+1))
  15373.       IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 115
  15374.       B(LH) = B(J2)
  15375.       J2 = J2+1
  15376.       LH = LH+1
  15377.       IF (J2-N2M2) 114,114,116
  15378.   115 J2 = J2+1
  15379.       J1 = J1+1
  15380.       IF (J2-N2M2) 114,114,116
  15381.   116 B(LH) = B(N2M2+1)
  15382.       CALL INXCB (IF,K-1,J1,J2)
  15383.       J2 = J1+NMP+NMP
  15384.       CALL CPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2))
  15385.   117 RETURN
  15386.   118 IERROR = 4
  15387.       RETURN
  15388.   119 IERROR = 5
  15389.       RETURN
  15390.       END
  15391. *DECK CCOPY
  15392.       SUBROUTINE CCOPY (N, CX, INCX, CY, INCY)
  15393. C***BEGIN PROLOGUE  CCOPY
  15394. C***PURPOSE  Copy a vector.
  15395. C***LIBRARY   SLATEC (BLAS)
  15396. C***CATEGORY  D1A5
  15397. C***TYPE      COMPLEX (SCOPY-S, DCOPY-D, CCOPY-C)
  15398. C***KEYWORDS  BLAS, COPY, LINEAR ALGEBRA, VECTOR
  15399. C***AUTHOR  Lawson, C. L., (JPL)
  15400. C           Hanson, R. J., (SNLA)
  15401. C           Kincaid, D. R., (U. of Texas)
  15402. C           Krogh, F. T., (JPL)
  15403. C***DESCRIPTION
  15404. C
  15405. C                B L A S  Subprogram
  15406. C    Description of Parameters
  15407. C
  15408. C     --Input--
  15409. C        N  number of elements in input vector(s)
  15410. C       CX  complex vector with N elements
  15411. C     INCX  storage spacing between elements of CX
  15412. C       CY  complex vector with N elements
  15413. C     INCY  storage spacing between elements of CY
  15414. C
  15415. C     --Output--
  15416. C       CY  copy of vector CX (unchanged if N .LE. 0)
  15417. C
  15418. C     Copy complex CX to complex CY.
  15419. C     For I = 0 to N-1, copy CX(LX+I*INCX) to CY(LY+I*INCY),
  15420. C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
  15421. C     defined in a similar way using INCY.
  15422. C
  15423. C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
  15424. C                 Krogh, Basic linear algebra subprograms for Fortran
  15425. C                 usage, Algorithm No. 539, Transactions on Mathematical
  15426. C                 Software 5, 3 (September 1979), pp. 308-323.
  15427. C***ROUTINES CALLED  (NONE)
  15428. C***REVISION HISTORY  (YYMMDD)
  15429. C   791001  DATE WRITTEN
  15430. C   890831  Modified array declarations.  (WRB)
  15431. C   890831  REVISION DATE from Version 3.2
  15432. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15433. C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
  15434. C   920501  Reformatted the REFERENCES section.  (WRB)
  15435. C***END PROLOGUE  CCOPY
  15436.       COMPLEX CX(*),CY(*)
  15437. C***FIRST EXECUTABLE STATEMENT  CCOPY
  15438.       IF (N .LE. 0) RETURN
  15439.       IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
  15440. C
  15441. C     Code for unequal or nonpositive increments.
  15442. C
  15443.       KX = 1
  15444.       KY = 1
  15445.       IF (INCX .LT. 0) KX = 1+(1-N)*INCX
  15446.       IF (INCY .LT. 0) KY = 1+(1-N)*INCY
  15447.       DO 10 I = 1,N
  15448.         CY(KY) = CX(KX)
  15449.         KX = KX + INCX
  15450.         KY = KY + INCY
  15451.    10 CONTINUE
  15452.       RETURN
  15453. C
  15454. C     Code for equal, positive increments.
  15455. C
  15456.    20 NS = N*INCX
  15457.       DO 30 I = 1,NS,INCX
  15458.         CY(I) = CX(I)
  15459.    30 CONTINUE
  15460.       RETURN
  15461.       END
  15462. *DECK CCOSH
  15463.       COMPLEX FUNCTION CCOSH (Z)
  15464. C***BEGIN PROLOGUE  CCOSH
  15465. C***PURPOSE  Compute the complex hyperbolic cosine.
  15466. C***LIBRARY   SLATEC (FNLIB)
  15467. C***CATEGORY  C4C
  15468. C***TYPE      COMPLEX (CCOSH-C)
  15469. C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC COSINE
  15470. C***AUTHOR  Fullerton, W., (LANL)
  15471. C***DESCRIPTION
  15472. C
  15473. C CCOSH(Z) calculates the complex hyperbolic cosine of Z.
  15474. C
  15475. C***REFERENCES  (NONE)
  15476. C***ROUTINES CALLED  (NONE)
  15477. C***REVISION HISTORY  (YYMMDD)
  15478. C   770401  DATE WRITTEN
  15479. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15480. C   890531  REVISION DATE from Version 3.2
  15481. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15482. C***END PROLOGUE  CCOSH
  15483.       COMPLEX Z, CI
  15484.       SAVE CI
  15485.       DATA CI /(0.,1.)/
  15486. C***FIRST EXECUTABLE STATEMENT  CCOSH
  15487.       CCOSH = COS (CI*Z)
  15488. C
  15489.       RETURN
  15490.       END
  15491. *DECK CCOT
  15492.       COMPLEX FUNCTION CCOT (Z)
  15493. C***BEGIN PROLOGUE  CCOT
  15494. C***PURPOSE  Compute the cotangent.
  15495. C***LIBRARY   SLATEC (FNLIB)
  15496. C***CATEGORY  C4A
  15497. C***TYPE      COMPLEX (COT-S, DCOT-D, CCOT-C)
  15498. C***KEYWORDS  COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
  15499. C***AUTHOR  Fullerton, W., (LANL)
  15500. C***DESCRIPTION
  15501. C
  15502. C CCOT(Z) calculates the complex trigonometric cotangent of Z.
  15503. C
  15504. C***REFERENCES  (NONE)
  15505. C***ROUTINES CALLED  R1MACH, XERCLR, XERMSG
  15506. C***REVISION HISTORY  (YYMMDD)
  15507. C   770401  DATE WRITTEN
  15508. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15509. C   890531  REVISION DATE from Version 3.2
  15510. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15511. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  15512. C   900326  Removed duplicate information from DESCRIPTION section.
  15513. C           (WRB)
  15514. C***END PROLOGUE  CCOT
  15515.       COMPLEX Z
  15516.       SAVE SQEPS
  15517.       DATA SQEPS /0./
  15518. C***FIRST EXECUTABLE STATEMENT  CCOT
  15519.       IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4))
  15520. C
  15521.       X2 = 2.0*REAL(Z)
  15522.       Y2 = 2.0*AIMAG(Z)
  15523. C
  15524.       SN2X = SIN (X2)
  15525.       CALL XERCLR
  15526. C
  15527.       DEN = COSH(Y2) - COS(X2)
  15528.       IF (DEN .EQ. 0.) CALL XERMSG ('SLATEC', 'CCOT',
  15529.      +   'COT IS SINGULAR FOR INPUT Z (X IS 0 OR PI AND Y IS 0)', 2, 2)
  15530. C
  15531.       IF (ABS(DEN).GT.MAX(ABS(X2),1.)*SQEPS) GO TO 10
  15532.       CALL XERCLR
  15533.       CALL XERMSG ('SLATEC', 'CCOT',
  15534.      +   'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X TOO NEAR ' //
  15535.      +   '0 OR PI', 1, 1)
  15536. C
  15537.  10   CCOT = CMPLX (SN2X/DEN, -SINH(Y2)/DEN)
  15538. C
  15539.       RETURN
  15540.       END
  15541. *DECK CDCDOT
  15542.       COMPLEX FUNCTION CDCDOT (N, CB, CX, INCX, CY, INCY)
  15543. C***BEGIN PROLOGUE  CDCDOT
  15544. C***PURPOSE  Compute the inner product of two vectors with extended
  15545. C            precision accumulation.
  15546. C***LIBRARY   SLATEC (BLAS)
  15547. C***CATEGORY  D1A4
  15548. C***TYPE      COMPLEX (SDSDOT-S, CDCDOT-C)
  15549. C***KEYWORDS  BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
  15550. C***AUTHOR  Lawson, C. L., (JPL)
  15551. C           Hanson, R. J., (SNLA)
  15552. C           Kincaid, D. R., (U. of Texas)
  15553. C           Krogh, F. T., (JPL)
  15554. C***DESCRIPTION
  15555. C
  15556. C                B L A S  Subprogram
  15557. C    Description of Parameters
  15558. C
  15559. C     --Input--
  15560. C        N  number of elements in input vector(s)
  15561. C       CB  complex scalar to be added to inner product
  15562. C       CX  complex vector with N elements
  15563. C     INCX  storage spacing between elements of CX
  15564. C       CY  complex vector with N elements
  15565. C     INCY  storage spacing between elements of CY
  15566. C
  15567. C     --Output--
  15568. C   CDCDOT  complex dot product (CB if N .LE. 0)
  15569. C
  15570. C     Returns complex result with dot product accumulated in D.P.
  15571. C     CDCDOT = CB + sum for I = 0 to N-1 of CX(LX+I*INCY)*CY(LY+I*INCY)
  15572. C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
  15573. C     defined in a similar way using INCY.
  15574. C
  15575. C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
  15576. C                 Krogh, Basic linear algebra subprograms for Fortran
  15577. C                 usage, Algorithm No. 539, Transactions on Mathematical
  15578. C                 Software 5, 3 (September 1979), pp. 308-323.
  15579. C***ROUTINES CALLED  (NONE)
  15580. C***REVISION HISTORY  (YYMMDD)
  15581. C   791001  DATE WRITTEN
  15582. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15583. C   890531  REVISION DATE from Version 3.2
  15584. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15585. C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
  15586. C   920501  Reformatted the REFERENCES section.  (WRB)
  15587. C***END PROLOGUE  CDCDOT
  15588.       INTEGER N, INCX, INCY, I, KX, KY
  15589.       COMPLEX CX(*), CY(*), CB
  15590.       DOUBLE PRECISION DSDOTR, DSDOTI, DT1, DT2, DT3, DT4
  15591. C***FIRST EXECUTABLE STATEMENT  CDCDOT
  15592.       DSDOTR = DBLE(REAL(CB))
  15593.       DSDOTI = DBLE(AIMAG(CB))
  15594.       IF (N .LE. 0) GO TO 10
  15595.       KX = 1
  15596.       KY = 1
  15597.       IF(INCX.LT.0) KX = 1+(1-N)*INCX
  15598.       IF(INCY.LT.0) KY = 1+(1-N)*INCY
  15599.       DO 5 I = 1,N
  15600.         DT1 = DBLE(REAL(CX(KX)))
  15601.         DT2 = DBLE(REAL(CY(KY)))
  15602.         DT3 = DBLE(AIMAG(CX(KX)))
  15603.         DT4 = DBLE(AIMAG(CY(KY)))
  15604.         DSDOTR = DSDOTR+(DT1*DT2)-(DT3*DT4)
  15605.         DSDOTI = DSDOTI+(DT1*DT4)+(DT3*DT2)
  15606.         KX = KX+INCX
  15607.         KY = KY+INCY
  15608.     5 CONTINUE
  15609.    10 CDCDOT = CMPLX(REAL(DSDOTR),REAL(DSDOTI))
  15610.       RETURN
  15611.       END
  15612. *DECK CDIV
  15613.       SUBROUTINE CDIV (AR, AI, BR, BI, CR, CI)
  15614. C***BEGIN PROLOGUE  CDIV
  15615. C***SUBSIDIARY
  15616. C***PURPOSE  Compute the complex quotient of two complex numbers.
  15617. C***LIBRARY   SLATEC
  15618. C***TYPE      COMPLEX (CDIV-C)
  15619. C***AUTHOR  (UNKNOWN)
  15620. C***DESCRIPTION
  15621. C
  15622. C     Complex division, (CR,CI) = (AR,AI)/(BR,BI)
  15623. C
  15624. C***SEE ALSO  EISDOC
  15625. C***ROUTINES CALLED  (NONE)
  15626. C***REVISION HISTORY  (YYMMDD)
  15627. C   811101  DATE WRITTEN
  15628. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15629. C   900402  Added TYPE section.  (WRB)
  15630. C***END PROLOGUE  CDIV
  15631.       REAL AR,AI,BR,BI,CR,CI
  15632. C
  15633.       REAL S,ARS,AIS,BRS,BIS
  15634. C***FIRST EXECUTABLE STATEMENT  CDIV
  15635.       S = ABS(BR) + ABS(BI)
  15636.       ARS = AR/S
  15637.       AIS = AI/S
  15638.       BRS = BR/S
  15639.       BIS = BI/S
  15640.       S = BRS**2 + BIS**2
  15641.       CR = (ARS*BRS + AIS*BIS)/S
  15642.       CI = (AIS*BRS - ARS*BIS)/S
  15643.       RETURN
  15644.       END
  15645. *DECK CDOTC
  15646.       COMPLEX FUNCTION CDOTC (N, CX, INCX, CY, INCY)
  15647. C***BEGIN PROLOGUE  CDOTC
  15648. C***PURPOSE  Dot product of two complex vectors using the complex
  15649. C            conjugate of the first vector.
  15650. C***LIBRARY   SLATEC (BLAS)
  15651. C***CATEGORY  D1A4
  15652. C***TYPE      COMPLEX (CDOTC-C)
  15653. C***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
  15654. C***AUTHOR  Lawson, C. L., (JPL)
  15655. C           Hanson, R. J., (SNLA)
  15656. C           Kincaid, D. R., (U. of Texas)
  15657. C           Krogh, F. T., (JPL)
  15658. C***DESCRIPTION
  15659. C
  15660. C                B L A S  Subprogram
  15661. C    Description of Parameters
  15662. C
  15663. C     --Input--
  15664. C        N  number of elements in input vector(s)
  15665. C       CX  complex vector with N elements
  15666. C     INCX  storage spacing between elements of CX
  15667. C       CY  complex vector with N elements
  15668. C     INCY  storage spacing between elements of CY
  15669. C
  15670. C     --Output--
  15671. C    CDOTC  complex result (zero if N .LE. 0)
  15672. C
  15673. C     Returns the dot product of complex CX and CY, using CONJUGATE(CX)
  15674. C     CDOTC = SUM for I = 0 to N-1 of CONJ(CX(LX+I*INCX))*CY(LY+I*INCY),
  15675. C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
  15676. C     defined in a similar way using INCY.
  15677. C
  15678. C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
  15679. C                 Krogh, Basic linear algebra subprograms for Fortran
  15680. C                 usage, Algorithm No. 539, Transactions on Mathematical
  15681. C                 Software 5, 3 (September 1979), pp. 308-323.
  15682. C***ROUTINES CALLED  (NONE)
  15683. C***REVISION HISTORY  (YYMMDD)
  15684. C   791001  DATE WRITTEN
  15685. C   890831  Modified array declarations.  (WRB)
  15686. C   890831  REVISION DATE from Version 3.2
  15687. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15688. C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
  15689. C   920501  Reformatted the REFERENCES section.  (WRB)
  15690. C***END PROLOGUE  CDOTC
  15691.       COMPLEX CX(*),CY(*)
  15692. C***FIRST EXECUTABLE STATEMENT  CDOTC
  15693.       CDOTC = (0.0,0.0)
  15694.       IF (N .LE. 0) RETURN
  15695.       IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
  15696. C
  15697. C     Code for unequal or nonpositive increments.
  15698. C
  15699.       KX = 1
  15700.       KY = 1
  15701.       IF (INCX .LT. 0) KX = 1+(1-N)*INCX
  15702.       IF (INCY .LT. 0) KY = 1+(1-N)*INCY
  15703.       DO 10 I = 1,N
  15704.         CDOTC = CDOTC + CONJG(CX(KX))*CY(KY)
  15705.         KX = KX + INCX
  15706.         KY = KY + INCY
  15707.    10 CONTINUE
  15708.       RETURN
  15709. C
  15710. C     Code for equal, positive increments.
  15711. C
  15712.    20 NS = N*INCX
  15713.       DO 30 I = 1,NS,INCX
  15714.       CDOTC = CDOTC + CONJG(CX(I))*CY(I)
  15715.    30 CONTINUE
  15716.       RETURN
  15717.       END
  15718. *DECK CDOTU
  15719.       COMPLEX FUNCTION CDOTU (N, CX, INCX, CY, INCY)
  15720. C***BEGIN PROLOGUE  CDOTU
  15721. C***PURPOSE  Compute the inner product of two vectors.
  15722. C***LIBRARY   SLATEC (BLAS)
  15723. C***CATEGORY  D1A4
  15724. C***TYPE      COMPLEX (SDOT-S, DDOT-D, CDOTU-C)
  15725. C***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
  15726. C***AUTHOR  Lawson, C. L., (JPL)
  15727. C           Hanson, R. J., (SNLA)
  15728. C           Kincaid, D. R., (U. of Texas)
  15729. C           Krogh, F. T., (JPL)
  15730. C***DESCRIPTION
  15731. C
  15732. C                B L A S  Subprogram
  15733. C    Description of parameters
  15734. C
  15735. C     --Input--
  15736. C        N  number of elements in input vector(s)
  15737. C       CX  complex vector with N elements
  15738. C     INCX  storage spacing between elements of CX
  15739. C       CY  complex vector with N elements
  15740. C     INCY  storage spacing between elements of CY
  15741. C
  15742. C     --Output--
  15743. C    CDOTU  complex result (zero if N .LE. 0)
  15744. C
  15745. C     Returns the dot product of complex CX and CY, no conjugation
  15746. C     CDOTU = SUM for I = 0 to N-1 of  CX(LX+I*INCX) * CY(LY+I*INCY),
  15747. C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
  15748. C     defined in a similar way using INCY.
  15749. C
  15750. C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
  15751. C                 Krogh, Basic linear algebra subprograms for Fortran
  15752. C                 usage, Algorithm No. 539, Transactions on Mathematical
  15753. C                 Software 5, 3 (September 1979), pp. 308-323.
  15754. C***ROUTINES CALLED  (NONE)
  15755. C***REVISION HISTORY  (YYMMDD)
  15756. C   791001  DATE WRITTEN
  15757. C   890831  Modified array declarations.  (WRB)
  15758. C   890831  REVISION DATE from Version 3.2
  15759. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15760. C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
  15761. C   920501  Reformatted the REFERENCES section.  (WRB)
  15762. C***END PROLOGUE  CDOTU
  15763.       COMPLEX CX(*),CY(*)
  15764. C***FIRST EXECUTABLE STATEMENT  CDOTU
  15765.       CDOTU = (0.0,0.0)
  15766.       IF (N .LE. 0) RETURN
  15767.       IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
  15768. C
  15769. C     Code for unequal or nonpositive increments.
  15770. C
  15771.       KX = 1
  15772.       KY = 1
  15773.       IF (INCX .LT. 0) KX = 1+(1-N)*INCX
  15774.       IF (INCY .LT. 0) KY = 1+(1-N)*INCY
  15775.       DO 10 I = 1,N
  15776.         CDOTU = CDOTU + CX(KX)*CY(KY)
  15777.         KX = KX + INCX
  15778.         KY = KY + INCY
  15779.    10 CONTINUE
  15780.       RETURN
  15781. C
  15782. C     Code for equal, positive increments.
  15783. C
  15784.    20 NS = N*INCX
  15785.       DO 30 I = 1,NS,INCX
  15786.         CDOTU = CDOTU + CX(I)*CY(I)
  15787.    30 CONTINUE
  15788.       RETURN
  15789.       END
  15790. *DECK CEXPRL
  15791.       COMPLEX FUNCTION CEXPRL (Z)
  15792. C***BEGIN PROLOGUE  CEXPRL
  15793. C***PURPOSE  Calculate the relative error exponential (EXP(X)-1)/X.
  15794. C***LIBRARY   SLATEC (FNLIB)
  15795. C***CATEGORY  C4B
  15796. C***TYPE      COMPLEX (EXPREL-S, DEXPRL-D, CEXPRL-C)
  15797. C***KEYWORDS  ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB
  15798. C***AUTHOR  Fullerton, W., (LANL)
  15799. C***DESCRIPTION
  15800. C
  15801. C Evaluate  (EXP(Z)-1)/Z .  For small ABS(Z), we use the Taylor
  15802. C series.  We could instead use the expression
  15803. C        CEXPRL(Z) = (EXP(X)*EXP(I*Y)-1)/Z
  15804. C                  = (X*EXPREL(X) * (1 - 2*SIN(Y/2)**2) - 2*SIN(Y/2)**2
  15805. C                                    + I*SIN(Y)*(1+X*EXPREL(X))) / Z
  15806. C
  15807. C***REFERENCES  (NONE)
  15808. C***ROUTINES CALLED  R1MACH
  15809. C***REVISION HISTORY  (YYMMDD)
  15810. C   770801  DATE WRITTEN
  15811. C   890531  Changed all specific intrinsics to generic.  (WRB)
  15812. C   890531  REVISION DATE from Version 3.2
  15813. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15814. C***END PROLOGUE  CEXPRL
  15815.       COMPLEX Z
  15816.       LOGICAL FIRST
  15817.       SAVE NTERMS, RBND, FIRST
  15818.       DATA FIRST / .TRUE. /
  15819. C***FIRST EXECUTABLE STATEMENT  CEXPRL
  15820.       IF (FIRST) THEN
  15821.          ALNEPS = LOG(R1MACH(3))
  15822.          XN = 3.72 - 0.3*ALNEPS
  15823.          XLN = LOG((XN+1.0)/1.36)
  15824.          NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5
  15825.          RBND = R1MACH(3)
  15826.       ENDIF
  15827.       FIRST = .FALSE.
  15828. C
  15829.       R = ABS(Z)
  15830.       IF (R.GT.0.5) CEXPRL = (EXP(Z) - 1.0) / Z
  15831.       IF (R.GT.0.5) RETURN
  15832. C
  15833.       CEXPRL = (1.0, 0.0)
  15834.       IF (R.LT.RBND) RETURN
  15835. C
  15836.       CEXPRL = (0.0, 0.0)
  15837.       DO 20 I=1,NTERMS
  15838.         CEXPRL = 1.0 + CEXPRL*Z/(NTERMS+2-I)
  15839.  20   CONTINUE
  15840. C
  15841.       RETURN
  15842.       END
  15843. *DECK CFFTB
  15844.       SUBROUTINE CFFTB (N, C, WSAVE)
  15845. C***BEGIN PROLOGUE  CFFTB
  15846. C***SUBSIDIARY
  15847. C***PURPOSE  Compute the unnormalized inverse of CFFTF.
  15848. C***LIBRARY   SLATEC (FFTPACK)
  15849. C***CATEGORY  J1A2
  15850. C***TYPE      COMPLEX (RFFTB-S, CFFTB-C)
  15851. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  15852. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  15853. C***DESCRIPTION
  15854. C
  15855. C  ********************************************************************
  15856. C  *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
  15857. C  ********************************************************************
  15858. C  *                                                                  *
  15859. C  *   This routine uses non-standard Fortran 77 constructs and will  *
  15860. C  *   be removed from the library at a future date.  You are         *
  15861. C  *   requested to use CFFTB1.                                       *
  15862. C  *                                                                  *
  15863. C  ********************************************************************
  15864. C
  15865. C  Subroutine CFFTB computes the backward complex discrete Fourier
  15866. C  transform (the Fourier synthesis).  Equivalently, CFFTB computes
  15867. C  a complex periodic sequence from its Fourier coefficients.
  15868. C  The transform is defined below at output parameter C.
  15869. C
  15870. C  A call of CFFTF followed by a call of CFFTB will multiply the
  15871. C  sequence by N.
  15872. C
  15873. C  The array WSAVE which is used by subroutine CFFTB must be
  15874. C  initialized by calling subroutine CFFTI(N,WSAVE).
  15875. C
  15876. C  Input Parameters
  15877. C
  15878. C  N       the length of the complex sequence C.  The method is
  15879. C          more efficient when N is the product of small primes.
  15880. C
  15881. C  C       a complex array of length N which contains the sequence
  15882. C
  15883. C  WSAVE   a real work array which must be dimensioned at least 4*N+15
  15884. C          in the program that calls CFFTB.  The WSAVE array must be
  15885. C          initialized by calling subroutine CFFTI(N,WSAVE), and a
  15886. C          different WSAVE array must be used for each different
  15887. C          value of N.  This initialization does not have to be
  15888. C          repeated so long as N remains unchanged.  Thus subsequent
  15889. C          transforms can be obtained faster than the first.
  15890. C          The same WSAVE array can be used by CFFTF and CFFTB.
  15891. C
  15892. C  Output Parameters
  15893. C
  15894. C  C       For J=1,...,N
  15895. C
  15896. C              C(J)=the sum from K=1,...,N of
  15897. C
  15898. C                 C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
  15899. C
  15900. C                         where I=SQRT(-1)
  15901. C
  15902. C  WSAVE   contains initialization calculations which must not be
  15903. C          destroyed between calls of subroutine CFFTF or CFFTB
  15904. C
  15905. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  15906. C                 Computations (G. Rodrigue, ed.), Academic Press,
  15907. C                 1982, pp. 51-83.
  15908. C***ROUTINES CALLED  CFFTB1
  15909. C***REVISION HISTORY  (YYMMDD)
  15910. C   790601  DATE WRITTEN
  15911. C   830401  Modified to use SLATEC library source file format.
  15912. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  15913. C           changing dummy array size declarations (1) to (*).
  15914. C   861211  REVISION DATE from Version 3.2
  15915. C   881128  Modified by Dick Valent to meet prologue standards.
  15916. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15917. C   900131  Routine changed from user-callable to subsidiary
  15918. C           because of non-standard Fortran 77 arguments in the
  15919. C           call to CFFTB1.  (WRB)
  15920. C   920501  Reformatted the REFERENCES section.  (WRB)
  15921. C***END PROLOGUE  CFFTB
  15922.       COMPLEX C
  15923.       DIMENSION C(*), WSAVE(*)
  15924. C***FIRST EXECUTABLE STATEMENT  CFFTB
  15925.       IF (N .EQ. 1) RETURN
  15926.       IW1 = N+N+1
  15927.       IW2 = IW1+N+N
  15928.       CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
  15929.       RETURN
  15930.       END
  15931. *DECK CFFTB1
  15932.       SUBROUTINE CFFTB1 (N, C, CH, WA, IFAC)
  15933. C***BEGIN PROLOGUE  CFFTB1
  15934. C***PURPOSE  Compute the unnormalized inverse of CFFTF1.
  15935. C***LIBRARY   SLATEC (FFTPACK)
  15936. C***CATEGORY  J1A2
  15937. C***TYPE      COMPLEX (RFFTB1-S, CFFTB1-C)
  15938. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  15939. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  15940. C***DESCRIPTION
  15941. C
  15942. C  Subroutine CFFTB1 computes the backward complex discrete Fourier
  15943. C  transform (the Fourier synthesis).  Equivalently, CFFTB1 computes
  15944. C  a complex periodic sequence from its Fourier coefficients.
  15945. C  The transform is defined below at output parameter C.
  15946. C
  15947. C  A call of CFFTF1 followed by a call of CFFTB1 will multiply the
  15948. C  sequence by N.
  15949. C
  15950. C  The arrays WA and IFAC which are used by subroutine CFFTB1 must be
  15951. C  initialized by calling subroutine CFFTI1 (N, WA, IFAC).
  15952. C
  15953. C  Input Parameters
  15954. C
  15955. C  N       the length of the complex sequence C.  The method is
  15956. C          more efficient when N is the product of small primes.
  15957. C
  15958. C  C       a complex array of length N which contains the sequence
  15959. C
  15960. C  CH      a real work array of length at least 2*N
  15961. C
  15962. C  WA      a real work array which must be dimensioned at least 2*N.
  15963. C
  15964. C  IFAC    an integer work array which must be dimensioned at least 15.
  15965. C
  15966. C          The WA and IFAC arrays must be initialized by calling
  15967. C          subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC
  15968. C          arrays must be used for each different value of N.  This
  15969. C          initialization does not have to be repeated so long as N
  15970. C          remains unchanged.  Thus subsequent transforms can be
  15971. C          obtained faster than the first.  The same WA and IFAC arrays
  15972. C          can be used by CFFTF1 and CFFTB1.
  15973. C
  15974. C  Output Parameters
  15975. C
  15976. C  C       For J=1,...,N
  15977. C
  15978. C              C(J)=the sum from K=1,...,N of
  15979. C
  15980. C                 C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
  15981. C
  15982. C                         where I=SQRT(-1)
  15983. C
  15984. C  NOTE:   WA and IFAC contain initialization calculations which must
  15985. C          not be destroyed between calls of subroutine CFFTF1 or CFFTB1
  15986. C
  15987. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  15988. C                 Computations (G. Rodrigue, ed.), Academic Press,
  15989. C                 1982, pp. 51-83.
  15990. C***ROUTINES CALLED  PASSB, PASSB2, PASSB3, PASSB4, PASSB5
  15991. C***REVISION HISTORY  (YYMMDD)
  15992. C   790601  DATE WRITTEN
  15993. C   830401  Modified to use SLATEC library source file format.
  15994. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  15995. C           changing dummy array size declarations (1) to (*).
  15996. C   881128  Modified by Dick Valent to meet prologue standards.
  15997. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  15998. C   900131  Routine changed from subsidiary to user-callable.  (WRB)
  15999. C   920501  Reformatted the REFERENCES section.  (WRB)
  16000. C***END PROLOGUE  CFFTB1
  16001.       DIMENSION CH(*), C(*), WA(*), IFAC(*)
  16002. C***FIRST EXECUTABLE STATEMENT  CFFTB1
  16003.       NF = IFAC(2)
  16004.       NA = 0
  16005.       L1 = 1
  16006.       IW = 1
  16007.       DO 116 K1=1,NF
  16008.          IP = IFAC(K1+2)
  16009.          L2 = IP*L1
  16010.          IDO = N/L2
  16011.          IDOT = IDO+IDO
  16012.          IDL1 = IDOT*L1
  16013.          IF (IP .NE. 4) GO TO 103
  16014.          IX2 = IW+IDOT
  16015.          IX3 = IX2+IDOT
  16016.          IF (NA .NE. 0) GO TO 101
  16017.          CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
  16018.          GO TO 102
  16019.   101    CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  16020.   102    NA = 1-NA
  16021.          GO TO 115
  16022.   103    IF (IP .NE. 2) GO TO 106
  16023.          IF (NA .NE. 0) GO TO 104
  16024.          CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
  16025.          GO TO 105
  16026.   104    CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
  16027.   105    NA = 1-NA
  16028.          GO TO 115
  16029.   106    IF (IP .NE. 3) GO TO 109
  16030.          IX2 = IW+IDOT
  16031.          IF (NA .NE. 0) GO TO 107
  16032.          CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
  16033.          GO TO 108
  16034.   107    CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  16035.   108    NA = 1-NA
  16036.          GO TO 115
  16037.   109    IF (IP .NE. 5) GO TO 112
  16038.          IX2 = IW+IDOT
  16039.          IX3 = IX2+IDOT
  16040.          IX4 = IX3+IDOT
  16041.          IF (NA .NE. 0) GO TO 110
  16042.          CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  16043.          GO TO 111
  16044.   110    CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  16045.   111    NA = 1-NA
  16046.          GO TO 115
  16047.   112    IF (NA .NE. 0) GO TO 113
  16048.          CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
  16049.          GO TO 114
  16050.   113    CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  16051.   114    IF (NAC .NE. 0) NA = 1-NA
  16052.   115    L1 = L2
  16053.          IW = IW+(IP-1)*IDOT
  16054.   116 CONTINUE
  16055.       IF (NA .EQ. 0) RETURN
  16056.       N2 = N+N
  16057.       DO 117 I=1,N2
  16058.          C(I) = CH(I)
  16059.   117 CONTINUE
  16060.       RETURN
  16061.       END
  16062. *DECK CFFTF
  16063.       SUBROUTINE CFFTF (N, C, WSAVE)
  16064. C***BEGIN PROLOGUE  CFFTF
  16065. C***SUBSIDIARY
  16066. C***PURPOSE  Compute the forward transform of a complex, periodic
  16067. C            sequence.
  16068. C***LIBRARY   SLATEC (FFTPACK)
  16069. C***CATEGORY  J1A2
  16070. C***TYPE      COMPLEX (RFFTF-S, CFFTF-C)
  16071. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  16072. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  16073. C***DESCRIPTION
  16074. C
  16075. C  ********************************************************************
  16076. C  *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
  16077. C  ********************************************************************
  16078. C  *                                                                  *
  16079. C  *   This routine uses non-standard Fortran 77 constructs and will  *
  16080. C  *   be removed from the library at a future date.  You are         *
  16081. C  *   requested to use CFFTF1.                                       *
  16082. C  *                                                                  *
  16083. C  ********************************************************************
  16084. C
  16085. C  Subroutine CFFTF computes the forward complex discrete Fourier
  16086. C  transform (the Fourier analysis).  Equivalently, CFFTF computes
  16087. C  the Fourier coefficients of a complex periodic sequence.
  16088. C  The transform is defined below at output parameter C.
  16089. C
  16090. C  The transform is not normalized.  To obtain a normalized transform
  16091. C  the output must be divided by N.  Otherwise a call of CFFTF
  16092. C  followed by a call of CFFTB will multiply the sequence by N.
  16093. C
  16094. C  The array WSAVE which is used by subroutine CFFTF must be
  16095. C  initialized by calling subroutine CFFTI(N,WSAVE).
  16096. C
  16097. C  Input Parameters
  16098. C
  16099. C  N       the length of the complex sequence C.  The method is
  16100. C          more efficient when N is the product of small primes.
  16101. C
  16102. C  C       a complex array of length N which contains the sequence
  16103. C
  16104. C  WSAVE   a real work array which must be dimensioned at least 4*N+15
  16105. C          in the program that calls CFFTF.  The WSAVE array must be
  16106. C          initialized by calling subroutine CFFTI(N,WSAVE), and a
  16107. C          different WSAVE array must be used for each different
  16108. C          value of N.  This initialization does not have to be
  16109. C          repeated so long as N remains unchanged.  Thus subsequent
  16110. C          transforms can be obtained faster than the first.
  16111. C          The same WSAVE array can be used by CFFTF and CFFTB.
  16112. C
  16113. C  Output Parameters
  16114. C
  16115. C  C       For J=1,...,N
  16116. C
  16117. C              C(J)=the sum from K=1,...,N of
  16118. C
  16119. C                 C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
  16120. C
  16121. C                         where I=SQRT(-1)
  16122. C
  16123. C  WSAVE   contains initialization calculations which must not be
  16124. C          destroyed between calls of subroutine CFFTF or CFFTB
  16125. C
  16126. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  16127. C                 Computations (G. Rodrigue, ed.), Academic Press,
  16128. C                 1982, pp. 51-83.
  16129. C***ROUTINES CALLED  CFFTF1
  16130. C***REVISION HISTORY  (YYMMDD)
  16131. C   790601  DATE WRITTEN
  16132. C   830401  Modified to use SLATEC library source file format.
  16133. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  16134. C           changing dummy array size declarations (1) to (*).
  16135. C   861211  REVISION DATE from Version 3.2
  16136. C   881128  Modified by Dick Valent to meet prologue standards.
  16137. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16138. C   900131  Routine changed from user-callable to subsidiary
  16139. C           because of non-standard Fortran 77 arguments in the
  16140. C           call to CFFTB1.  (WRB)
  16141. C   920501  Reformatted the REFERENCES section.  (WRB)
  16142. C***END PROLOGUE  CFFTF
  16143.       COMPLEX C
  16144.       DIMENSION C(*), WSAVE(*)
  16145. C***FIRST EXECUTABLE STATEMENT  CFFTF
  16146.       IF (N .EQ. 1) RETURN
  16147.       IW1 = N+N+1
  16148.       IW2 = IW1+N+N
  16149.       CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
  16150.       RETURN
  16151.       END
  16152. *DECK CFFTF1
  16153.       SUBROUTINE CFFTF1 (N, C, CH, WA, IFAC)
  16154. C***BEGIN PROLOGUE  CFFTF1
  16155. C***PURPOSE  Compute the forward transform of a complex, periodic
  16156. C            sequence.
  16157. C***LIBRARY   SLATEC (FFTPACK)
  16158. C***CATEGORY  J1A2
  16159. C***TYPE      COMPLEX (RFFTF1-S, CFFTF1-C)
  16160. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  16161. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  16162. C***DESCRIPTION
  16163. C
  16164. C  Subroutine CFFTF1 computes the forward complex discrete Fourier
  16165. C  transform (the Fourier analysis).  Equivalently, CFFTF1 computes
  16166. C  the Fourier coefficients of a complex periodic sequence.
  16167. C  The transform is defined below at output parameter C.
  16168. C
  16169. C  The transform is not normalized.  To obtain a normalized transform
  16170. C  the output must be divided by N.  Otherwise a call of CFFTF1
  16171. C  followed by a call of CFFTB1 will multiply the sequence by N.
  16172. C
  16173. C  The arrays WA and IFAC which are used by subroutine CFFTB1 must be
  16174. C  initialized by calling subroutine CFFTI1 (N, WA, IFAC).
  16175. C
  16176. C  Input Parameters
  16177. C
  16178. C  N       the length of the complex sequence C.  The method is
  16179. C          more efficient when N is the product of small primes.
  16180. C
  16181. C  C       a complex array of length N which contains the sequence
  16182. C
  16183. C  CH      a real work array of length at least 2*N
  16184. C
  16185. C  WA      a real work array which must be dimensioned at least 2*N.
  16186. C
  16187. C  IFAC    an integer work array which must be dimensioned at least 15.
  16188. C
  16189. C          The WA and IFAC arrays must be initialized by calling
  16190. C          subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC
  16191. C          arrays must be used for each different value of N.  This
  16192. C          initialization does not have to be repeated so long as N
  16193. C          remains unchanged.  Thus subsequent transforms can be
  16194. C          obtained faster than the first.  The same WA and IFAC arrays
  16195. C          can be used by CFFTF1 and CFFTB1.
  16196. C
  16197. C  Output Parameters
  16198. C
  16199. C  C       For J=1,...,N
  16200. C
  16201. C              C(J)=the sum from K=1,...,N of
  16202. C
  16203. C                 C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
  16204. C
  16205. C                         where I=SQRT(-1)
  16206. C
  16207. C  NOTE:   WA and IFAC contain initialization calculations which must
  16208. C          not be destroyed between calls of subroutine CFFTF1 or CFFTB1
  16209. C
  16210. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  16211. C                 Computations (G. Rodrigue, ed.), Academic Press,
  16212. C                 1982, pp. 51-83.
  16213. C***ROUTINES CALLED  PASSF, PASSF2, PASSF3, PASSF4, PASSF5
  16214. C***REVISION HISTORY  (YYMMDD)
  16215. C   790601  DATE WRITTEN
  16216. C   830401  Modified to use SLATEC library source file format.
  16217. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  16218. C           changing dummy array size declarations (1) to (*).
  16219. C   881128  Modified by Dick Valent to meet prologue standards.
  16220. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16221. C   900131  Routine changed from subsidiary to user-callable.  (WRB)
  16222. C   920501  Reformatted the REFERENCES section.  (WRB)
  16223. C***END PROLOGUE  CFFTF1
  16224.       DIMENSION CH(*), C(*), WA(*), IFAC(*)
  16225. C***FIRST EXECUTABLE STATEMENT  CFFTF1
  16226.       NF = IFAC(2)
  16227.       NA = 0
  16228.       L1 = 1
  16229.       IW = 1
  16230.       DO 116 K1=1,NF
  16231.          IP = IFAC(K1+2)
  16232.          L2 = IP*L1
  16233.          IDO = N/L2
  16234.          IDOT = IDO+IDO
  16235.          IDL1 = IDOT*L1
  16236.          IF (IP .NE. 4) GO TO 103
  16237.          IX2 = IW+IDOT
  16238.          IX3 = IX2+IDOT
  16239.          IF (NA .NE. 0) GO TO 101
  16240.          CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
  16241.          GO TO 102
  16242.   101    CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  16243.   102    NA = 1-NA
  16244.          GO TO 115
  16245.   103    IF (IP .NE. 2) GO TO 106
  16246.          IF (NA .NE. 0) GO TO 104
  16247.          CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
  16248.          GO TO 105
  16249.   104    CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
  16250.   105    NA = 1-NA
  16251.          GO TO 115
  16252.   106    IF (IP .NE. 3) GO TO 109
  16253.          IX2 = IW+IDOT
  16254.          IF (NA .NE. 0) GO TO 107
  16255.          CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
  16256.          GO TO 108
  16257.   107    CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  16258.   108    NA = 1-NA
  16259.          GO TO 115
  16260.   109    IF (IP .NE. 5) GO TO 112
  16261.          IX2 = IW+IDOT
  16262.          IX3 = IX2+IDOT
  16263.          IX4 = IX3+IDOT
  16264.          IF (NA .NE. 0) GO TO 110
  16265.          CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  16266.          GO TO 111
  16267.   110    CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  16268.   111    NA = 1-NA
  16269.          GO TO 115
  16270.   112    IF (NA .NE. 0) GO TO 113
  16271.          CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
  16272.          GO TO 114
  16273.   113    CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  16274.   114    IF (NAC .NE. 0) NA = 1-NA
  16275.   115    L1 = L2
  16276.          IW = IW+(IP-1)*IDOT
  16277.   116 CONTINUE
  16278.       IF (NA .EQ. 0) RETURN
  16279.       N2 = N+N
  16280.       DO 117 I=1,N2
  16281.          C(I) = CH(I)
  16282.   117 CONTINUE
  16283.       RETURN
  16284.       END
  16285. *DECK CFFTI
  16286.       SUBROUTINE CFFTI (N, WSAVE)
  16287. C***BEGIN PROLOGUE  CFFTI
  16288. C***SUBSIDIARY
  16289. C***PURPOSE  Initialize a work array for CFFTF and CFFTB.
  16290. C***LIBRARY   SLATEC (FFTPACK)
  16291. C***CATEGORY  J1A2
  16292. C***TYPE      COMPLEX (RFFTI-S, CFFTI-C)
  16293. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  16294. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  16295. C***DESCRIPTION
  16296. C
  16297. C  ********************************************************************
  16298. C  *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
  16299. C  ********************************************************************
  16300. C  *                                                                  *
  16301. C  *   This routine uses non-standard Fortran 77 constructs and will  *
  16302. C  *   be removed from the library at a future date.  You are         *
  16303. C  *   requested to use CFFTI1.                                       *
  16304. C  *                                                                  *
  16305. C  ********************************************************************
  16306. C
  16307. C  Subroutine CFFTI initializes the array WSAVE which is used in
  16308. C  both CFFTF and CFFTB.  The prime factorization of N together with
  16309. C  a tabulation of the trigonometric functions are computed and
  16310. C  stored in WSAVE.
  16311. C
  16312. C  Input Parameter
  16313. C
  16314. C  N       the length of the sequence to be transformed
  16315. C
  16316. C  Output Parameter
  16317. C
  16318. C  WSAVE   a work array which must be dimensioned at least 4*N+15.
  16319. C          The same work array can be used for both CFFTF and CFFTB
  16320. C          as long as N remains unchanged.  Different WSAVE arrays
  16321. C          are required for different values of N.  The contents of
  16322. C          WSAVE must not be changed between calls of CFFTF or CFFTB.
  16323. C
  16324. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  16325. C                 Computations (G. Rodrigue, ed.), Academic Press,
  16326. C                 1982, pp. 51-83.
  16327. C***ROUTINES CALLED  CFFTI1
  16328. C***REVISION HISTORY  (YYMMDD)
  16329. C   790601  DATE WRITTEN
  16330. C   830401  Modified to use SLATEC library source file format.
  16331. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  16332. C           changing dummy array size declarations (1) to (*).
  16333. C   861211  REVISION DATE from Version 3.2
  16334. C   881128  Modified by Dick Valent to meet prologue standards.
  16335. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16336. C   900131  Routine changed from user-callable to subsidiary
  16337. C           because of non-standard Fortran 77 arguments in the
  16338. C           call to CFFTB1.  (WRB)
  16339. C   920501  Reformatted the REFERENCES section.  (WRB)
  16340. C***END PROLOGUE  CFFTI
  16341.       DIMENSION WSAVE(*)
  16342. C***FIRST EXECUTABLE STATEMENT  CFFTI
  16343.       IF (N .EQ. 1) RETURN
  16344.       IW1 = N+N+1
  16345.       IW2 = IW1+N+N
  16346.       CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
  16347.       RETURN
  16348.       END
  16349. *DECK CFFTI1
  16350.       SUBROUTINE CFFTI1 (N, WA, IFAC)
  16351. C***BEGIN PROLOGUE  CFFTI1
  16352. C***PURPOSE  Initialize a real and an integer work array for CFFTF1 and
  16353. C            CFFTB1.
  16354. C***LIBRARY   SLATEC (FFTPACK)
  16355. C***CATEGORY  J1A2
  16356. C***TYPE      COMPLEX (RFFTI1-S, CFFTI1-C)
  16357. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  16358. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  16359. C***DESCRIPTION
  16360. C
  16361. C  Subroutine CFFTI1 initializes the work arrays WA and IFAC which are
  16362. C  used in both CFFTF1 and CFFTB1.  The prime factorization of N and a
  16363. C  tabulation of the trigonometric functions are computed and stored in
  16364. C  IFAC and WA, respectively.
  16365. C
  16366. C  Input Parameter
  16367. C
  16368. C  N       the length of the sequence to be transformed
  16369. C
  16370. C  Output Parameters
  16371. C
  16372. C  WA      a real work array which must be dimensioned at least 2*N.
  16373. C
  16374. C  IFAC    an integer work array which must be dimensioned at least 15.
  16375. C
  16376. C          The same work arrays can be used for both CFFTF1 and CFFTB1
  16377. C          as long as N remains unchanged.  Different WA and IFAC arrays
  16378. C          are required for different values of N.  The contents of
  16379. C          WA and IFAC must not be changed between calls of CFFTF1 or
  16380. C          CFFTB1.
  16381. C
  16382. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  16383. C                 Computations (G. Rodrigue, ed.), Academic Press,
  16384. C                 1982, pp. 51-83.
  16385. C***ROUTINES CALLED  (NONE)
  16386. C***REVISION HISTORY  (YYMMDD)
  16387. C   790601  DATE WRITTEN
  16388. C   830401  Modified to use SLATEC library source file format.
  16389. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  16390. C           (a) changing dummy array size declarations (1) to (*),
  16391. C           (b) changing references to intrinsic function FLOAT
  16392. C               to REAL, and
  16393. C           (c) changing definition of variable TPI by using
  16394. C               FORTRAN intrinsic function ATAN instead of a DATA
  16395. C               statement.
  16396. C   881128  Modified by Dick Valent to meet prologue standards.
  16397. C   890531  Changed all specific intrinsics to generic.  (WRB)
  16398. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16399. C   900131  Routine changed from subsidiary to user-callable.  (WRB)
  16400. C   920501  Reformatted the REFERENCES section.  (WRB)
  16401. C***END PROLOGUE  CFFTI1
  16402.       DIMENSION WA(*), IFAC(*), NTRYH(4)
  16403.       SAVE NTRYH
  16404.       DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
  16405. C***FIRST EXECUTABLE STATEMENT  CFFTI1
  16406.       NL = N
  16407.       NF = 0
  16408.       J = 0
  16409.   101 J = J+1
  16410.       IF (J-4) 102,102,103
  16411.   102 NTRY = NTRYH(J)
  16412.       GO TO 104
  16413.   103 NTRY = NTRY+2
  16414.   104 NQ = NL/NTRY
  16415.       NR = NL-NTRY*NQ
  16416.       IF (NR) 101,105,101
  16417.   105 NF = NF+1
  16418.       IFAC(NF+2) = NTRY
  16419.       NL = NQ
  16420.       IF (NTRY .NE. 2) GO TO 107
  16421.       IF (NF .EQ. 1) GO TO 107
  16422.       DO 106 I=2,NF
  16423.          IB = NF-I+2
  16424.          IFAC(IB+2) = IFAC(IB+1)
  16425.   106 CONTINUE
  16426.       IFAC(3) = 2
  16427.   107 IF (NL .NE. 1) GO TO 104
  16428.       IFAC(1) = N
  16429.       IFAC(2) = NF
  16430.       TPI = 8.*ATAN(1.)
  16431.       ARGH = TPI/N
  16432.       I = 2
  16433.       L1 = 1
  16434.       DO 110 K1=1,NF
  16435.          IP = IFAC(K1+2)
  16436.          LD = 0
  16437.          L2 = L1*IP
  16438.          IDO = N/L2
  16439.          IDOT = IDO+IDO+2
  16440.          IPM = IP-1
  16441.          DO 109 J=1,IPM
  16442.             I1 = I
  16443.             WA(I-1) = 1.
  16444.             WA(I) = 0.
  16445.             LD = LD+L1
  16446.             FI = 0.
  16447.             ARGLD = LD*ARGH
  16448.             DO 108 II=4,IDOT,2
  16449.                I = I+2
  16450.                FI = FI+1.
  16451.                ARG = FI*ARGLD
  16452.                WA(I-1) = COS(ARG)
  16453.                WA(I) = SIN(ARG)
  16454.   108       CONTINUE
  16455.             IF (IP .LE. 5) GO TO 109
  16456.             WA(I1-1) = WA(I-1)
  16457.             WA(I1) = WA(I)
  16458.   109    CONTINUE
  16459.          L1 = L2
  16460.   110 CONTINUE
  16461.       RETURN
  16462.       END
  16463. *DECK CFOD
  16464.       SUBROUTINE CFOD (METH, ELCO, TESCO)
  16465. C***BEGIN PROLOGUE  CFOD
  16466. C***SUBSIDIARY
  16467. C***PURPOSE  Subsidiary to DEBDF
  16468. C***LIBRARY   SLATEC
  16469. C***TYPE      SINGLE PRECISION (CFOD-S, DCFOD-D)
  16470. C***AUTHOR  (UNKNOWN)
  16471. C***DESCRIPTION
  16472. C
  16473. C   CFOD defines coefficients needed in the integrator package DEBDF
  16474. C
  16475. C***SEE ALSO  DEBDF
  16476. C***ROUTINES CALLED  (NONE)
  16477. C***REVISION HISTORY  (YYMMDD)
  16478. C   800901  DATE WRITTEN
  16479. C   890531  Changed all specific intrinsics to generic.  (WRB)
  16480. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16481. C   900328  Added TYPE section.  (WRB)
  16482. C***END PROLOGUE  CFOD
  16483. C
  16484. C
  16485. CLLL. OPTIMIZE
  16486.       INTEGER METH, I, IB, NQ, NQM1, NQP1
  16487.       REAL ELCO, TESCO, AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ,
  16488.      1   RQFAC, RQ1FAC, TSIGN, XPIN
  16489.       DIMENSION ELCO(13,12), TESCO(3,12)
  16490. C-----------------------------------------------------------------------
  16491. C CFOD  IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS
  16492. C NEEDED THERE.  THE COEFFICIENTS FOR THE CURRENT METHOD, AS
  16493. C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED.
  16494. C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2.
  16495. C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.)
  16496. C CFOD  IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM,
  16497. C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED.
  16498. C
  16499. C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS.
  16500. C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF
  16501. C ORDER NQ ARE STORED IN ELCO(I,NQ).  THEY ARE GIVEN BY A GENERATING
  16502. C POLYNOMIAL, I.E.,
  16503. C     L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ.
  16504. C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY
  16505. C     DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1),    L(-1) = 0.
  16506. C FOR THE BDF METHODS, L(X) IS GIVEN BY
  16507. C     L(X) = (X+1)*(X+2)* ... *(X+NQ)/K,
  16508. C WHERE         K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ).
  16509. C
  16510. C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE
  16511. C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER.
  16512. C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP
  16513. C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER
  16514. C NQ + 1 IF K = 3.
  16515. C-----------------------------------------------------------------------
  16516.       DIMENSION PC(12)
  16517. C
  16518. C***FIRST EXECUTABLE STATEMENT  CFOD
  16519.       GO TO (100, 200), METH
  16520. C
  16521.  100  ELCO(1,1) = 1.0E0
  16522.       ELCO(2,1) = 1.0E0
  16523.       TESCO(1,1) = 0.0E0
  16524.       TESCO(2,1) = 2.0E0
  16525.       TESCO(1,2) = 1.0E0
  16526.       TESCO(3,12) = 0.0E0
  16527.       PC(1) = 1.0E0
  16528.       RQFAC = 1.0E0
  16529.       DO 140 NQ = 2,12
  16530. C-----------------------------------------------------------------------
  16531. C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
  16532. C     P(X) = (X+1)*(X+2)*...*(X+NQ-1).
  16533. C INITIALLY, P(X) = 1.
  16534. C-----------------------------------------------------------------------
  16535.         RQ1FAC = RQFAC
  16536.         RQFAC = RQFAC/NQ
  16537.         NQM1 = NQ - 1
  16538.         FNQM1 = NQM1
  16539.         NQP1 = NQ + 1
  16540. C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ----------------------------------
  16541.         PC(NQ) = 0.0E0
  16542.         DO 110 IB = 1,NQM1
  16543.           I = NQP1 - IB
  16544.  110      PC(I) = PC(I-1) + FNQM1*PC(I)
  16545.         PC(1) = FNQM1*PC(1)
  16546. C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). -----------------------
  16547.         PINT = PC(1)
  16548.         XPIN = PC(1)/2.0E0
  16549.         TSIGN = 1.0E0
  16550.         DO 120 I = 2,NQ
  16551.           TSIGN = -TSIGN
  16552.           PINT = PINT + TSIGN*PC(I)/I
  16553.  120      XPIN = XPIN + TSIGN*PC(I)/(I+1)
  16554. C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
  16555.         ELCO(1,NQ) = PINT*RQ1FAC
  16556.         ELCO(2,NQ) = 1.0E0
  16557.         DO 130 I = 2,NQ
  16558.  130      ELCO(I+1,NQ) = RQ1FAC*PC(I)/I
  16559.         AGAMQ = RQFAC*XPIN
  16560.         RAGQ = 1.0E0/AGAMQ
  16561.         TESCO(2,NQ) = RAGQ
  16562.       IF(NQ.LT.12)TESCO(1,NQP1)=RAGQ*RQFAC/NQP1
  16563.         TESCO(3,NQM1) = RAGQ
  16564.  140    CONTINUE
  16565.       RETURN
  16566. C
  16567.  200  PC(1) = 1.0E0
  16568.       RQ1FAC = 1.0E0
  16569.       DO 230 NQ = 1,5
  16570. C-----------------------------------------------------------------------
  16571. C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
  16572. C     P(X) = (X+1)*(X+2)*...*(X+NQ).
  16573. C INITIALLY, P(X) = 1.
  16574. C-----------------------------------------------------------------------
  16575.         FNQ = NQ
  16576.         NQP1 = NQ + 1
  16577. C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------
  16578.         PC(NQP1) = 0.0E0
  16579.         DO 210 IB = 1,NQ
  16580.           I = NQ + 2 - IB
  16581.  210      PC(I) = PC(I-1) + FNQ*PC(I)
  16582.         PC(1) = FNQ*PC(1)
  16583. C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
  16584.         DO 220 I = 1,NQP1
  16585.  220      ELCO(I,NQ) = PC(I)/PC(2)
  16586.         ELCO(2,NQ) = 1.0E0
  16587.         TESCO(1,NQ) = RQ1FAC
  16588.         TESCO(2,NQ) = NQP1/ELCO(1,NQ)
  16589.         TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ)
  16590.         RQ1FAC = RQ1FAC/FNQ
  16591.  230    CONTINUE
  16592.       RETURN
  16593. C----------------------- END OF SUBROUTINE CFOD  -----------------------
  16594.       END
  16595. *DECK CG
  16596.       SUBROUTINE CG (NM, N, AR, AI, WR, WI, MATZ, ZR, ZI, FV1, FV2, FV3,
  16597.      +   IERR)
  16598. C***BEGIN PROLOGUE  CG
  16599. C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
  16600. C            of a complex general matrix.
  16601. C***LIBRARY   SLATEC (EISPACK)
  16602. C***CATEGORY  D4A4
  16603. C***TYPE      COMPLEX (RG-S, CG-C)
  16604. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  16605. C***AUTHOR  Smith, B. T., et al.
  16606. C***DESCRIPTION
  16607. C
  16608. C     This subroutine calls the recommended sequence of
  16609. C     subroutines from the eigensystem subroutine package (EISPACK)
  16610. C     to find the eigenvalues and eigenvectors (if desired)
  16611. C     of a COMPLEX GENERAL matrix.
  16612. C
  16613. C     On INPUT
  16614. C
  16615. C        NM must be set to the row dimension of the two-dimensional
  16616. C          array parameters, AR, AI, ZR and ZI, as declared in the
  16617. C          calling program dimension statement.  NM is an INTEGER
  16618. C          variable.
  16619. C
  16620. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  16621. C          variable.  N must be less than or equal to NM.
  16622. C
  16623. C        AR and AI contain the real and imaginary parts, respectively,
  16624. C          of the complex general matrix.  AR and AI are two-dimensional
  16625. C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
  16626. C
  16627. C        MATZ is an INTEGER variable set equal to zero if only
  16628. C          eigenvalues are desired.  Otherwise, it is set to any
  16629. C          non-zero integer for both eigenvalues and eigenvectors.
  16630. C
  16631. C     On OUTPUT
  16632. C
  16633. C        WR and WI contain the real and imaginary parts, respectively,
  16634. C          of the eigenvalues.  WR and WI are one-dimensional REAL
  16635. C          arrays, dimensioned WR(N) and WI(N).
  16636. C
  16637. C        ZR and ZI contain the real and imaginary parts, respectively,
  16638. C          of the eigenvectors if MATZ is not zero.  ZR and ZI are
  16639. C          two-dimensional REAL arrays, dimensioned ZR(NM,N) and
  16640. C          ZI(NM,N).
  16641. C
  16642. C        IERR is an INTEGER flag set to
  16643. C          Zero       for normal return,
  16644. C          10*N       if N is greater than NM,
  16645. C          J          if the J-th eigenvalue has not been
  16646. C                     determined after a total of 30 iterations.
  16647. C                     The eigenvalues should be correct for indices
  16648. C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
  16649. C                     computed.
  16650. C
  16651. C        FV1, FV2, and FV3 are one-dimensional REAL arrays used for
  16652. C          temporary storage, dimensioned FV1(N), FV2(N), and FV3(N).
  16653. C
  16654. C     Questions and comments should be directed to B. S. Garbow,
  16655. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  16656. C     ------------------------------------------------------------------
  16657. C
  16658. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  16659. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  16660. C                 system Routines - EISPACK Guide, Springer-Verlag,
  16661. C                 1976.
  16662. C***ROUTINES CALLED  CBABK2, CBAL, COMQR, COMQR2, CORTH
  16663. C***REVISION HISTORY  (YYMMDD)
  16664. C   760101  DATE WRITTEN
  16665. C   890831  Modified array declarations.  (WRB)
  16666. C   890831  REVISION DATE from Version 3.2
  16667. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16668. C   920501  Reformatted the REFERENCES section.  (WRB)
  16669. C***END PROLOGUE  CG
  16670. C
  16671.       INTEGER N,NM,IS1,IS2,IERR,MATZ
  16672.       REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
  16673.       REAL FV1(*),FV2(*),FV3(*)
  16674. C
  16675. C***FIRST EXECUTABLE STATEMENT  CG
  16676.       IF (N .LE. NM) GO TO 10
  16677.       IERR = 10 * N
  16678.       GO TO 50
  16679. C
  16680.    10 CALL  CBAL(NM,N,AR,AI,IS1,IS2,FV1)
  16681.       CALL  CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
  16682.       IF (MATZ .NE. 0) GO TO 20
  16683. C     .......... FIND EIGENVALUES ONLY ..........
  16684.       CALL  COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
  16685.       GO TO 50
  16686. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  16687.    20 CALL  COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
  16688.       IF (IERR .NE. 0) GO TO 50
  16689.       CALL  CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
  16690.    50 RETURN
  16691.       END
  16692. *DECK CGAMMA
  16693.       COMPLEX FUNCTION CGAMMA (Z)
  16694. C***BEGIN PROLOGUE  CGAMMA
  16695. C***PURPOSE  Compute the complete Gamma function.
  16696. C***LIBRARY   SLATEC (FNLIB)
  16697. C***CATEGORY  C7A
  16698. C***TYPE      COMPLEX (GAMMA-S, DGAMMA-D, CGAMMA-C)
  16699. C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
  16700. C***AUTHOR  Fullerton, W., (LANL)
  16701. C***DESCRIPTION
  16702. C
  16703. C CGAMMA(Z) calculates the complete gamma function for COMPLEX
  16704. C argument Z.  This is a preliminary version that is portable
  16705. C but not accurate.
  16706. C
  16707. C***REFERENCES  (NONE)
  16708. C***ROUTINES CALLED  CLNGAM
  16709. C***REVISION HISTORY  (YYMMDD)
  16710. C   770701  DATE WRITTEN
  16711. C   861211  REVISION DATE from Version 3.2
  16712. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16713. C***END PROLOGUE  CGAMMA
  16714.       COMPLEX Z, CLNGAM
  16715. C***FIRST EXECUTABLE STATEMENT  CGAMMA
  16716.       CGAMMA = EXP (CLNGAM(Z))
  16717. C
  16718.       RETURN
  16719.       END
  16720. *DECK CGAMR
  16721.       COMPLEX FUNCTION CGAMR (Z)
  16722. C***BEGIN PROLOGUE  CGAMR
  16723. C***PURPOSE  Compute the reciprocal of the Gamma function.
  16724. C***LIBRARY   SLATEC (FNLIB)
  16725. C***CATEGORY  C7A
  16726. C***TYPE      COMPLEX (GAMR-S, DGAMR-D, CGAMR-C)
  16727. C***KEYWORDS  FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS
  16728. C***AUTHOR  Fullerton, W., (LANL)
  16729. C***DESCRIPTION
  16730. C
  16731. C CGAMR(Z) calculates the reciprocal gamma function for COMPLEX
  16732. C argument Z.  This is a preliminary version that is not accurate.
  16733. C
  16734. C***REFERENCES  (NONE)
  16735. C***ROUTINES CALLED  CLNGAM, XERCLR, XGETF, XSETF
  16736. C***REVISION HISTORY  (YYMMDD)
  16737. C   770701  DATE WRITTEN
  16738. C   861211  REVISION DATE from Version 3.2
  16739. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16740. C***END PROLOGUE  CGAMR
  16741.       COMPLEX Z, CLNGAM
  16742. C***FIRST EXECUTABLE STATEMENT  CGAMR
  16743.       CGAMR = (0.0, 0.0)
  16744.       X = REAL (Z)
  16745.       IF (X.LE.0.0 .AND. AINT(X).EQ.X .AND. AIMAG(Z).EQ.0.0) RETURN
  16746. C
  16747.       CALL XGETF (IROLD)
  16748.       CALL XSETF (1)
  16749.       CGAMR = CLNGAM(Z)
  16750.       CALL XERCLR
  16751.       CALL XSETF (IROLD)
  16752.       CGAMR = EXP (-CGAMR)
  16753. C
  16754.       RETURN
  16755.       END
  16756. *DECK CGBCO
  16757.       SUBROUTINE CGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z)
  16758. C***BEGIN PROLOGUE  CGBCO
  16759. C***PURPOSE  Factor a band matrix by Gaussian elimination and
  16760. C            estimate the condition number of the matrix.
  16761. C***LIBRARY   SLATEC (LINPACK)
  16762. C***CATEGORY  D2C2
  16763. C***TYPE      COMPLEX (SGBCO-S, DGBCO-D, CGBCO-C)
  16764. C***KEYWORDS  BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
  16765. C             MATRIX FACTORIZATION
  16766. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  16767. C***DESCRIPTION
  16768. C
  16769. C     CGBCO factors a complex band matrix by Gaussian
  16770. C     elimination and estimates the condition of the matrix.
  16771. C
  16772. C     If  RCOND  is not needed, CGBFA is slightly faster.
  16773. C     To solve  A*X = B , follow CGBCO by CGBSL.
  16774. C     To compute  INVERSE(A)*C , follow CGBCO by CGBSL.
  16775. C     To compute  DETERMINANT(A) , follow CGBCO by CGBDI.
  16776. C
  16777. C     On Entry
  16778. C
  16779. C        ABD     COMPLEX(LDA, N)
  16780. C                contains the matrix in band storage.  The columns
  16781. C                of the matrix are stored in the columns of  ABD  and
  16782. C                the diagonals of the matrix are stored in rows
  16783. C                ML+1 through 2*ML+MU+1 of  ABD .
  16784. C                See the comments below for details.
  16785. C
  16786. C        LDA     INTEGER
  16787. C                the leading dimension of the array  ABD .
  16788. C                LDA must be .GE. 2*ML + MU + 1 .
  16789. C
  16790. C        N       INTEGER
  16791. C                the order of the original matrix.
  16792. C
  16793. C        ML      INTEGER
  16794. C                number of diagonals below the main diagonal.
  16795. C                0 .LE. ML .LT. N .
  16796. C
  16797. C        MU      INTEGER
  16798. C                number of diagonals above the main diagonal.
  16799. C                0 .LE. MU .LT. N .
  16800. C                More efficient if  ML .LE. MU .
  16801. C
  16802. C     On Return
  16803. C
  16804. C        ABD     an upper triangular matrix in band storage and
  16805. C                the multipliers which were used to obtain it.
  16806. C                The factorization can be written  A = L*U  where
  16807. C                L  is a product of permutation and unit lower
  16808. C                triangular matrices and  U  is upper triangular.
  16809. C
  16810. C        IPVT    INTEGER(N)
  16811. C                an integer vector of pivot indices.
  16812. C
  16813. C        RCOND   REAL
  16814. C                an estimate of the reciprocal condition of  A .
  16815. C                For the system  A*X = B , relative perturbations
  16816. C                in  A  And  B  of size  EPSILON  may cause
  16817. C                relative perturbations in  X  of size  EPSILON/RCOND .
  16818. C                If  RCOND  is so small that the logical expression
  16819. C                           1.0 + RCOND .EQ. 1.0
  16820. C                is true, then  A  may be singular to working
  16821. C                precision.  In particular,  RCOND  is zero  if
  16822. C                exact singularity is detected or the estimate
  16823. C                underflows.
  16824. C
  16825. C        Z       COMPLEX(N)
  16826. C                a work vector whose contents are usually unimportant.
  16827. C                If  A  is close to a singular matrix, then  Z  is
  16828. C                an approximate null vector in the sense that
  16829. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  16830. C
  16831. C     Band Storage
  16832. C
  16833. C           if  A  is a band matrix, the following program segment
  16834. C           will set up the input.
  16835. C
  16836. C                   ML = (band width below the diagonal)
  16837. C                   MU = (band width above the diagonal)
  16838. C                   M = ML + MU + 1
  16839. C                   DO 20 J = 1, N
  16840. C                      I1 = MAX(1, J-MU)
  16841. C                      I2 = MIN(N, J+Ml)
  16842. C                      DO 10 I = I1, I2
  16843. C                         K = I - J + M
  16844. C                         ABD(K,J) = A(I,J)
  16845. C                10    CONTINUE
  16846. C                20 CONTINUE
  16847. C
  16848. C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
  16849. C           In addition, the first  ML  rows in  ABD  are used for
  16850. C           elements generated during the triangularization.
  16851. C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
  16852. C           The  ML+MU by ML+MU  upper left triangle and the
  16853. C           ML by ML  lower right triangle are not referenced.
  16854. C
  16855. C     Example:  If the original matrix is
  16856. C
  16857. C           11 12 13  0  0  0
  16858. C           21 22 23 24  0  0
  16859. C            0 32 33 34 35  0
  16860. C            0  0 43 44 45 46
  16861. C            0  0  0 54 55 56
  16862. C            0  0  0  0 65 66
  16863. C
  16864. C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABD should contain
  16865. C
  16866. C            *  *  *  +  +  +  , * = not used
  16867. C            *  * 13 24 35 46  , + = used for pivoting
  16868. C            * 12 23 34 45 56
  16869. C           11 22 33 44 55 66
  16870. C           21 32 43 54 65  *
  16871. C
  16872. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  16873. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  16874. C***ROUTINES CALLED  CAXPY, CDOTC, CGBFA, CSSCAL, SCASUM
  16875. C***REVISION HISTORY  (YYMMDD)
  16876. C   780814  DATE WRITTEN
  16877. C   890531  Changed all specific intrinsics to generic.  (WRB)
  16878. C   890831  Modified array declarations.  (WRB)
  16879. C   890831  REVISION DATE from Version 3.2
  16880. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  16881. C   900326  Removed duplicate information from DESCRIPTION section.
  16882. C           (WRB)
  16883. C   920501  Reformatted the REFERENCES section.  (WRB)
  16884. C***END PROLOGUE  CGBCO
  16885.       INTEGER LDA,N,ML,MU,IPVT(*)
  16886.       COMPLEX ABD(LDA,*),Z(*)
  16887.       REAL RCOND
  16888. C
  16889.       COMPLEX CDOTC,EK,T,WK,WKM
  16890.       REAL ANORM,S,SCASUM,SM,YNORM
  16891.       INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM
  16892.       COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
  16893.       REAL CABS1
  16894.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  16895.       CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
  16896. C
  16897. C     COMPUTE 1-NORM OF A
  16898. C
  16899. C***FIRST EXECUTABLE STATEMENT  CGBCO
  16900.       ANORM = 0.0E0
  16901.       L = ML + 1
  16902.       IS = L + MU
  16903.       DO 10 J = 1, N
  16904.          ANORM = MAX(ANORM,SCASUM(L,ABD(IS,J),1))
  16905.          IF (IS .GT. ML + 1) IS = IS - 1
  16906.          IF (J .LE. MU) L = L + 1
  16907.          IF (J .GE. N - ML) L = L - 1
  16908.    10 CONTINUE
  16909. C
  16910. C     FACTOR
  16911. C
  16912.       CALL CGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
  16913. C
  16914. C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  16915. C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
  16916. C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
  16917. C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  16918. C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
  16919. C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  16920. C
  16921. C     SOLVE CTRANS(U)*W = E
  16922. C
  16923.       EK = (1.0E0,0.0E0)
  16924.       DO 20 J = 1, N
  16925.          Z(J) = (0.0E0,0.0E0)
  16926.    20 CONTINUE
  16927.       M = ML + MU + 1
  16928.       JU = 0
  16929.       DO 100 K = 1, N
  16930.          IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  16931.          IF (CABS1(EK-Z(K)) .LE. CABS1(ABD(M,K))) GO TO 30
  16932.             S = CABS1(ABD(M,K))/CABS1(EK-Z(K))
  16933.             CALL CSSCAL(N,S,Z,1)
  16934.             EK = CMPLX(S,0.0E0)*EK
  16935.    30    CONTINUE
  16936.          WK = EK - Z(K)
  16937.          WKM = -EK - Z(K)
  16938.          S = CABS1(WK)
  16939.          SM = CABS1(WKM)
  16940.          IF (CABS1(ABD(M,K)) .EQ. 0.0E0) GO TO 40
  16941.             WK = WK/CONJG(ABD(M,K))
  16942.             WKM = WKM/CONJG(ABD(M,K))
  16943.          GO TO 50
  16944.    40    CONTINUE
  16945.             WK = (1.0E0,0.0E0)
  16946.             WKM = (1.0E0,0.0E0)
  16947.    50    CONTINUE
  16948.          KP1 = K + 1
  16949.          JU = MIN(MAX(JU,MU+IPVT(K)),N)
  16950.          MM = M
  16951.          IF (KP1 .GT. JU) GO TO 90
  16952.             DO 60 J = KP1, JU
  16953.                MM = MM - 1
  16954.                SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(MM,J)))
  16955.                Z(J) = Z(J) + WK*CONJG(ABD(MM,J))
  16956.                S = S + CABS1(Z(J))
  16957.    60       CONTINUE
  16958.             IF (S .GE. SM) GO TO 80
  16959.                T = WKM - WK
  16960.                WK = WKM
  16961.                MM = M
  16962.                DO 70 J = KP1, JU
  16963.                   MM = MM - 1
  16964.                   Z(J) = Z(J) + T*CONJG(ABD(MM,J))
  16965.    70          CONTINUE
  16966.    80       CONTINUE
  16967.    90    CONTINUE
  16968.          Z(K) = WK
  16969.   100 CONTINUE
  16970.       S = 1.0E0/SCASUM(N,Z,1)
  16971.       CALL CSSCAL(N,S,Z,1)
  16972. C
  16973. C     SOLVE CTRANS(L)*Y = W
  16974. C
  16975.       DO 120 KB = 1, N
  16976.          K = N + 1 - KB
  16977.          LM = MIN(ML,N-K)
  16978.          IF (K .LT. N) Z(K) = Z(K) + CDOTC(LM,ABD(M+1,K),1,Z(K+1),1)
  16979.          IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
  16980.             S = 1.0E0/CABS1(Z(K))
  16981.             CALL CSSCAL(N,S,Z,1)
  16982.   110    CONTINUE
  16983.          L = IPVT(K)
  16984.          T = Z(L)
  16985.          Z(L) = Z(K)
  16986.          Z(K) = T
  16987.   120 CONTINUE
  16988.       S = 1.0E0/SCASUM(N,Z,1)
  16989.       CALL CSSCAL(N,S,Z,1)
  16990. C
  16991.       YNORM = 1.0E0
  16992. C
  16993. C     SOLVE L*V = Y
  16994. C
  16995.       DO 140 K = 1, N
  16996.          L = IPVT(K)
  16997.          T = Z(L)
  16998.          Z(L) = Z(K)
  16999.          Z(K) = T
  17000.          LM = MIN(ML,N-K)
  17001.          IF (K .LT. N) CALL CAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1)
  17002.          IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
  17003.             S = 1.0E0/CABS1(Z(K))
  17004.             CALL CSSCAL(N,S,Z,1)
  17005.             YNORM = S*YNORM
  17006.   130    CONTINUE
  17007.   140 CONTINUE
  17008.       S = 1.0E0/SCASUM(N,Z,1)
  17009.       CALL CSSCAL(N,S,Z,1)
  17010.       YNORM = S*YNORM
  17011. C
  17012. C     SOLVE  U*Z = W
  17013. C
  17014.       DO 160 KB = 1, N
  17015.          K = N + 1 - KB
  17016.          IF (CABS1(Z(K)) .LE. CABS1(ABD(M,K))) GO TO 150
  17017.             S = CABS1(ABD(M,K))/CABS1(Z(K))
  17018.             CALL CSSCAL(N,S,Z,1)
  17019.             YNORM = S*YNORM
  17020.   150    CONTINUE
  17021.          IF (CABS1(ABD(M,K)) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K)
  17022.          IF (CABS1(ABD(M,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  17023.          LM = MIN(K,M) - 1
  17024.          LA = M - LM
  17025.          LZ = K - LM
  17026.          T = -Z(K)
  17027.          CALL CAXPY(LM,T,ABD(LA,K),1,Z(LZ),1)
  17028.   160 CONTINUE
  17029. C     MAKE ZNORM = 1.0
  17030.       S = 1.0E0/SCASUM(N,Z,1)
  17031.       CALL CSSCAL(N,S,Z,1)
  17032.       YNORM = S*YNORM
  17033. C
  17034.       IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  17035.       IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  17036.       RETURN
  17037.       END
  17038. *DECK CGBDI
  17039.       SUBROUTINE CGBDI (ABD, LDA, N, ML, MU, IPVT, DET)
  17040. C***BEGIN PROLOGUE  CGBDI
  17041. C***PURPOSE  Compute the determinant of a complex band matrix using the
  17042. C            factors from CGBCO or CGBFA.
  17043. C***LIBRARY   SLATEC (LINPACK)
  17044. C***CATEGORY  D3C2
  17045. C***TYPE      COMPLEX (SGBDI-S, DGBDI-D, CGBDI-C)
  17046. C***KEYWORDS  BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK,
  17047. C             MATRIX
  17048. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  17049. C***DESCRIPTION
  17050. C
  17051. C     CGBDI computes the determinant of a band matrix
  17052. C     using the factors computed by CGBCO or CGBFA.
  17053. C     If the inverse is needed, use CGBSL  N  times.
  17054. C
  17055. C     On Entry
  17056. C
  17057. C        ABD     COMPLEX(LDA, N)
  17058. C                the output from CGBCO or CGBFA.
  17059. C
  17060. C        LDA     INTEGER
  17061. C                the leading dimension of the array  ABD .
  17062. C
  17063. C        N       INTEGER
  17064. C                the order of the original matrix.
  17065. C
  17066. C        ML      INTEGER
  17067. C                number of diagonals below the main diagonal.
  17068. C
  17069. C        MU      INTEGER
  17070. C                number of diagonals above the main diagonal.
  17071. C
  17072. C        IPVT    INTEGER(N)
  17073. C                the pivot vector from CGBCO or CGBFA.
  17074. C
  17075. C     On Return
  17076. C
  17077. C        DET     COMPLEX(2)
  17078. C                determinant of original matrix.
  17079. C                Determinant = DET(1) * 10.0**DET(2)
  17080. C                with  1.0 .LE. CABS1(DET(1)) .LT. 10.0
  17081. C                or  DET(1) = 0.0 .
  17082. C
  17083. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  17084. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  17085. C***ROUTINES CALLED  (NONE)
  17086. C***REVISION HISTORY  (YYMMDD)
  17087. C   780814  DATE WRITTEN
  17088. C   890831  Modified array declarations.  (WRB)
  17089. C   890831  REVISION DATE from Version 3.2
  17090. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17091. C   900326  Removed duplicate information from DESCRIPTION section.
  17092. C           (WRB)
  17093. C   920501  Reformatted the REFERENCES section.  (WRB)
  17094. C***END PROLOGUE  CGBDI
  17095.       INTEGER LDA,N,ML,MU,IPVT(*)
  17096.       COMPLEX ABD(LDA,*),DET(2)
  17097. C
  17098.       REAL TEN
  17099.       INTEGER I,M
  17100.       COMPLEX ZDUM
  17101.       REAL CABS1
  17102. C
  17103.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  17104. C***FIRST EXECUTABLE STATEMENT  CGBDI
  17105.       M = ML + MU + 1
  17106.       DET(1) = (1.0E0,0.0E0)
  17107.       DET(2) = (0.0E0,0.0E0)
  17108.       TEN = 10.0E0
  17109.       DO 50 I = 1, N
  17110.          IF (IPVT(I) .NE. I) DET(1) = -DET(1)
  17111.          DET(1) = ABD(M,I)*DET(1)
  17112.          IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60
  17113.    10    IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20
  17114.             DET(1) = CMPLX(TEN,0.0E0)*DET(1)
  17115.             DET(2) = DET(2) - (1.0E0,0.0E0)
  17116.          GO TO 10
  17117.    20    CONTINUE
  17118.    30    IF (CABS1(DET(1)) .LT. TEN) GO TO 40
  17119.             DET(1) = DET(1)/CMPLX(TEN,0.0E0)
  17120.             DET(2) = DET(2) + (1.0E0,0.0E0)
  17121.          GO TO 30
  17122.    40    CONTINUE
  17123.    50 CONTINUE
  17124.    60 CONTINUE
  17125.       RETURN
  17126.       END
  17127. *DECK CGBFA
  17128.       SUBROUTINE CGBFA (ABD, LDA, N, ML, MU, IPVT, INFO)
  17129. C***BEGIN PROLOGUE  CGBFA
  17130. C***PURPOSE  Factor a band matrix using Gaussian elimination.
  17131. C***LIBRARY   SLATEC (LINPACK)
  17132. C***CATEGORY  D2C2
  17133. C***TYPE      COMPLEX (SGBFA-S, DGBFA-D, CGBFA-C)
  17134. C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION
  17135. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  17136. C***DESCRIPTION
  17137. C
  17138. C     CGBFA factors a complex band matrix by elimination.
  17139. C
  17140. C     CGBFA is usually called by CGBCO, but it can be called
  17141. C     directly with a saving in time if  RCOND  is not needed.
  17142. C
  17143. C     On Entry
  17144. C
  17145. C        ABD     COMPLEX(LDA, N)
  17146. C                contains the matrix in band storage.  The columns
  17147. C                of the matrix are stored in the columns of  ABD  and
  17148. C                the diagonals of the matrix are stored in rows
  17149. C                ML+1 through 2*ML+MU+1 of  ABD .
  17150. C                See the comments below for details.
  17151. C
  17152. C        LDA     INTEGER
  17153. C                the leading dimension of the array  ABD .
  17154. C                LDA must be .GE. 2*ML + MU + 1 .
  17155. C
  17156. C        N       INTEGER
  17157. C                the order of the original matrix.
  17158. C
  17159. C        ML      INTEGER
  17160. C                number of diagonals below the main diagonal.
  17161. C                0 .LE. ML .LT. N .
  17162. C
  17163. C        MU      INTEGER
  17164. C                number of diagonals above the main diagonal.
  17165. C                0 .LE. MU .LT. N .
  17166. C                More efficient if  ML .LE. MU .
  17167. C     On Return
  17168. C
  17169. C        ABD     an upper triangular matrix in band storage and
  17170. C                the multipliers which were used to obtain it.
  17171. C                The factorization can be written  A = L*U  where
  17172. C                L  is a product of permutation and unit lower
  17173. C                triangular matrices and  U  is upper triangular.
  17174. C
  17175. C        IPVT    INTEGER(N)
  17176. C                an integer vector of pivot indices.
  17177. C
  17178. C        INFO    INTEGER
  17179. C                = 0  normal value.
  17180. C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
  17181. C                     condition for this subroutine, but it does
  17182. C                     indicate that CGBSL will divide by zero if
  17183. C                     called.  Use  RCOND  in CGBCO for a reliable
  17184. C                     indication of singularity.
  17185. C
  17186. C     Band Storage
  17187. C
  17188. C           If  A  is a band matrix, the following program segment
  17189. C           will set up the input.
  17190. C
  17191. C                   ML = (band width below the diagonal)
  17192. C                   MU = (band width above the diagonal)
  17193. C                   M = ML + MU + 1
  17194. C                   DO 20 J = 1, N
  17195. C                      I1 = MAX(1, J-MU)
  17196. C                      I2 = MIN(N, J+ML)
  17197. C                      DO 10 I = I1, I2
  17198. C                         K = I - J + M
  17199. C                         ABD(K,J) = A(I,J)
  17200. C                10    CONTINUE
  17201. C                20 CONTINUE
  17202. C
  17203. C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
  17204. C           In addition, the first  ML  rows in  ABD  are used for
  17205. C           elements generated during the triangularization.
  17206. C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
  17207. C           The  ML+MU by ML+MU  upper left triangle and the
  17208. C           ML by ML  lower right triangle are not referenced.
  17209. C
  17210. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  17211. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  17212. C***ROUTINES CALLED  CAXPY, CSCAL, ICAMAX
  17213. C***REVISION HISTORY  (YYMMDD)
  17214. C   780814  DATE WRITTEN
  17215. C   890531  Changed all specific intrinsics to generic.  (WRB)
  17216. C   890831  Modified array declarations.  (WRB)
  17217. C   890831  REVISION DATE from Version 3.2
  17218. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17219. C   900326  Removed duplicate information from DESCRIPTION section.
  17220. C           (WRB)
  17221. C   920501  Reformatted the REFERENCES section.  (WRB)
  17222. C***END PROLOGUE  CGBFA
  17223.       INTEGER LDA,N,ML,MU,IPVT(*),INFO
  17224.       COMPLEX ABD(LDA,*)
  17225. C
  17226.       COMPLEX T
  17227.       INTEGER I,ICAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
  17228.       COMPLEX ZDUM
  17229.       REAL CABS1
  17230.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  17231. C
  17232. C***FIRST EXECUTABLE STATEMENT  CGBFA
  17233.       M = ML + MU + 1
  17234.       INFO = 0
  17235. C
  17236. C     ZERO INITIAL FILL-IN COLUMNS
  17237. C
  17238.       J0 = MU + 2
  17239.       J1 = MIN(N,M) - 1
  17240.       IF (J1 .LT. J0) GO TO 30
  17241.       DO 20 JZ = J0, J1
  17242.          I0 = M + 1 - JZ
  17243.          DO 10 I = I0, ML
  17244.             ABD(I,JZ) = (0.0E0,0.0E0)
  17245.    10    CONTINUE
  17246.    20 CONTINUE
  17247.    30 CONTINUE
  17248.       JZ = J1
  17249.       JU = 0
  17250. C
  17251. C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
  17252. C
  17253.       NM1 = N - 1
  17254.       IF (NM1 .LT. 1) GO TO 130
  17255.       DO 120 K = 1, NM1
  17256.          KP1 = K + 1
  17257. C
  17258. C        ZERO NEXT FILL-IN COLUMN
  17259. C
  17260.          JZ = JZ + 1
  17261.          IF (JZ .GT. N) GO TO 50
  17262.          IF (ML .LT. 1) GO TO 50
  17263.             DO 40 I = 1, ML
  17264.                ABD(I,JZ) = (0.0E0,0.0E0)
  17265.    40       CONTINUE
  17266.    50    CONTINUE
  17267. C
  17268. C        FIND L = PIVOT INDEX
  17269. C
  17270.          LM = MIN(ML,N-K)
  17271.          L = ICAMAX(LM+1,ABD(M,K),1) + M - 1
  17272.          IPVT(K) = L + K - M
  17273. C
  17274. C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
  17275. C
  17276.          IF (CABS1(ABD(L,K)) .EQ. 0.0E0) GO TO 100
  17277. C
  17278. C           INTERCHANGE IF NECESSARY
  17279. C
  17280.             IF (L .EQ. M) GO TO 60
  17281.                T = ABD(L,K)
  17282.                ABD(L,K) = ABD(M,K)
  17283.                ABD(M,K) = T
  17284.    60       CONTINUE
  17285. C
  17286. C           COMPUTE MULTIPLIERS
  17287. C
  17288.             T = -(1.0E0,0.0E0)/ABD(M,K)
  17289.             CALL CSCAL(LM,T,ABD(M+1,K),1)
  17290. C
  17291. C           ROW ELIMINATION WITH COLUMN INDEXING
  17292. C
  17293.             JU = MIN(MAX(JU,MU+IPVT(K)),N)
  17294.             MM = M
  17295.             IF (JU .LT. KP1) GO TO 90
  17296.             DO 80 J = KP1, JU
  17297.                L = L - 1
  17298.                MM = MM - 1
  17299.                T = ABD(L,J)
  17300.                IF (L .EQ. MM) GO TO 70
  17301.                   ABD(L,J) = ABD(MM,J)
  17302.                   ABD(MM,J) = T
  17303.    70          CONTINUE
  17304.                CALL CAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
  17305.    80       CONTINUE
  17306.    90       CONTINUE
  17307.          GO TO 110
  17308.   100    CONTINUE
  17309.             INFO = K
  17310.   110    CONTINUE
  17311.   120 CONTINUE
  17312.   130 CONTINUE
  17313.       IPVT(N) = N
  17314.       IF (CABS1(ABD(M,N)) .EQ. 0.0E0) INFO = N
  17315.       RETURN
  17316.       END
  17317. *DECK CGBSL
  17318.       SUBROUTINE CGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB)
  17319. C***BEGIN PROLOGUE  CGBSL
  17320. C***PURPOSE  Solve the complex band system A*X=B or CTRANS(A)*X=B using
  17321. C            the factors computed by CGBCO or CGBFA.
  17322. C***LIBRARY   SLATEC (LINPACK)
  17323. C***CATEGORY  D2C2
  17324. C***TYPE      COMPLEX (SGBSL-S, DGBSL-D, CGBSL-C)
  17325. C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
  17326. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  17327. C***DESCRIPTION
  17328. C
  17329. C     CGBSL solves the complex band system
  17330. C     A * X = B  or  CTRANS(A) * X = B
  17331. C     using the factors computed by CGBCO or CGBFA.
  17332. C
  17333. C     On Entry
  17334. C
  17335. C        ABD     COMPLEX(LDA, N)
  17336. C                the output from CGBCO or CGBFA.
  17337. C
  17338. C        LDA     INTEGER
  17339. C                the leading dimension of the array  ABD .
  17340. C
  17341. C        N       INTEGER
  17342. C                the order of the original matrix.
  17343. C
  17344. C        ML      INTEGER
  17345. C                number of diagonals below the main diagonal.
  17346. C
  17347. C        MU      INTEGER
  17348. C                number of diagonals above the main diagonal.
  17349. C
  17350. C        IPVT    INTEGER(N)
  17351. C                the pivot vector from CGBCO or CGBFA.
  17352. C
  17353. C        B       COMPLEX(N)
  17354. C                the right hand side vector.
  17355. C
  17356. C        JOB     INTEGER
  17357. C                = 0         to solve  A*X = B ,
  17358. C                = nonzero   to solve  CTRANS(A)*X = B , where
  17359. C                            CTRANS(A)  is the conjugate transpose.
  17360. C
  17361. C     On Return
  17362. C
  17363. C        B       the solution vector  X .
  17364. C
  17365. C     Error Condition
  17366. C
  17367. C        A division by zero will occur if the input factor contains a
  17368. C        zero on the diagonal.  Technically this indicates singularity
  17369. C        but it is often caused by improper arguments or improper
  17370. C        setting of LDA .  It will not occur if the subroutines are
  17371. C        called correctly and if CGBCO has set RCOND .GT. 0.0
  17372. C        or CGBFA has set INFO .EQ. 0 .
  17373. C
  17374. C     To compute  INVERSE(A) * C  where  C  is a matrix
  17375. C     with  P  columns
  17376. C           CALL CGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
  17377. C           IF (RCOND is too small) GO TO ...
  17378. C           DO 10 J = 1, P
  17379. C              CALL CGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
  17380. C        10 CONTINUE
  17381. C
  17382. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  17383. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  17384. C***ROUTINES CALLED  CAXPY, CDOTC
  17385. C***REVISION HISTORY  (YYMMDD)
  17386. C   780814  DATE WRITTEN
  17387. C   890531  Changed all specific intrinsics to generic.  (WRB)
  17388. C   890831  Modified array declarations.  (WRB)
  17389. C   890831  REVISION DATE from Version 3.2
  17390. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17391. C   900326  Removed duplicate information from DESCRIPTION section.
  17392. C           (WRB)
  17393. C   920501  Reformatted the REFERENCES section.  (WRB)
  17394. C***END PROLOGUE  CGBSL
  17395.       INTEGER LDA,N,ML,MU,IPVT(*),JOB
  17396.       COMPLEX ABD(LDA,*),B(*)
  17397. C
  17398.       COMPLEX CDOTC,T
  17399.       INTEGER K,KB,L,LA,LB,LM,M,NM1
  17400. C***FIRST EXECUTABLE STATEMENT  CGBSL
  17401.       M = MU + ML + 1
  17402.       NM1 = N - 1
  17403.       IF (JOB .NE. 0) GO TO 50
  17404. C
  17405. C        JOB = 0 , SOLVE  A * X = B
  17406. C        FIRST SOLVE L*Y = B
  17407. C
  17408.          IF (ML .EQ. 0) GO TO 30
  17409.          IF (NM1 .LT. 1) GO TO 30
  17410.             DO 20 K = 1, NM1
  17411.                LM = MIN(ML,N-K)
  17412.                L = IPVT(K)
  17413.                T = B(L)
  17414.                IF (L .EQ. K) GO TO 10
  17415.                   B(L) = B(K)
  17416.                   B(K) = T
  17417.    10          CONTINUE
  17418.                CALL CAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
  17419.    20       CONTINUE
  17420.    30    CONTINUE
  17421. C
  17422. C        NOW SOLVE  U*X = Y
  17423. C
  17424.          DO 40 KB = 1, N
  17425.             K = N + 1 - KB
  17426.             B(K) = B(K)/ABD(M,K)
  17427.             LM = MIN(K,M) - 1
  17428.             LA = M - LM
  17429.             LB = K - LM
  17430.             T = -B(K)
  17431.             CALL CAXPY(LM,T,ABD(LA,K),1,B(LB),1)
  17432.    40    CONTINUE
  17433.       GO TO 100
  17434.    50 CONTINUE
  17435. C
  17436. C        JOB = NONZERO, SOLVE  CTRANS(A) * X = B
  17437. C        FIRST SOLVE  CTRANS(U)*Y = B
  17438. C
  17439.          DO 60 K = 1, N
  17440.             LM = MIN(K,M) - 1
  17441.             LA = M - LM
  17442.             LB = K - LM
  17443.             T = CDOTC(LM,ABD(LA,K),1,B(LB),1)
  17444.             B(K) = (B(K) - T)/CONJG(ABD(M,K))
  17445.    60    CONTINUE
  17446. C
  17447. C        NOW SOLVE CTRANS(L)*X = Y
  17448. C
  17449.          IF (ML .EQ. 0) GO TO 90
  17450.          IF (NM1 .LT. 1) GO TO 90
  17451.             DO 80 KB = 1, NM1
  17452.                K = N - KB
  17453.                LM = MIN(ML,N-K)
  17454.                B(K) = B(K) + CDOTC(LM,ABD(M+1,K),1,B(K+1),1)
  17455.                L = IPVT(K)
  17456.                IF (L .EQ. K) GO TO 70
  17457.                   T = B(L)
  17458.                   B(L) = B(K)
  17459.                   B(K) = T
  17460.    70          CONTINUE
  17461.    80       CONTINUE
  17462.    90    CONTINUE
  17463.   100 CONTINUE
  17464.       RETURN
  17465.       END
  17466. *DECK CGECO
  17467.       SUBROUTINE CGECO (A, LDA, N, IPVT, RCOND, Z)
  17468. C***BEGIN PROLOGUE  CGECO
  17469. C***PURPOSE  Factor a matrix using Gaussian elimination and estimate
  17470. C            the condition number of the matrix.
  17471. C***LIBRARY   SLATEC (LINPACK)
  17472. C***CATEGORY  D2C1
  17473. C***TYPE      COMPLEX (SGECO-S, DGECO-D, CGECO-C)
  17474. C***KEYWORDS  CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
  17475. C             MATRIX FACTORIZATION
  17476. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  17477. C***DESCRIPTION
  17478. C
  17479. C     CGECO factors a complex matrix by Gaussian elimination
  17480. C     and estimates the condition of the matrix.
  17481. C
  17482. C     If  RCOND  is not needed, CGEFA is slightly faster.
  17483. C     To solve  A*X = B , follow CGECO By CGESL.
  17484. C     To Compute  INVERSE(A)*C , follow CGECO by CGESL.
  17485. C     To compute  DETERMINANT(A) , follow CGECO by CGEDI.
  17486. C     To compute  INVERSE(A) , follow CGECO by CGEDI.
  17487. C
  17488. C     On Entry
  17489. C
  17490. C        A       COMPLEX(LDA, N)
  17491. C                the matrix to be factored.
  17492. C
  17493. C        LDA     INTEGER
  17494. C                the leading dimension of the array  A .
  17495. C
  17496. C        N       INTEGER
  17497. C                the order of the matrix  A .
  17498. C
  17499. C     On Return
  17500. C
  17501. C        A       an upper triangular matrix and the multipliers
  17502. C                which were used to obtain it.
  17503. C                The factorization can be written  A = L*U  where
  17504. C                L  is a product of permutation and unit lower
  17505. C                triangular matrices and  U  is upper triangular.
  17506. C
  17507. C        IPVT    INTEGER(N)
  17508. C                an integer vector of pivot indices.
  17509. C
  17510. C        RCOND   REAL
  17511. C                an estimate of the reciprocal condition of  A .
  17512. C                For the system  A*X = B , relative perturbations
  17513. C                in  A  and  B  of size  EPSILON  may cause
  17514. C                relative perturbations in  X  of size  EPSILON/RCOND .
  17515. C                If  RCOND  is so small that the logical expression
  17516. C                           1.0 + RCOND .EQ. 1.0
  17517. C                is true, then  A  may be singular to working
  17518. C                precision.  In particular,  RCOND  is zero  if
  17519. C                exact singularity is detected or the estimate
  17520. C                underflows.
  17521. C
  17522. C        Z       COMPLEX(N)
  17523. C                a work vector whose contents are usually unimportant.
  17524. C                If  A  is close to a singular matrix, then  Z  is
  17525. C                an approximate null vector in the sense that
  17526. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  17527. C
  17528. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  17529. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  17530. C***ROUTINES CALLED  CAXPY, CDOTC, CGEFA, CSSCAL, SCASUM
  17531. C***REVISION HISTORY  (YYMMDD)
  17532. C   780814  DATE WRITTEN
  17533. C   890531  Changed all specific intrinsics to generic.  (WRB)
  17534. C   890831  Modified array declarations.  (WRB)
  17535. C   890831  REVISION DATE from Version 3.2
  17536. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17537. C   900326  Removed duplicate information from DESCRIPTION section.
  17538. C           (WRB)
  17539. C   920501  Reformatted the REFERENCES section.  (WRB)
  17540. C***END PROLOGUE  CGECO
  17541.       INTEGER LDA,N,IPVT(*)
  17542.       COMPLEX A(LDA,*),Z(*)
  17543.       REAL RCOND
  17544. C
  17545.       COMPLEX CDOTC,EK,T,WK,WKM
  17546.       REAL ANORM,S,SCASUM,SM,YNORM
  17547.       INTEGER INFO,J,K,KB,KP1,L
  17548.       COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
  17549.       REAL CABS1
  17550.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  17551.       CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
  17552. C
  17553. C     COMPUTE 1-NORM OF A
  17554. C
  17555. C***FIRST EXECUTABLE STATEMENT  CGECO
  17556.       ANORM = 0.0E0
  17557.       DO 10 J = 1, N
  17558.          ANORM = MAX(ANORM,SCASUM(N,A(1,J),1))
  17559.    10 CONTINUE
  17560. C
  17561. C     FACTOR
  17562. C
  17563.       CALL CGEFA(A,LDA,N,IPVT,INFO)
  17564. C
  17565. C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  17566. C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
  17567. C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
  17568. C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  17569. C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
  17570. C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  17571. C
  17572. C     SOLVE CTRANS(U)*W = E
  17573. C
  17574.       EK = (1.0E0,0.0E0)
  17575.       DO 20 J = 1, N
  17576.          Z(J) = (0.0E0,0.0E0)
  17577.    20 CONTINUE
  17578.       DO 100 K = 1, N
  17579.          IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  17580.          IF (CABS1(EK-Z(K)) .LE. CABS1(A(K,K))) GO TO 30
  17581.             S = CABS1(A(K,K))/CABS1(EK-Z(K))
  17582.             CALL CSSCAL(N,S,Z,1)
  17583.             EK = CMPLX(S,0.0E0)*EK
  17584.    30    CONTINUE
  17585.          WK = EK - Z(K)
  17586.          WKM = -EK - Z(K)
  17587.          S = CABS1(WK)
  17588.          SM = CABS1(WKM)
  17589.          IF (CABS1(A(K,K)) .EQ. 0.0E0) GO TO 40
  17590.             WK = WK/CONJG(A(K,K))
  17591.             WKM = WKM/CONJG(A(K,K))
  17592.          GO TO 50
  17593.    40    CONTINUE
  17594.             WK = (1.0E0,0.0E0)
  17595.             WKM = (1.0E0,0.0E0)
  17596.    50    CONTINUE
  17597.          KP1 = K + 1
  17598.          IF (KP1 .GT. N) GO TO 90
  17599.             DO 60 J = KP1, N
  17600.                SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J)))
  17601.                Z(J) = Z(J) + WK*CONJG(A(K,J))
  17602.                S = S + CABS1(Z(J))
  17603.    60       CONTINUE
  17604.             IF (S .GE. SM) GO TO 80
  17605.                T = WKM - WK
  17606.                WK = WKM
  17607.                DO 70 J = KP1, N
  17608.                   Z(J) = Z(J) + T*CONJG(A(K,J))
  17609.    70          CONTINUE
  17610.    80       CONTINUE
  17611.    90    CONTINUE
  17612.          Z(K) = WK
  17613.   100 CONTINUE
  17614.       S = 1.0E0/SCASUM(N,Z,1)
  17615.       CALL CSSCAL(N,S,Z,1)
  17616. C
  17617. C     SOLVE CTRANS(L)*Y = W
  17618. C
  17619.       DO 120 KB = 1, N
  17620.          K = N + 1 - KB
  17621.          IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1)
  17622.          IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
  17623.             S = 1.0E0/CABS1(Z(K))
  17624.             CALL CSSCAL(N,S,Z,1)
  17625.   110    CONTINUE
  17626.          L = IPVT(K)
  17627.          T = Z(L)
  17628.          Z(L) = Z(K)
  17629.          Z(K) = T
  17630.   120 CONTINUE
  17631.       S = 1.0E0/SCASUM(N,Z,1)
  17632.       CALL CSSCAL(N,S,Z,1)
  17633. C
  17634.       YNORM = 1.0E0
  17635. C
  17636. C     SOLVE L*V = Y
  17637. C
  17638.       DO 140 K = 1, N
  17639.          L = IPVT(K)
  17640.          T = Z(L)
  17641.          Z(L) = Z(K)
  17642.          Z(K) = T
  17643.          IF (K .LT. N) CALL CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
  17644.          IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
  17645.             S = 1.0E0/CABS1(Z(K))
  17646.             CALL CSSCAL(N,S,Z,1)
  17647.             YNORM = S*YNORM
  17648.   130    CONTINUE
  17649.   140 CONTINUE
  17650.       S = 1.0E0/SCASUM(N,Z,1)
  17651.       CALL CSSCAL(N,S,Z,1)
  17652.       YNORM = S*YNORM
  17653. C
  17654. C     SOLVE  U*Z = V
  17655. C
  17656.       DO 160 KB = 1, N
  17657.          K = N + 1 - KB
  17658.          IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 150
  17659.             S = CABS1(A(K,K))/CABS1(Z(K))
  17660.             CALL CSSCAL(N,S,Z,1)
  17661.             YNORM = S*YNORM
  17662.   150    CONTINUE
  17663.          IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
  17664.          IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  17665.          T = -Z(K)
  17666.          CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  17667.   160 CONTINUE
  17668. C     MAKE ZNORM = 1.0
  17669.       S = 1.0E0/SCASUM(N,Z,1)
  17670.       CALL CSSCAL(N,S,Z,1)
  17671.       YNORM = S*YNORM
  17672. C
  17673.       IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  17674.       IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  17675.       RETURN
  17676.       END
  17677. *DECK CGEDI
  17678.       SUBROUTINE CGEDI (A, LDA, N, IPVT, DET, WORK, JOB)
  17679. C***BEGIN PROLOGUE  CGEDI
  17680. C***PURPOSE  Compute the determinant and inverse of a matrix using the
  17681. C            factors computed by CGECO or CGEFA.
  17682. C***LIBRARY   SLATEC (LINPACK)
  17683. C***CATEGORY  D2C1, D3C1
  17684. C***TYPE      COMPLEX (SGEDI-S, DGEDI-D, CGEDI-C)
  17685. C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX
  17686. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  17687. C***DESCRIPTION
  17688. C
  17689. C     CGEDI computes the determinant and inverse of a matrix
  17690. C     using the factors computed by CGECO or CGEFA.
  17691. C
  17692. C     On Entry
  17693. C
  17694. C        A       COMPLEX(LDA, N)
  17695. C                the output from CGECO or CGEFA.
  17696. C
  17697. C        LDA     INTEGER
  17698. C                the leading dimension of the array  A .
  17699. C
  17700. C        N       INTEGER
  17701. C                the order of the matrix  A .
  17702. C
  17703. C        IPVT    INTEGER(N)
  17704. C                the pivot vector from CGECO or CGEFA.
  17705. C
  17706. C        WORK    COMPLEX(N)
  17707. C                work vector.  Contents destroyed.
  17708. C
  17709. C        JOB     INTEGER
  17710. C                = 11   both determinant and inverse.
  17711. C                = 01   inverse only.
  17712. C                = 10   determinant only.
  17713. C
  17714. C     On Return
  17715. C
  17716. C        A       inverse of original matrix if requested.
  17717. C                Otherwise unchanged.
  17718. C
  17719. C        DET     COMPLEX(2)
  17720. C                determinant of original matrix if requested.
  17721. C                Otherwise not referenced.
  17722. C                Determinant = DET(1) * 10.0**DET(2)
  17723. C                with  1.0 .LE. CABS1(DET(1)) .LT. 10.0
  17724. C                or  DET(1) .EQ. 0.0 .
  17725. C
  17726. C     Error Condition
  17727. C
  17728. C        A division by zero will occur if the input factor contains
  17729. C        a zero on the diagonal and the inverse is requested.
  17730. C        It will not occur if the subroutines are called correctly
  17731. C        and if CGECO has set RCOND .GT. 0.0 or CGEFA has set
  17732. C        INFO .EQ. 0 .
  17733. C
  17734. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  17735. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  17736. C***ROUTINES CALLED  CAXPY, CSCAL, CSWAP
  17737. C***REVISION HISTORY  (YYMMDD)
  17738. C   780814  DATE WRITTEN
  17739. C   890831  Modified array declarations.  (WRB)
  17740. C   890831  REVISION DATE from Version 3.2
  17741. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17742. C   900326  Removed duplicate information from DESCRIPTION section.
  17743. C           (WRB)
  17744. C   920501  Reformatted the REFERENCES section.  (WRB)
  17745. C***END PROLOGUE  CGEDI
  17746.       INTEGER LDA,N,IPVT(*),JOB
  17747.       COMPLEX A(LDA,*),DET(2),WORK(*)
  17748. C
  17749.       COMPLEX T
  17750.       REAL TEN
  17751.       INTEGER I,J,K,KB,KP1,L,NM1
  17752.       COMPLEX ZDUM
  17753.       REAL CABS1
  17754.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  17755. C***FIRST EXECUTABLE STATEMENT  CGEDI
  17756. C
  17757. C     COMPUTE DETERMINANT
  17758. C
  17759.       IF (JOB/10 .EQ. 0) GO TO 70
  17760.          DET(1) = (1.0E0,0.0E0)
  17761.          DET(2) = (0.0E0,0.0E0)
  17762.          TEN = 10.0E0
  17763.          DO 50 I = 1, N
  17764.             IF (IPVT(I) .NE. I) DET(1) = -DET(1)
  17765.             DET(1) = A(I,I)*DET(1)
  17766.             IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60
  17767.    10       IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20
  17768.                DET(1) = CMPLX(TEN,0.0E0)*DET(1)
  17769.                DET(2) = DET(2) - (1.0E0,0.0E0)
  17770.             GO TO 10
  17771.    20       CONTINUE
  17772.    30       IF (CABS1(DET(1)) .LT. TEN) GO TO 40
  17773.                DET(1) = DET(1)/CMPLX(TEN,0.0E0)
  17774.                DET(2) = DET(2) + (1.0E0,0.0E0)
  17775.             GO TO 30
  17776.    40       CONTINUE
  17777.    50    CONTINUE
  17778.    60    CONTINUE
  17779.    70 CONTINUE
  17780. C
  17781. C     COMPUTE INVERSE(U)
  17782. C
  17783.       IF (MOD(JOB,10) .EQ. 0) GO TO 150
  17784.          DO 100 K = 1, N
  17785.             A(K,K) = (1.0E0,0.0E0)/A(K,K)
  17786.             T = -A(K,K)
  17787.             CALL CSCAL(K-1,T,A(1,K),1)
  17788.             KP1 = K + 1
  17789.             IF (N .LT. KP1) GO TO 90
  17790.             DO 80 J = KP1, N
  17791.                T = A(K,J)
  17792.                A(K,J) = (0.0E0,0.0E0)
  17793.                CALL CAXPY(K,T,A(1,K),1,A(1,J),1)
  17794.    80       CONTINUE
  17795.    90       CONTINUE
  17796.   100    CONTINUE
  17797. C
  17798. C        FORM INVERSE(U)*INVERSE(L)
  17799. C
  17800.          NM1 = N - 1
  17801.          IF (NM1 .LT. 1) GO TO 140
  17802.          DO 130 KB = 1, NM1
  17803.             K = N - KB
  17804.             KP1 = K + 1
  17805.             DO 110 I = KP1, N
  17806.                WORK(I) = A(I,K)
  17807.                A(I,K) = (0.0E0,0.0E0)
  17808.   110       CONTINUE
  17809.             DO 120 J = KP1, N
  17810.                T = WORK(J)
  17811.                CALL CAXPY(N,T,A(1,J),1,A(1,K),1)
  17812.   120       CONTINUE
  17813.             L = IPVT(K)
  17814.             IF (L .NE. K) CALL CSWAP(N,A(1,K),1,A(1,L),1)
  17815.   130    CONTINUE
  17816.   140    CONTINUE
  17817.   150 CONTINUE
  17818.       RETURN
  17819.       END
  17820. *DECK CGEEV
  17821.       SUBROUTINE CGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO)
  17822. C***BEGIN PROLOGUE  CGEEV
  17823. C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
  17824. C            of a complex general matrix.
  17825. C***LIBRARY   SLATEC
  17826. C***CATEGORY  D4A4
  17827. C***TYPE      COMPLEX (SGEEV-S, CGEEV-C)
  17828. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, GENERAL MATRIX
  17829. C***AUTHOR  Kahaner, D. K., (NBS)
  17830. C           Moler, C. B., (U. of New Mexico)
  17831. C           Stewart, G. W., (U. of Maryland)
  17832. C***DESCRIPTION
  17833. C
  17834. C     Abstract
  17835. C      CGEEV computes the eigenvalues and, optionally,
  17836. C      the eigenvectors of a general complex matrix.
  17837. C
  17838. C     Call Sequence Parameters-
  17839. C       (The values of parameters marked with * (star) will be changed
  17840. C         by CGEEV.)
  17841. C
  17842. C        A*      COMPLEX(LDA,N)
  17843. C                complex nonsymmetric input matrix.
  17844. C
  17845. C        LDA     INTEGER
  17846. C                set by the user to
  17847. C                the leading dimension of the complex array A.
  17848. C
  17849. C        N       INTEGER
  17850. C                set by the user to
  17851. C                the order of the matrices A and V, and
  17852. C                the number of elements in E.
  17853. C
  17854. C        E*      COMPLEX(N)
  17855. C                on return from CGEEV E contains the eigenvalues of A.
  17856. C                See also INFO below.
  17857. C
  17858. C        V*      COMPLEX(LDV,N)
  17859. C                on return from CGEEV if the user has set JOB
  17860. C                = 0        V is not referenced.
  17861. C                = nonzero  the N eigenvectors of A are stored in the
  17862. C                first N columns of V.  See also INFO below.
  17863. C                (If the input matrix A is nearly degenerate, V
  17864. C                 will be badly conditioned, i.e. have nearly
  17865. C                 dependent columns.)
  17866. C
  17867. C        LDV     INTEGER
  17868. C                set by the user to
  17869. C                the leading dimension of the array V if JOB is also
  17870. C                set nonzero.  In that case N must be .LE. LDV.
  17871. C                If JOB is set to zero LDV is not referenced.
  17872. C
  17873. C        WORK*   REAL(3N)
  17874. C                temporary storage vector.  Contents changed by CGEEV.
  17875. C
  17876. C        JOB     INTEGER
  17877. C                set by the user to
  17878. C                = 0        eigenvalues only to be calculated by CGEEV.
  17879. C                           neither V nor LDV are referenced.
  17880. C                = nonzero  eigenvalues and vectors to be calculated.
  17881. C                           In this case A & V must be distinct arrays.
  17882. C                           Also,  if LDA > LDV,  CGEEV changes all the
  17883. C                           elements of A thru column N.  If LDA < LDV,
  17884. C                           CGEEV changes all the elements of V through
  17885. C                           column N.  If LDA = LDV only A(I,J) and V(I,
  17886. C                           J) for I,J = 1,...,N are changed by CGEEV.
  17887. C
  17888. C        INFO*   INTEGER
  17889. C                on return from CGEEV the value of INFO is
  17890. C                = 0  normal return, calculation successful.
  17891. C                = K  if the eigenvalue iteration fails to converge,
  17892. C                     eigenvalues K+1 through N are correct, but
  17893. C                     no eigenvectors were computed even if they were
  17894. C                     requested (JOB nonzero).
  17895. C
  17896. C      Error Messages
  17897. C           No. 1  recoverable  N is greater than LDA
  17898. C           No. 2  recoverable  N is less than one.
  17899. C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
  17900. C           No. 4  warning      LDA > LDV,  elements of A other than the
  17901. C                               N by N input elements have been changed
  17902. C           No. 5  warning      LDA < LDV,  elements of V other than the
  17903. C                               N by N output elements have been changed
  17904. C
  17905. C***REFERENCES  (NONE)
  17906. C***ROUTINES CALLED  CBABK2, CBAL, COMQR, COMQR2, CORTH, SCOPY, XERMSG
  17907. C***REVISION HISTORY  (YYMMDD)
  17908. C   800808  DATE WRITTEN
  17909. C   890531  Changed all specific intrinsics to generic.  (WRB)
  17910. C   890531  REVISION DATE from Version 3.2
  17911. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  17912. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  17913. C   900326  Removed duplicate information from DESCRIPTION section.
  17914. C           (WRB)
  17915. C***END PROLOGUE  CGEEV
  17916.       INTEGER I,IHI,ILO,INFO,J,K,L,LDA,LDV,MDIM,N
  17917.       REAL A(*),E(*),WORK(*),V(*)
  17918. C***FIRST EXECUTABLE STATEMENT  CGEEV
  17919.       IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CGEEV', 'N .GT. LDA.', 1,
  17920.      +   1)
  17921.       IF(N .GT. LDA) RETURN
  17922.       IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CGEEV', 'N .LT. 1', 2, 1)
  17923.       IF(N .LT. 1) RETURN
  17924.       IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
  17925.       MDIM = 2 * LDA
  17926.       IF(JOB .EQ. 0) GO TO 5
  17927.       IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CGEEV',
  17928.      +   'JOB .NE. 0 AND N .GT. LDV.', 3, 1)
  17929.       IF(N .GT. LDV) RETURN
  17930.       IF(N .EQ. 1) GO TO 35
  17931. C
  17932. C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
  17933. C
  17934.       MDIM = MIN(MDIM,2 * LDV)
  17935.       IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CGEEV',
  17936.      +   'LDA.LT.LDV,  ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' //
  17937.      +   'ELEMENTS HAVE BEEN CHANGED.', 5, 0)
  17938.       IF(LDA.LE.LDV) GO TO 5
  17939.       CALL XERMSG ('SLATEC', 'CGEEV',
  17940.      +   'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' //
  17941.      +   'ELEMENTS HAVE BEEN CHANGED.', 4, 0)
  17942.       L = N - 1
  17943.       DO 4 J=1,L
  17944.           I = 2 * N
  17945.          M = 1+J*2*LDV
  17946.          K = 1+J*2*LDA
  17947.          CALL SCOPY(I,A(K),1,A(M),1)
  17948.     4 CONTINUE
  17949.     5 CONTINUE
  17950. C
  17951. C     SEPARATE REAL AND IMAGINARY PARTS
  17952. C
  17953.       DO 6 J = 1, N
  17954.        K = (J-1) * MDIM +1
  17955.        L = K + N
  17956.        CALL SCOPY(N,A(K+1),2,WORK(1),1)
  17957.        CALL SCOPY(N,A(K),2,A(K),1)
  17958.        CALL SCOPY(N,WORK(1),1,A(L),1)
  17959.     6 CONTINUE
  17960. C
  17961. C     SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG.
  17962. C
  17963.       CALL CBAL(MDIM,N,A(1),A(N+1),ILO,IHI,WORK(1))
  17964.       CALL CORTH(MDIM,N,ILO,IHI,A(1),A(N+1),WORK(N+1),WORK(2*N+1))
  17965.       IF(JOB .NE. 0) GO TO 10
  17966. C
  17967. C     EIGENVALUES ONLY
  17968. C
  17969.       CALL COMQR(MDIM,N,ILO,IHI,A(1),A(N+1),E(1),E(N+1),INFO)
  17970.       GO TO 30
  17971. C
  17972. C     EIGENVALUES AND EIGENVECTORS.
  17973. C
  17974.    10 CALL COMQR2(MDIM,N,ILO,IHI,WORK(N+1),WORK(2*N+1),A(1),A(N+1),
  17975.      1  E(1),E(N+1),V(1),V(N+1),INFO)
  17976.       IF (INFO .NE. 0) GO TO 30
  17977.       CALL CBABK2(MDIM,N,ILO,IHI,WORK(1),N,V(1),V(N+1))
  17978. C
  17979. C     CONVERT EIGENVECTORS TO COMPLEX STORAGE.
  17980. C
  17981.       DO 20 J = 1,N
  17982.        K = (J-1) * MDIM + 1
  17983.        I = (J-1) * 2 * LDV + 1
  17984.        L = K + N
  17985.        CALL SCOPY(N,V(K),1,WORK(1),1)
  17986.        CALL SCOPY(N,V(L),1,V(I+1),2)
  17987.        CALL SCOPY(N,WORK(1),1,V(I),2)
  17988.    20 CONTINUE
  17989. C
  17990. C     CONVERT EIGENVALUES TO COMPLEX STORAGE.
  17991. C
  17992.    30 CALL SCOPY(N,E(1),1,WORK(1),1)
  17993.       CALL SCOPY(N,E(N+1),1,E(2),2)
  17994.       CALL SCOPY(N,WORK(1),1,E(1),2)
  17995.       RETURN
  17996. C
  17997. C     TAKE CARE OF N=1 CASE
  17998. C
  17999.    35 E(1) = A(1)
  18000.       E(2) = A(2)
  18001.       INFO = 0
  18002.       IF(JOB .EQ. 0) RETURN
  18003.       V(1) = A(1)
  18004.       V(2) = A(2)
  18005.       RETURN
  18006.       END
  18007. *DECK CGEFA
  18008.       SUBROUTINE CGEFA (A, LDA, N, IPVT, INFO)
  18009. C***BEGIN PROLOGUE  CGEFA
  18010. C***PURPOSE  Factor a matrix using Gaussian elimination.
  18011. C***LIBRARY   SLATEC (LINPACK)
  18012. C***CATEGORY  D2C1
  18013. C***TYPE      COMPLEX (SGEFA-S, DGEFA-D, CGEFA-C)
  18014. C***KEYWORDS  GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
  18015. C             MATRIX FACTORIZATION
  18016. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  18017. C***DESCRIPTION
  18018. C
  18019. C     CGEFA factors a complex matrix by Gaussian elimination.
  18020. C
  18021. C     CGEFA is usually called by CGECO, but it can be called
  18022. C     directly with a saving in time if  RCOND  is not needed.
  18023. C     (Time for CGECO) = (1 + 9/N)*(Time for CGEFA) .
  18024. C
  18025. C     On Entry
  18026. C
  18027. C        A       COMPLEX(LDA, N)
  18028. C                the matrix to be factored.
  18029. C
  18030. C        LDA     INTEGER
  18031. C                the leading dimension of the array  A .
  18032. C
  18033. C        N       INTEGER
  18034. C                the order of the matrix  A .
  18035. C
  18036. C     On Return
  18037. C
  18038. C        A       an upper triangular matrix and the multipliers
  18039. C                which were used to obtain it.
  18040. C                The factorization can be written  A = L*U  where
  18041. C                L  is a product of permutation and unit lower
  18042. C                triangular matrices and  U  is upper triangular.
  18043. C
  18044. C        IPVT    INTEGER(N)
  18045. C                an integer vector of pivot indices.
  18046. C
  18047. C        INFO    INTEGER
  18048. C                = 0  normal value.
  18049. C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
  18050. C                     condition for this subroutine, but it does
  18051. C                     indicate that CGESL or CGEDI will divide by zero
  18052. C                     if called.  Use  RCOND  in CGECO for a reliable
  18053. C                     indication of singularity.
  18054. C
  18055. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  18056. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  18057. C***ROUTINES CALLED  CAXPY, CSCAL, ICAMAX
  18058. C***REVISION HISTORY  (YYMMDD)
  18059. C   780814  DATE WRITTEN
  18060. C   890831  Modified array declarations.  (WRB)
  18061. C   890831  REVISION DATE from Version 3.2
  18062. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18063. C   900326  Removed duplicate information from DESCRIPTION section.
  18064. C           (WRB)
  18065. C   920501  Reformatted the REFERENCES section.  (WRB)
  18066. C***END PROLOGUE  CGEFA
  18067.       INTEGER LDA,N,IPVT(*),INFO
  18068.       COMPLEX A(LDA,*)
  18069. C
  18070.       COMPLEX T
  18071.       INTEGER ICAMAX,J,K,KP1,L,NM1
  18072.       COMPLEX ZDUM
  18073.       REAL CABS1
  18074.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  18075. C
  18076. C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
  18077. C
  18078. C***FIRST EXECUTABLE STATEMENT  CGEFA
  18079.       INFO = 0
  18080.       NM1 = N - 1
  18081.       IF (NM1 .LT. 1) GO TO 70
  18082.       DO 60 K = 1, NM1
  18083.          KP1 = K + 1
  18084. C
  18085. C        FIND L = PIVOT INDEX
  18086. C
  18087.          L = ICAMAX(N-K+1,A(K,K),1) + K - 1
  18088.          IPVT(K) = L
  18089. C
  18090. C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
  18091. C
  18092.          IF (CABS1(A(L,K)) .EQ. 0.0E0) GO TO 40
  18093. C
  18094. C           INTERCHANGE IF NECESSARY
  18095. C
  18096.             IF (L .EQ. K) GO TO 10
  18097.                T = A(L,K)
  18098.                A(L,K) = A(K,K)
  18099.                A(K,K) = T
  18100.    10       CONTINUE
  18101. C
  18102. C           COMPUTE MULTIPLIERS
  18103. C
  18104.             T = -(1.0E0,0.0E0)/A(K,K)
  18105.             CALL CSCAL(N-K,T,A(K+1,K),1)
  18106. C
  18107. C           ROW ELIMINATION WITH COLUMN INDEXING
  18108. C
  18109.             DO 30 J = KP1, N
  18110.                T = A(L,J)
  18111.                IF (L .EQ. K) GO TO 20
  18112.                   A(L,J) = A(K,J)
  18113.                   A(K,J) = T
  18114.    20          CONTINUE
  18115.                CALL CAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
  18116.    30       CONTINUE
  18117.          GO TO 50
  18118.    40    CONTINUE
  18119.             INFO = K
  18120.    50    CONTINUE
  18121.    60 CONTINUE
  18122.    70 CONTINUE
  18123.       IPVT(N) = N
  18124.       IF (CABS1(A(N,N)) .EQ. 0.0E0) INFO = N
  18125.       RETURN
  18126.       END
  18127. *DECK CGEFS
  18128.       SUBROUTINE CGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK)
  18129. C***BEGIN PROLOGUE  CGEFS
  18130. C***PURPOSE  Solve a general system of linear equations.
  18131. C***LIBRARY   SLATEC
  18132. C***CATEGORY  D2C1
  18133. C***TYPE      COMPLEX (SGEFS-S, DGEFS-D, CGEFS-C)
  18134. C***KEYWORDS  COMPLEX LINEAR EQUATIONS, GENERAL MATRIX,
  18135. C             GENERAL SYSTEM OF LINEAR EQUATIONS
  18136. C***AUTHOR  Voorhees, E. A., (LANL)
  18137. C***DESCRIPTION
  18138. C
  18139. C    Subroutine CGEFS solves A general NxN system of complex
  18140. C    linear equations using LINPACK subroutines CGECO
  18141. C    and CGESL.  That is, if A is an NxN complex matrix
  18142. C    and if X  and B are complex  N-vectors, then CGEFS
  18143. C    solves the equation
  18144. C
  18145. C                          A*X=B.
  18146. C
  18147. C    The matrix A is first factored into upper and lower tri-
  18148. C    angular matrices U and L using partial pivoting.  These
  18149. C    factors and the pivoting information are used to find the
  18150. C    solution vector X.  An approximate condition number is
  18151. C    calculated to provide a rough estimate of the number of
  18152. C    digits of accuracy in the computed solution.
  18153. C
  18154. C    If the equation A*X=B is to be solved for more than one vector
  18155. C    B, the factoring of A does not need to be performed again and
  18156. C    the option to only solve (ITASK .GT. 1) will be faster for
  18157. C    the succeeding solutions.  In this case, the contents of A,
  18158. C    LDA, N and IWORK must not have been altered by the user follow-
  18159. C    ing factorization (ITASK=1).  IND will not be changed by CGEFS
  18160. C    in this case.
  18161. C
  18162. C  Argument Description ***
  18163. C
  18164. C    A      COMPLEX(LDA,N)
  18165. C             on entry, the doubly subscripted array with dimension
  18166. C               (LDA,N) which contains the coefficient matrix.
  18167. C             on return, an upper triangular matrix U and the
  18168. C               multipliers necessary to construct a matrix L
  18169. C               so that A=L*U.
  18170. C    LDA    INTEGER
  18171. C             the leading dimension of the array A.  LDA must be great-
  18172. C             er than or equal to N.  (Terminal error message IND=-1)
  18173. C    N      INTEGER
  18174. C             the order of the matrix A.  The first N elements of
  18175. C             the array A are the elements of the first column of
  18176. C             the matrix A.  N must be greater than or equal to 1.
  18177. C             (Terminal error message IND=-2)
  18178. C    V      COMPLEX(N)
  18179. C             on entry, the singly subscripted array(vector) of di-
  18180. C               mension N which contains the right hand side B of a
  18181. C               system of simultaneous linear equations A*X=B.
  18182. C             on return, V contains the solution vector, X .
  18183. C    ITASK  INTEGER
  18184. C             if ITASK=1, the matrix A is factored and then the
  18185. C               linear equation is solved.
  18186. C             if ITASK .GT. 1, the equation is solved using the existing
  18187. C               factored matrix A and IWORK.
  18188. C             if ITASK .LT. 1, then terminal error message IND=-3 is
  18189. C               printed.
  18190. C    IND    INTEGER
  18191. C             GT.0  IND is a rough estimate of the number of digits
  18192. C                     of accuracy in the solution, X.
  18193. C             LT.0  see error message corresponding to IND below.
  18194. C    WORK   COMPLEX(N)
  18195. C             a singly subscripted array of dimension at least N.
  18196. C    IWORK  INTEGER(N)
  18197. C             a singly subscripted array of dimension at least N.
  18198. C
  18199. C  Error Messages Printed ***
  18200. C
  18201. C    IND=-1  terminal   N is greater than LDA.
  18202. C    IND=-2  terminal   N is less than 1.
  18203. C    IND=-3  terminal   ITASK is less than 1.
  18204. C    IND=-4  terminal   The matrix A is computationally singular.
  18205. C                         A solution has not been computed.
  18206. C    IND=-10 warning    The solution has no apparent significance.
  18207. C                         The solution may be inaccurate or the matrix
  18208. C                         A may be poorly scaled.
  18209. C
  18210. C               NOTE-  The above terminal(*fatal*) error messages are
  18211. C                      designed to be handled by XERMSG in which
  18212. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  18213. C                      for warning error messages from XERMSG.  Unless
  18214. C                      the user provides otherwise, an error message
  18215. C                      will be printed followed by an abort.
  18216. C
  18217. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  18218. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  18219. C***ROUTINES CALLED  CGECO, CGESL, R1MACH, XERMSG
  18220. C***REVISION HISTORY  (YYMMDD)
  18221. C   800328  DATE WRITTEN
  18222. C   890531  Changed all specific intrinsics to generic.  (WRB)
  18223. C   890831  Modified array declarations.  (WRB)
  18224. C   890831  REVISION DATE from Version 3.2
  18225. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18226. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  18227. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  18228. C           IF-THEN-ELSE.  (RWC)
  18229. C   920501  Reformatted the REFERENCES section.  (WRB)
  18230. C***END PROLOGUE  CGEFS
  18231. C
  18232.       INTEGER LDA,N,ITASK,IND,IWORK(*)
  18233.       COMPLEX A(LDA,*),V(*),WORK(*)
  18234.       REAL R1MACH
  18235.       REAL RCOND
  18236.       CHARACTER*8 XERN1, XERN2
  18237. C***FIRST EXECUTABLE STATEMENT  CGEFS
  18238.       IF (LDA.LT.N) THEN
  18239.          IND = -1
  18240.          WRITE (XERN1, '(I8)') LDA
  18241.          WRITE (XERN2, '(I8)') N
  18242.          CALL XERMSG ('SLATEC', 'CGEFS', 'LDA = ' // XERN1 //
  18243.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  18244.          RETURN
  18245.       ENDIF
  18246. C
  18247.       IF (N.LE.0) THEN
  18248.          IND = -2
  18249.          WRITE (XERN1, '(I8)') N
  18250.          CALL XERMSG ('SLATEC', 'CGEFS', 'N = ' // XERN1 //
  18251.      *      ' IS LESS THAN 1', -2, 1)
  18252.          RETURN
  18253.       ENDIF
  18254. C
  18255.       IF (ITASK.LT.1) THEN
  18256.          IND = -3
  18257.          WRITE (XERN1, '(I8)') ITASK
  18258.          CALL XERMSG ('SLATEC', 'CGEFS', 'ITASK = ' // XERN1 //
  18259.      *      ' IS LESS THAN 1', -3, 1)
  18260.          RETURN
  18261.       ENDIF
  18262. C
  18263. C     FACTOR MATRIX A INTO LU
  18264. C
  18265.       IF (ITASK.EQ.1) THEN
  18266.          CALL CGECO(A,LDA,N,IWORK,RCOND,WORK)
  18267. C
  18268. C        CHECK FOR COMPUTATIONALLY SINGULAR MATRIX
  18269. C
  18270.          IF (RCOND.EQ.0.0) THEN
  18271.             IND = -4
  18272.             CALL XERMSG ('SLATEC', 'CGEFS',
  18273.      *         'SINGULAR MATRIX A - NO SOLUTION', -4, 1)
  18274.             RETURN
  18275.          ENDIF
  18276. C
  18277. C        COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  18278. C
  18279.          IND = -LOG10(R1MACH(4)/RCOND)
  18280. C
  18281. C        CHECK FOR IND GREATER THAN ZERO
  18282. C
  18283.          IF (IND.LE.0) THEN
  18284.             IND = -10
  18285.             CALL XERMSG ('SLATEC', 'CGEFS',
  18286.      *         'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  18287.          ENDIF
  18288.       ENDIF
  18289. C
  18290. C     SOLVE AFTER FACTORING
  18291. C
  18292.       CALL CGESL(A,LDA,N,IWORK,V,0)
  18293.       RETURN
  18294.       END
  18295. *DECK CGEIR
  18296.       SUBROUTINE CGEIR (A, LDA, N, V, ITASK, IND, WORK, IWORK)
  18297. C***BEGIN PROLOGUE  CGEIR
  18298. C***PURPOSE  Solve a general system of linear equations.  Iterative
  18299. C            refinement is used to obtain an error estimate.
  18300. C***LIBRARY   SLATEC
  18301. C***CATEGORY  D2C1
  18302. C***TYPE      COMPLEX (SGEIR-S, CGEIR-C)
  18303. C***KEYWORDS  COMPLEX LINEAR EQUATIONS, GENERAL MATRIX,
  18304. C             GENERAL SYSTEM OF LINEAR EQUATIONS
  18305. C***AUTHOR  Voorhees, E. A., (LANL)
  18306. C***DESCRIPTION
  18307. C
  18308. C    Subroutine CGEIR solves a general NxN system of complex
  18309. C    linear equations using LINPACK subroutines CGEFA and CGESL.
  18310. C    One pass of iterative refinement is used only to obtain an
  18311. C    estimate of the accuracy.  That is, if A is an NxN complex
  18312. C    matrix and if X and B are complex N-vectors, then CGEIR solves
  18313. C    the equation
  18314. C
  18315. C                          A*X=B.
  18316. C
  18317. C    The matrix A is first factored into upper and lower tri-
  18318. C    angular matrices U and L using partial pivoting.  These
  18319. C    factors and the pivoting information are used to calculate
  18320. C    the solution, X.  Then the residual vector is found and
  18321. C    used to calculate an estimate of the relative error, IND.
  18322. C    IND estimates the accuracy of the solution only when the
  18323. C    input matrix and the right hand side are represented
  18324. C    exactly in the computer and does not take into
  18325. C    account any errors in the input data.
  18326. C
  18327. C    If the equation A*X=B is to be solved for more than one vector
  18328. C    B, the factoring of A does not need to be performed again and
  18329. C    the option to only solve (ITASK .GT. 1) will be faster for
  18330. C    the succeeding solutions.  In this case, the contents of A,
  18331. C    LDA, N, WORK, and IWORK must not have been altered by the
  18332. C    user following factorization (ITASK=1).  IND will not be
  18333. C    changed by CGEIR in this case.
  18334. C
  18335. C  Argument Description ***
  18336. C
  18337. C    A      COMPLEX(LDA,N)
  18338. C             the doubly subscripted array with dimension (LDA,N)
  18339. C             which contains the coefficient matrix.  A is not
  18340. C             altered by the routine.
  18341. C    LDA    INTEGER
  18342. C             the leading dimension of the array A.  LDA must be great-
  18343. C             er than or equal to N.  (Terminal error message IND=-1)
  18344. C    N      INTEGER
  18345. C             the order of the matrix A.  The first N elements of
  18346. C             the array A are the elements of the first column of
  18347. C             matrix A.  N must be greater than or equal to 1.
  18348. C             (Terminal error message IND=-2)
  18349. C    V      COMPLEX(N)
  18350. C             on entry, the singly subscripted array(vector) of di-
  18351. C               mension N which contains the right hand side B of a
  18352. C               system of simultaneous linear equations A*X=B.
  18353. C             on return, V contains the solution vector, X .
  18354. C    ITASK  INTEGER
  18355. C             if ITASK=1, the matrix A is factored and then the
  18356. C               linear equation is solved.
  18357. C             if ITASK .GT. 1, the equation is solved using the existing
  18358. C               factored matrix A (stored in work).
  18359. C             if ITASK .LT. 1, then terminal error message IND=-3 is
  18360. C               printed.
  18361. C    IND    INTEGER
  18362. C             GT.0  IND is a rough estimate of the number of digits
  18363. C                     of accuracy in the solution, X.  IND=75 means
  18364. C                     that the solution vector X is zero.
  18365. C             LT.0  see error message corresponding to IND below.
  18366. C    WORK   COMPLEX(N*(N+1))
  18367. C             a singly subscripted array of dimension at least N*(N+1).
  18368. C    IWORK  INTEGER(N)
  18369. C             a singly subscripted array of dimension at least N.
  18370. C
  18371. C  Error Messages Printed ***
  18372. C
  18373. C    IND=-1  terminal   N is greater than LDA.
  18374. C    IND=-2  terminal   N is less than one.
  18375. C    IND=-3  terminal   ITASK is less than one.
  18376. C    IND=-4  terminal   The matrix A is computationally singular.
  18377. C                         A solution has not been computed.
  18378. C    IND=-10 warning    The solution has no apparent significance.
  18379. C                         The solution may be inaccurate or the matrix
  18380. C                         A may be poorly scaled.
  18381. C
  18382. C               NOTE-  The above terminal(*fatal*) error messages are
  18383. C                      designed to be handled by XERMSG in which
  18384. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  18385. C                      for warning error messages from XERMSG.  Unless
  18386. C                      the user provides otherwise, an error message
  18387. C                      will be printed followed by an abort.
  18388. C
  18389. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  18390. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  18391. C***ROUTINES CALLED  CCOPY, CDCDOT, CGEFA, CGESL, R1MACH, SCASUM, XERMSG
  18392. C***REVISION HISTORY  (YYMMDD)
  18393. C   800502  DATE WRITTEN
  18394. C   890531  Changed all specific intrinsics to generic.  (WRB)
  18395. C   890831  Modified array declarations.  (WRB)
  18396. C   890831  REVISION DATE from Version 3.2
  18397. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18398. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  18399. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  18400. C           IF-THEN-ELSE.  (RWC)
  18401. C   920501  Reformatted the REFERENCES section.  (WRB)
  18402. C***END PROLOGUE  CGEIR
  18403. C
  18404.       INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J
  18405.       COMPLEX A(LDA,*),V(*),WORK(N,*),CDCDOT
  18406.       REAL SCASUM,XNORM,DNORM,R1MACH
  18407.       CHARACTER*8 XERN1, XERN2
  18408. C***FIRST EXECUTABLE STATEMENT  CGEIR
  18409.       IF (LDA.LT.N) THEN
  18410.          IND = -1
  18411.          WRITE (XERN1, '(I8)') LDA
  18412.          WRITE (XERN2, '(I8)') N
  18413.          CALL XERMSG ('SLATEC', 'CGEIR', 'LDA = ' // XERN1 //
  18414.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  18415.          RETURN
  18416.       ENDIF
  18417. C
  18418.       IF (N.LE.0) THEN
  18419.          IND = -2
  18420.          WRITE (XERN1, '(I8)') N
  18421.          CALL XERMSG ('SLATEC', 'CGEIR', 'N = ' // XERN1 //
  18422.      *      ' IS LESS THAN 1', -2, 1)
  18423.          RETURN
  18424.       ENDIF
  18425. C
  18426.       IF (ITASK.LT.1) THEN
  18427.          IND = -3
  18428.          WRITE (XERN1, '(I8)') ITASK
  18429.          CALL XERMSG ('SLATEC', 'CGEIR', 'ITASK = ' // XERN1 //
  18430.      *      ' IS LESS THAN 1', -3, 1)
  18431.          RETURN
  18432.       ENDIF
  18433. C
  18434.       IF (ITASK.EQ.1) THEN
  18435. C        MOVE MATRIX A TO WORK
  18436.          DO 10 J=1,N
  18437.             CALL CCOPY(N,A(1,J),1,WORK(1,J),1)
  18438.    10    CONTINUE
  18439. C
  18440. C        FACTOR MATRIX A INTO LU
  18441. C
  18442.          CALL CGEFA(WORK,N,N,IWORK,INFO)
  18443. C
  18444. C        CHECK FOR COMPUTATIONALLY SINGULAR MATRIX
  18445. C
  18446.          IF (INFO.NE.0) THEN
  18447.             IND = -4
  18448.             CALL XERMSG ('SLATEC', 'CGEIR',
  18449.      *         'SINGULAR MATRIX A - NO SOLUTION', -4, 1)
  18450.             RETURN
  18451.          ENDIF
  18452.       ENDIF
  18453. C
  18454. C     SOLVE WHEN FACTORING COMPLETE
  18455. C     MOVE VECTOR B TO WORK
  18456. C
  18457.       CALL CCOPY(N,V(1),1,WORK(1,N+1),1)
  18458.       CALL CGESL(WORK,N,N,IWORK,V,0)
  18459. C
  18460. C     FORM NORM OF X0
  18461. C
  18462.       XNORM = SCASUM(N,V(1),1)
  18463.       IF (XNORM.EQ.0.0) THEN
  18464.          IND = 75
  18465.          RETURN
  18466.       ENDIF
  18467. C
  18468. C     COMPUTE  RESIDUAL
  18469. C
  18470.       DO 40 J=1,N
  18471.          WORK(J,N+1) = CDCDOT(N,-WORK(J,N+1),A(J,1),LDA,V,1)
  18472.    40 CONTINUE
  18473. C
  18474. C     SOLVE A*DELTA=R
  18475. C
  18476.       CALL CGESL(WORK,N,N,IWORK,WORK(1,N+1),0)
  18477. C
  18478. C     FORM NORM OF DELTA
  18479. C
  18480.       DNORM = SCASUM(N,WORK(1,N+1),1)
  18481. C
  18482. C     COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  18483. C     AND CHECK FOR IND GREATER THAN ZERO
  18484. C
  18485.       IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM))
  18486.       IF (IND.LE.0) THEN
  18487.          IND = -10
  18488.          CALL XERMSG ('SLATEC', 'CGEIR',
  18489.      *      'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  18490.       ENDIF
  18491.       RETURN
  18492.       END
  18493. *DECK CGESL
  18494.       SUBROUTINE CGESL (A, LDA, N, IPVT, B, JOB)
  18495. C***BEGIN PROLOGUE  CGESL
  18496. C***PURPOSE  Solve the complex system A*X=B or CTRANS(A)*X=B using the
  18497. C            factors computed by CGECO or CGEFA.
  18498. C***LIBRARY   SLATEC (LINPACK)
  18499. C***CATEGORY  D2C1
  18500. C***TYPE      COMPLEX (SGESL-S, DGESL-D, CGESL-C)
  18501. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
  18502. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  18503. C***DESCRIPTION
  18504. C
  18505. C     CGESL solves the complex system
  18506. C     A * X = B  or  CTRANS(A) * X = B
  18507. C     using the factors computed by CGECO or CGEFA.
  18508. C
  18509. C     On Entry
  18510. C
  18511. C        A       COMPLEX(LDA, N)
  18512. C                the output from CGECO or CGEFA.
  18513. C
  18514. C        LDA     INTEGER
  18515. C                the leading dimension of the array  A .
  18516. C
  18517. C        N       INTEGER
  18518. C                the order of the matrix  A .
  18519. C
  18520. C        IPVT    INTEGER(N)
  18521. C                the pivot vector from CGECO or CGEFA.
  18522. C
  18523. C        B       COMPLEX(N)
  18524. C                the right hand side vector.
  18525. C
  18526. C        JOB     INTEGER
  18527. C                = 0         to solve  A*X = B ,
  18528. C                = nonzero   to solve  CTRANS(A)*X = B  where
  18529. C                            CTRANS(A)  is the conjugate transpose.
  18530. C
  18531. C     On Return
  18532. C
  18533. C        B       the solution vector  X .
  18534. C
  18535. C     Error Condition
  18536. C
  18537. C        A division by zero will occur if the input factor contains a
  18538. C        zero on the diagonal.  Technically this indicates singularity
  18539. C        but it is often caused by improper arguments or improper
  18540. C        setting of LDA .  It will not occur if the subroutines are
  18541. C        called correctly and if CGECO has set RCOND .GT. 0.0
  18542. C        or CGEFA has set INFO .EQ. 0 .
  18543. C
  18544. C     To compute  INVERSE(A) * C  where  C  is a matrix
  18545. C     with  P  columns
  18546. C           CALL CGECO(A,LDA,N,IPVT,RCOND,Z)
  18547. C           IF (RCOND is too small) GO TO ...
  18548. C           DO 10 J = 1, P
  18549. C              CALL CGESL(A,LDA,N,IPVT,C(1,J),0)
  18550. C        10 CONTINUE
  18551. C
  18552. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  18553. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  18554. C***ROUTINES CALLED  CAXPY, CDOTC
  18555. C***REVISION HISTORY  (YYMMDD)
  18556. C   780814  DATE WRITTEN
  18557. C   890831  Modified array declarations.  (WRB)
  18558. C   890831  REVISION DATE from Version 3.2
  18559. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18560. C   900326  Removed duplicate information from DESCRIPTION section.
  18561. C           (WRB)
  18562. C   920501  Reformatted the REFERENCES section.  (WRB)
  18563. C***END PROLOGUE  CGESL
  18564.       INTEGER LDA,N,IPVT(*),JOB
  18565.       COMPLEX A(LDA,*),B(*)
  18566. C
  18567.       COMPLEX CDOTC,T
  18568.       INTEGER K,KB,L,NM1
  18569. C***FIRST EXECUTABLE STATEMENT  CGESL
  18570.       NM1 = N - 1
  18571.       IF (JOB .NE. 0) GO TO 50
  18572. C
  18573. C        JOB = 0 , SOLVE  A * X = B
  18574. C        FIRST SOLVE  L*Y = B
  18575. C
  18576.          IF (NM1 .LT. 1) GO TO 30
  18577.          DO 20 K = 1, NM1
  18578.             L = IPVT(K)
  18579.             T = B(L)
  18580.             IF (L .EQ. K) GO TO 10
  18581.                B(L) = B(K)
  18582.                B(K) = T
  18583.    10       CONTINUE
  18584.             CALL CAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
  18585.    20    CONTINUE
  18586.    30    CONTINUE
  18587. C
  18588. C        NOW SOLVE  U*X = Y
  18589. C
  18590.          DO 40 KB = 1, N
  18591.             K = N + 1 - KB
  18592.             B(K) = B(K)/A(K,K)
  18593.             T = -B(K)
  18594.             CALL CAXPY(K-1,T,A(1,K),1,B(1),1)
  18595.    40    CONTINUE
  18596.       GO TO 100
  18597.    50 CONTINUE
  18598. C
  18599. C        JOB = NONZERO, SOLVE  CTRANS(A) * X = B
  18600. C        FIRST SOLVE  CTRANS(U)*Y = B
  18601. C
  18602.          DO 60 K = 1, N
  18603.             T = CDOTC(K-1,A(1,K),1,B(1),1)
  18604.             B(K) = (B(K) - T)/CONJG(A(K,K))
  18605.    60    CONTINUE
  18606. C
  18607. C        NOW SOLVE CTRANS(L)*X = Y
  18608. C
  18609.          IF (NM1 .LT. 1) GO TO 90
  18610.          DO 80 KB = 1, NM1
  18611.             K = N - KB
  18612.             B(K) = B(K) + CDOTC(N-K,A(K+1,K),1,B(K+1),1)
  18613.             L = IPVT(K)
  18614.             IF (L .EQ. K) GO TO 70
  18615.                T = B(L)
  18616.                B(L) = B(K)
  18617.                B(K) = T
  18618.    70       CONTINUE
  18619.    80    CONTINUE
  18620.    90    CONTINUE
  18621.   100 CONTINUE
  18622.       RETURN
  18623.       END
  18624. *DECK CGTSL
  18625.       SUBROUTINE CGTSL (N, C, D, E, B, INFO)
  18626. C***BEGIN PROLOGUE  CGTSL
  18627. C***PURPOSE  Solve a tridiagonal linear system.
  18628. C***LIBRARY   SLATEC (LINPACK)
  18629. C***CATEGORY  D2C2A
  18630. C***TYPE      COMPLEX (SGTSL-S, DGTSL-D, CGTSL-C)
  18631. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL
  18632. C***AUTHOR  Dongarra, J., (ANL)
  18633. C***DESCRIPTION
  18634. C
  18635. C     CGTSL given a general tridiagonal matrix and a right hand
  18636. C     side will find the solution.
  18637. C
  18638. C     On Entry
  18639. C
  18640. C        N       INTEGER
  18641. C                is the order of the tridiagonal matrix.
  18642. C
  18643. C        C       COMPLEX(N)
  18644. C                is the subdiagonal of the tridiagonal matrix.
  18645. C                C(2) through C(N) should contain the subdiagonal.
  18646. C                On output C is destroyed.
  18647. C
  18648. C        D       COMPLEX(N)
  18649. C                is the diagonal of the tridiagonal matrix.
  18650. C                On output D is destroyed.
  18651. C
  18652. C        E       COMPLEX(N)
  18653. C                is the superdiagonal of the tridiagonal matrix.
  18654. C                E(1) through E(N-1) should contain the superdiagonal.
  18655. C                On output E is destroyed.
  18656. C
  18657. C        B       COMPLEX(N)
  18658. C                is the right hand side vector.
  18659. C
  18660. C     On Return
  18661. C
  18662. C        B       is the solution vector.
  18663. C
  18664. C        INFO    INTEGER
  18665. C                = 0 normal value.
  18666. C                = K if the K-th element of the diagonal becomes
  18667. C                    exactly zero.  The subroutine returns when
  18668. C                    this is detected.
  18669. C
  18670. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  18671. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  18672. C***ROUTINES CALLED  (NONE)
  18673. C***REVISION HISTORY  (YYMMDD)
  18674. C   780814  DATE WRITTEN
  18675. C   890831  Modified array declarations.  (WRB)
  18676. C   890831  REVISION DATE from Version 3.2
  18677. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18678. C   900326  Removed duplicate information from DESCRIPTION section.
  18679. C           (WRB)
  18680. C   920501  Reformatted the REFERENCES section.  (WRB)
  18681. C***END PROLOGUE  CGTSL
  18682.       INTEGER N,INFO
  18683.       COMPLEX C(*),D(*),E(*),B(*)
  18684. C
  18685.       INTEGER K,KB,KP1,NM1,NM2
  18686.       COMPLEX T
  18687.       COMPLEX ZDUM
  18688.       REAL CABS1
  18689.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  18690. C***FIRST EXECUTABLE STATEMENT  CGTSL
  18691.          INFO = 0
  18692.          C(1) = D(1)
  18693.          NM1 = N - 1
  18694.          IF (NM1 .LT. 1) GO TO 40
  18695.             D(1) = E(1)
  18696.             E(1) = (0.0E0,0.0E0)
  18697.             E(N) = (0.0E0,0.0E0)
  18698. C
  18699.             DO 30 K = 1, NM1
  18700.                KP1 = K + 1
  18701. C
  18702. C              FIND THE LARGEST OF THE TWO ROWS
  18703. C
  18704.                IF (CABS1(C(KP1)) .LT. CABS1(C(K))) GO TO 10
  18705. C
  18706. C                 INTERCHANGE ROW
  18707. C
  18708.                   T = C(KP1)
  18709.                   C(KP1) = C(K)
  18710.                   C(K) = T
  18711.                   T = D(KP1)
  18712.                   D(KP1) = D(K)
  18713.                   D(K) = T
  18714.                   T = E(KP1)
  18715.                   E(KP1) = E(K)
  18716.                   E(K) = T
  18717.                   T = B(KP1)
  18718.                   B(KP1) = B(K)
  18719.                   B(K) = T
  18720.    10          CONTINUE
  18721. C
  18722. C              ZERO ELEMENTS
  18723. C
  18724.                IF (CABS1(C(K)) .NE. 0.0E0) GO TO 20
  18725.                   INFO = K
  18726.                   GO TO 100
  18727.    20          CONTINUE
  18728.                T = -C(KP1)/C(K)
  18729.                C(KP1) = D(KP1) + T*D(K)
  18730.                D(KP1) = E(KP1) + T*E(K)
  18731.                E(KP1) = (0.0E0,0.0E0)
  18732.                B(KP1) = B(KP1) + T*B(K)
  18733.    30       CONTINUE
  18734.    40    CONTINUE
  18735.          IF (CABS1(C(N)) .NE. 0.0E0) GO TO 50
  18736.             INFO = N
  18737.          GO TO 90
  18738.    50    CONTINUE
  18739. C
  18740. C           BACK SOLVE
  18741. C
  18742.             NM2 = N - 2
  18743.             B(N) = B(N)/C(N)
  18744.             IF (N .EQ. 1) GO TO 80
  18745.                B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
  18746.                IF (NM2 .LT. 1) GO TO 70
  18747.                DO 60 KB = 1, NM2
  18748.                   K = NM2 - KB + 1
  18749.                   B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
  18750.    60          CONTINUE
  18751.    70          CONTINUE
  18752.    80       CONTINUE
  18753.    90    CONTINUE
  18754.   100 CONTINUE
  18755. C
  18756.       RETURN
  18757.       END
  18758. *DECK CH
  18759.       SUBROUTINE CH (NM, N, AR, AI, W, MATZ, ZR, ZI, FV1, FV2, FM1,
  18760.      +   IERR)
  18761. C***BEGIN PROLOGUE  CH
  18762. C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
  18763. C            of a complex Hermitian matrix.
  18764. C***LIBRARY   SLATEC (EISPACK)
  18765. C***CATEGORY  D4A3
  18766. C***TYPE      COMPLEX (RS-S, CH-C)
  18767. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  18768. C***AUTHOR  Smith, B. T., et al.
  18769. C***DESCRIPTION
  18770. C
  18771. C     This subroutine calls the recommended sequence of
  18772. C     subroutines from the eigensystem subroutine package (EISPACK)
  18773. C     to find the eigenvalues and eigenvectors (if desired)
  18774. C     of a COMPLEX HERMITIAN matrix.
  18775. C
  18776. C     On INPUT
  18777. C
  18778. C        NM must be set to the row dimension of the two-dimensional
  18779. C          array parameters, AR, AI, ZR and ZI, as declared in the
  18780. C          calling program dimension statement.  NM is an INTEGER
  18781. C          variable.
  18782. C
  18783. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  18784. C          variable.  N must be less than or equal to NM.
  18785. C
  18786. C        AR and AI contain the real and imaginary parts, respectively,
  18787. C          of the complex Hermitian matrix.  AR and AI are
  18788. C          two-dimensional REAL arrays, dimensioned AR(NM,N)
  18789. C          and AI(NM,N).
  18790. C
  18791. C        MATZ is an INTEGER variable set equal to zero if only
  18792. C          eigenvalues are desired.  Otherwise, it is set to any
  18793. C          non-zero integer for both eigenvalues and eigenvectors.
  18794. C
  18795. C     On OUTPUT
  18796. C
  18797. C        W contains the eigenvalues in ascending order.
  18798. C          W is a one-dimensional REAL array, dimensioned W(N).
  18799. C
  18800. C        ZR and ZI contain the real and imaginary parts, respectively,
  18801. C          of the eigenvectors if MATZ is not zero.  ZR and ZI are
  18802. C          two-dimensional REAL arrays, dimensioned ZR(NM,N) and
  18803. C          ZI(NM,N).
  18804. C
  18805. C        IERR is an INTEGER flag set to
  18806. C          Zero       for normal return,
  18807. C          10*N       if N is greater than NM,
  18808. C          J          if the J-th eigenvalue has not been
  18809. C                     determined after a total of 30 iterations.
  18810. C                     The eigenvalues should be correct for indices
  18811. C                     1, 2, ..., IERR-1, but no eigenvectors are
  18812. C                     computed.
  18813. C
  18814. C        FV1 and FV2 are one-dimensional REAL arrays used for
  18815. C          temporary storage, dimensioned FV1(N) and FV2(N).
  18816. C
  18817. C        FM1 is a two-dimensional REAL array used for temporary
  18818. C          storage, dimensioned FM1(2,N).
  18819. C
  18820. C     Questions and comments should be directed to B. S. Garbow,
  18821. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  18822. C     ------------------------------------------------------------------
  18823. C
  18824. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  18825. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  18826. C                 system Routines - EISPACK Guide, Springer-Verlag,
  18827. C                 1976.
  18828. C***ROUTINES CALLED  HTRIBK, HTRIDI, TQL2, TQLRAT
  18829. C***REVISION HISTORY  (YYMMDD)
  18830. C   760101  DATE WRITTEN
  18831. C   890831  Modified array declarations.  (WRB)
  18832. C   890831  REVISION DATE from Version 3.2
  18833. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  18834. C   920501  Reformatted the REFERENCES section.  (WRB)
  18835. C***END PROLOGUE  CH
  18836. C
  18837.       INTEGER I,J,N,NM,IERR,MATZ
  18838.       REAL AR(NM,*),AI(NM,*),W(*),ZR(NM,*),ZI(NM,*)
  18839.       REAL FV1(*),FV2(*),FM1(2,*)
  18840. C
  18841. C***FIRST EXECUTABLE STATEMENT  CH
  18842.       IF (N .LE. NM) GO TO 10
  18843.       IERR = 10 * N
  18844.       GO TO 50
  18845. C
  18846.    10 CALL  HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1)
  18847.       IF (MATZ .NE. 0) GO TO 20
  18848. C     .......... FIND EIGENVALUES ONLY ..........
  18849.       CALL  TQLRAT(N,W,FV2,IERR)
  18850.       GO TO 50
  18851. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  18852.    20 DO 40 I = 1, N
  18853. C
  18854.          DO 30 J = 1, N
  18855.             ZR(J,I) = 0.0E0
  18856.    30    CONTINUE
  18857. C
  18858.          ZR(I,I) = 1.0E0
  18859.    40 CONTINUE
  18860. C
  18861.       CALL  TQL2(NM,N,W,FV1,ZR,IERR)
  18862.       IF (IERR .NE. 0) GO TO 50
  18863.       CALL  HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI)
  18864.    50 RETURN
  18865.       END
  18866. *DECK CHFCM
  18867.       INTEGER FUNCTION CHFCM (D1, D2, DELTA)
  18868. C***BEGIN PROLOGUE  CHFCM
  18869. C***SUBSIDIARY
  18870. C***PURPOSE  Check a single cubic for monotonicity.
  18871. C***LIBRARY   SLATEC (PCHIP)
  18872. C***TYPE      SINGLE PRECISION (CHFCM-S, DCHFCM-D)
  18873. C***AUTHOR  Fritsch, F. N., (LLNL)
  18874. C***DESCRIPTION
  18875. C
  18876. C *Usage:
  18877. C
  18878. C        REAL  D1, D2, DELTA
  18879. C        INTEGER  ISMON, CHFCM
  18880. C
  18881. C        ISMON = CHFCM (D1, D2, DELTA)
  18882. C
  18883. C *Arguments:
  18884. C
  18885. C     D1,D2:IN  are the derivative values at the ends of an interval.
  18886. C
  18887. C     DELTA:IN  is the data slope over that interval.
  18888. C
  18889. C *Function Return Values:
  18890. C     ISMON : indicates the monotonicity of the cubic segment:
  18891. C             ISMON = -3  if function is probably decreasing;
  18892. C             ISMON = -1  if function is strictly decreasing;
  18893. C             ISMON =  0  if function is constant;
  18894. C             ISMON =  1  if function is strictly increasing;
  18895. C             ISMON =  2  if function is non-monotonic;
  18896. C             ISMON =  3  if function is probably increasing.
  18897. C           If ABS(ISMON)=3, the derivative values are too close to the
  18898. C           boundary of the monotonicity region to declare monotonicity
  18899. C           in the presence of roundoff error.
  18900. C
  18901. C *Description:
  18902. C
  18903. C          CHFCM:  Cubic Hermite Function -- Check Monotonicity.
  18904. C
  18905. C    Called by  PCHCM  to determine the monotonicity properties of the
  18906. C    cubic with boundary derivative values D1,D2 and chord slope DELTA.
  18907. C
  18908. C *Cautions:
  18909. C     This is essentially the same as old CHFMC, except that a
  18910. C     new output value, -3, was added February 1989.  (Formerly, -3
  18911. C     and +3 were lumped together in the single value 3.)  Codes that
  18912. C     flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed.
  18913. C     Codes that check via "IF (ISMON.GE.3)" should change the test to
  18914. C     "IF (IABS(ISMON).GE.3)".  Codes that declare monotonicity via
  18915. C     "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)".
  18916. C
  18917. C   REFER TO  PCHCM
  18918. C
  18919. C***ROUTINES CALLED  R1MACH
  18920. C***REVISION HISTORY  (YYMMDD)
  18921. C   820518  DATE WRITTEN
  18922. C   820805  Converted to SLATEC library version.
  18923. C   831201  Changed from  ISIGN  to SIGN  to correct bug that
  18924. C           produced wrong sign when -1 .LT. DELTA .LT. 0 .
  18925. C   890206  Added SAVE statements.
  18926. C   890207  Added sign to returned value ISMON=3 and corrected
  18927. C           argument description accordingly.
  18928. C   890306  Added caution about changed output.
  18929. C   890407  Changed name from CHFMC to CHFCM, as requested at the
  18930. C           March 1989 SLATEC CML meeting, and made a few other
  18931. C           minor modifications necessitated by this change.
  18932. C   890407  Converted to new SLATEC format.
  18933. C   890407  Modified DESCRIPTION to LDOC format.
  18934. C   891214  Moved SAVE statements.  (WRB)
  18935. C***END PROLOGUE  CHFCM
  18936. C
  18937. C  Fortran intrinsics used:  SIGN.
  18938. C  Other routines used:  R1MACH.
  18939. C
  18940. C ----------------------------------------------------------------------
  18941. C
  18942. C  Programming notes:
  18943. C
  18944. C     TEN is actually a tuning parameter, which determines the width of
  18945. C     the fuzz around the elliptical boundary.
  18946. C
  18947. C     To produce a double precision version, simply:
  18948. C        a. Change CHFCM to DCHFCM wherever it occurs,
  18949. C        b. Change the real declarations to double precision, and
  18950. C        c. Change the constants ZERO, ONE, ... to double precision.
  18951. C
  18952. C  DECLARE ARGUMENTS.
  18953. C
  18954.       REAL  D1, D2, DELTA
  18955. C
  18956. C  DECLARE LOCAL VARIABLES.
  18957. C
  18958.       INTEGER  ISMON, ITRUE
  18959.       REAL  A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, ZERO
  18960.       SAVE ZERO, ONE, TWO, THREE, FOUR
  18961.       SAVE TEN
  18962. C
  18963. C  INITIALIZE.
  18964. C
  18965.       DATA  ZERO /0./,  ONE /1.0/,  TWO /2./,  THREE /3./,  FOUR /4./,
  18966.      1      TEN /10./
  18967. C
  18968. C        MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND.
  18969. C***FIRST EXECUTABLE STATEMENT  CHFCM
  18970.       EPS = TEN*R1MACH(4)
  18971. C
  18972. C  MAKE THE CHECK.
  18973. C
  18974.       IF (DELTA .EQ. ZERO)  THEN
  18975. C        CASE OF CONSTANT DATA.
  18976.          IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO))  THEN
  18977.             ISMON = 0
  18978.          ELSE
  18979.             ISMON = 2
  18980.          ENDIF
  18981.       ELSE
  18982. C        DATA IS NOT CONSTANT -- PICK UP SIGN.
  18983.          ITRUE = SIGN (ONE, DELTA)
  18984.          A = D1/DELTA
  18985.          B = D2/DELTA
  18986.          IF ((A.LT.ZERO) .OR. (B.LT.ZERO))  THEN
  18987.             ISMON = 2
  18988.          ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS))  THEN
  18989. C           INSIDE SQUARE (0,3)X(0,3)  IMPLIES   OK.
  18990.             ISMON = ITRUE
  18991.          ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS))  THEN
  18992. C           OUTSIDE SQUARE (0,4)X(0,4)  IMPLIES   NONMONOTONIC.
  18993.             ISMON = 2
  18994.          ELSE
  18995. C           MUST CHECK AGAINST BOUNDARY OF ELLIPSE.
  18996.             A = A - TWO
  18997.             B = B - TWO
  18998.             PHI = ((A*A + B*B) + A*B) - THREE
  18999.             IF (PHI .LT. -EPS)  THEN
  19000.                ISMON = ITRUE
  19001.             ELSE IF (PHI .GT. EPS)  THEN
  19002.                ISMON = 2
  19003.             ELSE
  19004. C              TO CLOSE TO BOUNDARY TO TELL,
  19005. C                  IN THE PRESENCE OF ROUND-OFF ERRORS.
  19006.                ISMON = 3*ITRUE
  19007.             ENDIF
  19008.          ENDIF
  19009.       ENDIF
  19010. C
  19011. C  RETURN VALUE.
  19012. C
  19013.       CHFCM = ISMON
  19014.       RETURN
  19015. C------------- LAST LINE OF CHFCM FOLLOWS ------------------------------
  19016.       END
  19017. *DECK CHFDV
  19018.       SUBROUTINE CHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT,
  19019.      +   IERR)
  19020. C***BEGIN PROLOGUE  CHFDV
  19021. C***PURPOSE  Evaluate a cubic polynomial given in Hermite form and its
  19022. C            first derivative at an array of points.  While designed for
  19023. C            use by PCHFD, it may be useful directly as an evaluator
  19024. C            for a piecewise cubic Hermite function in applications,
  19025. C            such as graphing, where the interval is known in advance.
  19026. C            If only function values are required, use CHFEV instead.
  19027. C***LIBRARY   SLATEC (PCHIP)
  19028. C***CATEGORY  E3, H1
  19029. C***TYPE      SINGLE PRECISION (CHFDV-S, DCHFDV-D)
  19030. C***KEYWORDS  CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION,
  19031. C             CUBIC POLYNOMIAL EVALUATION, PCHIP
  19032. C***AUTHOR  Fritsch, F. N., (LLNL)
  19033. C             Lawrence Livermore National Laboratory
  19034. C             P.O. Box 808  (L-316)
  19035. C             Livermore, CA  94550
  19036. C             FTS 532-4275, (510) 422-4275
  19037. C***DESCRIPTION
  19038. C
  19039. C        CHFDV:  Cubic Hermite Function and Derivative Evaluator
  19040. C
  19041. C     Evaluates the cubic polynomial determined by function values
  19042. C     F1,F2 and derivatives D1,D2 on interval (X1,X2), together with
  19043. C     its first derivative, at the points  XE(J), J=1(1)NE.
  19044. C
  19045. C     If only function values are required, use CHFEV, instead.
  19046. C
  19047. C ----------------------------------------------------------------------
  19048. C
  19049. C  Calling sequence:
  19050. C
  19051. C        INTEGER  NE, NEXT(2), IERR
  19052. C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), DE(NE)
  19053. C
  19054. C        CALL  CHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR)
  19055. C
  19056. C   Parameters:
  19057. C
  19058. C     X1,X2 -- (input) endpoints of interval of definition of cubic.
  19059. C           (Error return if  X1.EQ.X2 .)
  19060. C
  19061. C     F1,F2 -- (input) values of function at X1 and X2, respectively.
  19062. C
  19063. C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
  19064. C
  19065. C     NE -- (input) number of evaluation points.  (Error return if
  19066. C           NE.LT.1 .)
  19067. C
  19068. C     XE -- (input) real array of points at which the functions are to
  19069. C           be evaluated.  If any of the XE are outside the interval
  19070. C           [X1,X2], a warning error is returned in NEXT.
  19071. C
  19072. C     FE -- (output) real array of values of the cubic function defined
  19073. C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
  19074. C
  19075. C     DE -- (output) real array of values of the first derivative of
  19076. C           the same function at the points  XE.
  19077. C
  19078. C     NEXT -- (output) integer array indicating number of extrapolation
  19079. C           points:
  19080. C            NEXT(1) = number of evaluation points to left of interval.
  19081. C            NEXT(2) = number of evaluation points to right of interval.
  19082. C
  19083. C     IERR -- (output) error flag.
  19084. C           Normal return:
  19085. C              IERR = 0  (no errors).
  19086. C           "Recoverable" errors:
  19087. C              IERR = -1  if NE.LT.1 .
  19088. C              IERR = -2  if X1.EQ.X2 .
  19089. C                (Output arrays have not been changed in either case.)
  19090. C
  19091. C***REFERENCES  (NONE)
  19092. C***ROUTINES CALLED  XERMSG
  19093. C***REVISION HISTORY  (YYMMDD)
  19094. C   811019  DATE WRITTEN
  19095. C   820803  Minor cosmetic changes for release 1.
  19096. C   890411  Added SAVE statements (Vers. 3.2).
  19097. C   890531  Changed all specific intrinsics to generic.  (WRB)
  19098. C   890831  Modified array declarations.  (WRB)
  19099. C   890831  REVISION DATE from Version 3.2
  19100. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  19101. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  19102. C***END PROLOGUE  CHFDV
  19103. C  Programming notes:
  19104. C
  19105. C     To produce a double precision version, simply:
  19106. C        a. Change CHFDV to DCHFDV wherever it occurs,
  19107. C        b. Change the real declaration to double precision, and
  19108. C        c. Change the constant ZERO to double precision.
  19109. C
  19110. C  DECLARE ARGUMENTS.
  19111. C
  19112.       INTEGER  NE, NEXT(2), IERR
  19113.       REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*)
  19114. C
  19115. C  DECLARE LOCAL VARIABLES.
  19116. C
  19117.       INTEGER  I
  19118.       REAL  C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
  19119.       SAVE ZERO
  19120.       DATA  ZERO /0./
  19121. C
  19122. C  VALIDITY-CHECK ARGUMENTS.
  19123. C
  19124. C***FIRST EXECUTABLE STATEMENT  CHFDV
  19125.       IF (NE .LT. 1)  GO TO 5001
  19126.       H = X2 - X1
  19127.       IF (H .EQ. ZERO)  GO TO 5002
  19128. C
  19129. C  INITIALIZE.
  19130. C
  19131.       IERR = 0
  19132.       NEXT(1) = 0
  19133.       NEXT(2) = 0
  19134.       XMI = MIN(ZERO, H)
  19135.       XMA = MAX(ZERO, H)
  19136. C
  19137. C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
  19138. C
  19139.       DELTA = (F2 - F1)/H
  19140.       DEL1 = (D1 - DELTA)/H
  19141.       DEL2 = (D2 - DELTA)/H
  19142. C                                           (DELTA IS NO LONGER NEEDED.)
  19143.       C2 = -(DEL1+DEL1 + DEL2)
  19144.       C2T2 = C2 + C2
  19145.       C3 = (DEL1 + DEL2)/H
  19146. C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
  19147.       C3T3 = C3+C3+C3
  19148. C
  19149. C  EVALUATION LOOP.
  19150. C
  19151.       DO 500  I = 1, NE
  19152.          X = XE(I) - X1
  19153.          FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
  19154.          DE(I) = D1 + X*(C2T2 + X*C3T3)
  19155. C          COUNT EXTRAPOLATION POINTS.
  19156.          IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
  19157.          IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
  19158. C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
  19159.   500 CONTINUE
  19160. C
  19161. C  NORMAL RETURN.
  19162. C
  19163.       RETURN
  19164. C
  19165. C  ERROR RETURNS.
  19166. C
  19167.  5001 CONTINUE
  19168. C     NE.LT.1 RETURN.
  19169.       IERR = -1
  19170.       CALL XERMSG ('SLATEC', 'CHFDV',
  19171.      +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
  19172.       RETURN
  19173. C
  19174.  5002 CONTINUE
  19175. C     X1.EQ.X2 RETURN.
  19176.       IERR = -2
  19177.       CALL XERMSG ('SLATEC', 'CHFDV', 'INTERVAL ENDPOINTS EQUAL', IERR,
  19178.      +   1)
  19179.       RETURN
  19180. C------------- LAST LINE OF CHFDV FOLLOWS ------------------------------
  19181.       END
  19182. *DECK CHFEV
  19183.       SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR)
  19184. C***BEGIN PROLOGUE  CHFEV
  19185. C***PURPOSE  Evaluate a cubic polynomial given in Hermite form at an
  19186. C            array of points.  While designed for use by PCHFE, it may
  19187. C            be useful directly as an evaluator for a piecewise cubic
  19188. C            Hermite function in applications, such as graphing, where
  19189. C            the interval is known in advance.
  19190. C***LIBRARY   SLATEC (PCHIP)
  19191. C***CATEGORY  E3
  19192. C***TYPE      SINGLE PRECISION (CHFEV-S, DCHFEV-D)
  19193. C***KEYWORDS  CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION,
  19194. C             PCHIP
  19195. C***AUTHOR  Fritsch, F. N., (LLNL)
  19196. C             Lawrence Livermore National Laboratory
  19197. C             P.O. Box 808  (L-316)
  19198. C             Livermore, CA  94550
  19199. C             FTS 532-4275, (510) 422-4275
  19200. C***DESCRIPTION
  19201. C
  19202. C          CHFEV:  Cubic Hermite Function EValuator
  19203. C
  19204. C     Evaluates the cubic polynomial determined by function values
  19205. C     F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points
  19206. C     XE(J), J=1(1)NE.
  19207. C
  19208. C ----------------------------------------------------------------------
  19209. C
  19210. C  Calling sequence:
  19211. C
  19212. C        INTEGER  NE, NEXT(2), IERR
  19213. C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE)
  19214. C
  19215. C        CALL  CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR)
  19216. C
  19217. C   Parameters:
  19218. C
  19219. C     X1,X2 -- (input) endpoints of interval of definition of cubic.
  19220. C           (Error return if  X1.EQ.X2 .)
  19221. C
  19222. C     F1,F2 -- (input) values of function at X1 and X2, respectively.
  19223. C
  19224. C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
  19225. C
  19226. C     NE -- (input) number of evaluation points.  (Error return if
  19227. C           NE.LT.1 .)
  19228. C
  19229. C     XE -- (input) real array of points at which the function is to be
  19230. C           evaluated.  If any of the XE are outside the interval
  19231. C           [X1,X2], a warning error is returned in NEXT.
  19232. C
  19233. C     FE -- (output) real array of values of the cubic function defined
  19234. C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
  19235. C
  19236. C     NEXT -- (output) integer array indicating number of extrapolation
  19237. C           points:
  19238. C            NEXT(1) = number of evaluation points to left of interval.
  19239. C            NEXT(2) = number of evaluation points to right of interval.
  19240. C
  19241. C     IERR -- (output) error flag.
  19242. C           Normal return:
  19243. C              IERR = 0  (no errors).
  19244. C           "Recoverable" errors:
  19245. C              IERR = -1  if NE.LT.1 .
  19246. C              IERR = -2  if X1.EQ.X2 .
  19247. C                (The FE-array has not been changed in either case.)
  19248. C
  19249. C***REFERENCES  (NONE)
  19250. C***ROUTINES CALLED  XERMSG
  19251. C***REVISION HISTORY  (YYMMDD)
  19252. C   811019  DATE WRITTEN
  19253. C   820803  Minor cosmetic changes for release 1.
  19254. C   890411  Added SAVE statements (Vers. 3.2).
  19255. C   890531  Changed all specific intrinsics to generic.  (WRB)
  19256. C   890703  Corrected category record.  (WRB)
  19257. C   890703  REVISION DATE from Version 3.2
  19258. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  19259. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  19260. C***END PROLOGUE  CHFEV
  19261. C  Programming notes:
  19262. C
  19263. C     To produce a double precision version, simply:
  19264. C        a. Change CHFEV to DCHFEV wherever it occurs,
  19265. C        b. Change the real declaration to double precision, and
  19266. C        c. Change the constant ZERO to double precision.
  19267. C
  19268. C  DECLARE ARGUMENTS.
  19269. C
  19270.       INTEGER  NE, NEXT(2), IERR
  19271.       REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*)
  19272. C
  19273. C  DECLARE LOCAL VARIABLES.
  19274. C
  19275.       INTEGER  I
  19276.       REAL  C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
  19277.       SAVE ZERO
  19278.       DATA  ZERO /0./
  19279. C
  19280. C  VALIDITY-CHECK ARGUMENTS.
  19281. C
  19282. C***FIRST EXECUTABLE STATEMENT  CHFEV
  19283.       IF (NE .LT. 1)  GO TO 5001
  19284.       H = X2 - X1
  19285.       IF (H .EQ. ZERO)  GO TO 5002
  19286. C
  19287. C  INITIALIZE.
  19288. C
  19289.       IERR = 0
  19290.       NEXT(1) = 0
  19291.       NEXT(2) = 0
  19292.       XMI = MIN(ZERO, H)
  19293.       XMA = MAX(ZERO, H)
  19294. C
  19295. C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
  19296. C
  19297.       DELTA = (F2 - F1)/H
  19298.       DEL1 = (D1 - DELTA)/H
  19299.       DEL2 = (D2 - DELTA)/H
  19300. C                                           (DELTA IS NO LONGER NEEDED.)
  19301.       C2 = -(DEL1+DEL1 + DEL2)
  19302.       C3 = (DEL1 + DEL2)/H
  19303. C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
  19304. C
  19305. C  EVALUATION LOOP.
  19306. C
  19307.       DO 500  I = 1, NE
  19308.          X = XE(I) - X1
  19309.          FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
  19310. C          COUNT EXTRAPOLATION POINTS.
  19311.          IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
  19312.          IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
  19313. C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
  19314.   500 CONTINUE
  19315. C
  19316. C  NORMAL RETURN.
  19317. C
  19318.       RETURN
  19319. C
  19320. C  ERROR RETURNS.
  19321. C
  19322.  5001 CONTINUE
  19323. C     NE.LT.1 RETURN.
  19324.       IERR = -1
  19325.       CALL XERMSG ('SLATEC', 'CHFEV',
  19326.      +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
  19327.       RETURN
  19328. C
  19329.  5002 CONTINUE
  19330. C     X1.EQ.X2 RETURN.
  19331.       IERR = -2
  19332.       CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR,
  19333.      +   1)
  19334.       RETURN
  19335. C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------
  19336.       END
  19337. *DECK CHFIV
  19338.       REAL FUNCTION CHFIV (X1, X2, F1, F2, D1, D2, A, B, IERR)
  19339. C***BEGIN PROLOGUE  CHFIV
  19340. C***SUBSIDIARY
  19341. C***PURPOSE  Subsidiary to PCHIA
  19342. C***LIBRARY   SLATEC (PCHIP)
  19343. C***TYPE      SINGLE PRECISION (CHFIV-S, DCHFIV-D)
  19344. C***AUTHOR  Fritsch, F. N., (LLNL)
  19345. C***DESCRIPTION
  19346. C
  19347. C          CHFIV:  Cubic Hermite Function Integral Evaluator.
  19348. C
  19349. C     Called by  PCHIA  to evaluate the integral of a single cubic (in
  19350. C     Hermite form) over an arbitrary interval (A,B).
  19351. C
  19352. C ----------------------------------------------------------------------
  19353. C
  19354. C  Calling sequence:
  19355. C
  19356. C        INTEGER  IERR
  19357. C        REAL  X1, X2, F1, F2, D1, D2, A, B
  19358. C        REAL  VALUE, CHFIV
  19359. C
  19360. C        VALUE = CHFIV (X1, X2, F1, F2, D1, D2, A, B, IERR)
  19361. C
  19362. C   Parameters:
  19363. C
  19364. C     VALUE -- (output) value of the requested integral.
  19365. C
  19366. C     X1,X2 -- (input) endpoints if interval of definition of cubic.
  19367. C           (Must be distinct.  Error return if not.)
  19368. C
  19369. C     F1,F2 -- (input) function values at the ends of the interval.
  19370. C
  19371. C     D1,D2 -- (input) derivative values at the ends of the interval.
  19372. C
  19373. C     A,B -- (input) endpoints of interval of integration.
  19374. C
  19375. C     IERR -- (output) error flag.
  19376. C           Normal return:
  19377. C              IERR = 0 (no errors).
  19378. C           "Recoverable errors":
  19379. C              IERR = -1  if X1.EQ.X2 .
  19380. C                (VALUE has not been set in this case.)
  19381. C
  19382. C***SEE ALSO  PCHIA
  19383. C***ROUTINES CALLED  XERMSG
  19384. C***REVISION HISTORY  (YYMMDD)
  19385. C   820730  DATE WRITTEN
  19386. C   820805  Converted to SLATEC library version.
  19387. C   870813  Minor cosmetic changes.
  19388. C   890411  1. Added SAVE statements (Vers. 3.2).
  19389. C           2. Added SIX to REAL declaration.
  19390. C   890411  REVISION DATE from Version 3.2
  19391. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  19392. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  19393. C   900328  Added TYPE section.  (WRB)
  19394. C   910408  Updated AUTHOR section in prologue.  (WRB)
  19395. C***END PROLOGUE  CHFIV
  19396. C  Programming notes:
  19397. C
  19398. C     To produce a double precision version, simply:
  19399. C        a. Change CHFIV to DCHFIV wherever it occurs,
  19400. C        b. Change the real declarations to double precision, and
  19401. C        c. Change the constants HALF, TWO, ... to double precision.
  19402. C
  19403. C  DECLARE ARGUMENTS.
  19404. C
  19405.       INTEGER  IERR
  19406.       REAL  X1, X2, F1, F2, D1, D2, A, B
  19407. C
  19408. C  DECLARE LOCAL VARIABLES.
  19409. C
  19410.       REAL  DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, PHIB1, PHIB2,
  19411.      *      PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, TB1, TB2, THREE,
  19412.      *      TWO, UA1, UA2, UB1, UB2
  19413.       SAVE HALF, TWO, THREE, FOUR, SIX
  19414. C
  19415. C  INITIALIZE.
  19416. C
  19417.       DATA  HALF /0.5/,  TWO /2./,  THREE /3./,  FOUR /4./,  SIX /6./
  19418. C
  19419. C  VALIDITY CHECK INPUT.
  19420. C
  19421. C***FIRST EXECUTABLE STATEMENT  CHFIV
  19422.       IF (X1 .EQ. X2)  GO TO 5001
  19423.       IERR = 0
  19424. C
  19425. C  COMPUTE INTEGRAL.
  19426. C
  19427.       H = X2 - X1
  19428.       TA1 = (A - X1) / H
  19429.       TA2 = (X2 - A) / H
  19430.       TB1 = (B - X1) / H
  19431.       TB2 = (X2 - B) / H
  19432. C
  19433.       UA1 = TA1**3
  19434.       PHIA1 = UA1 * (TWO - TA1)
  19435.       PSIA1 = UA1 * (THREE*TA1 - FOUR)
  19436.       UA2 = TA2**3
  19437.       PHIA2 =  UA2 * (TWO - TA2)
  19438.       PSIA2 = -UA2 * (THREE*TA2 - FOUR)
  19439. C
  19440.       UB1 = TB1**3
  19441.       PHIB1 = UB1 * (TWO - TB1)
  19442.       PSIB1 = UB1 * (THREE*TB1 - FOUR)
  19443.       UB2 = TB2**3
  19444.       PHIB2 =  UB2 * (TWO - TB2)
  19445.       PSIB2 = -UB2 * (THREE*TB2 - FOUR)
  19446. C
  19447.       FTERM =   F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1)
  19448.       DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX)
  19449. C
  19450. C  RETURN VALUE.
  19451. C
  19452.       CHFIV = (HALF*H) * (FTERM + DTERM)
  19453.       RETURN
  19454. C
  19455. C  ERROR RETURN.
  19456. C
  19457.  5001 CONTINUE
  19458.       IERR = -1
  19459.       CALL XERMSG ('SLATEC', 'CHFIV', 'X1 EQUAL TO X2', IERR, 1)
  19460.       RETURN
  19461. C------------- LAST LINE OF CHFIV FOLLOWS ------------------------------
  19462.       END
  19463. *DECK CHICO
  19464.       SUBROUTINE CHICO (A, LDA, N, KPVT, RCOND, Z)
  19465. C***BEGIN PROLOGUE  CHICO
  19466. C***PURPOSE  Factor a complex Hermitian matrix by elimination with sym-
  19467. C            metric pivoting and estimate the condition of the matrix.
  19468. C***LIBRARY   SLATEC (LINPACK)
  19469. C***CATEGORY  D2D1A
  19470. C***TYPE      COMPLEX (SSICO-S, DSICO-D, CHICO-C, CSICO-C)
  19471. C***KEYWORDS  CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK,
  19472. C             MATRIX FACTORIZATION
  19473. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  19474. C***DESCRIPTION
  19475. C
  19476. C     CHICO factors a complex Hermitian matrix by elimination with
  19477. C     symmetric pivoting and estimates the condition of the matrix.
  19478. C
  19479. C     If  RCOND  is not needed, CHIFA is slightly faster.
  19480. C     To solve  A*X = B , follow CHICO by CHISL.
  19481. C     To compute  INVERSE(A)*C , follow CHICO by CHISL.
  19482. C     To compute  INVERSE(A) , follow CHICO by CHIDI.
  19483. C     To compute  DETERMINANT(A) , follow CHICO by CHIDI.
  19484. C     To compute  INERTIA(A), follow CHICO by CHIDI.
  19485. C
  19486. C     On Entry
  19487. C
  19488. C        A       COMPLEX(LDA, N)
  19489. C                the Hermitian matrix to be factored.
  19490. C                Only the diagonal and upper triangle are used.
  19491. C
  19492. C        LDA     INTEGER
  19493. C                the leading dimension of the array  A .
  19494. C
  19495. C        N       INTEGER
  19496. C                the order of the matrix  A .
  19497. C
  19498. C     Output
  19499. C
  19500. C        A       a block diagonal matrix and the multipliers which
  19501. C                were used to obtain it.
  19502. C                The factorization can be written  A = U*D*CTRANS(U)
  19503. C                where  U  is a product of permutation and unit
  19504. C                upper triangular matrices , CTRANS(U) is the
  19505. C                conjugate transpose of  U , and  D  is block diagonal
  19506. C                with 1 by 1 and 2 by 2 blocks.
  19507. C
  19508. C        KVPT    INTEGER(N)
  19509. C                an integer vector of pivot indices.
  19510. C
  19511. C        RCOND   REAL
  19512. C                an estimate of the reciprocal condition of  A .
  19513. C                For the system  A*X = B , relative perturbations
  19514. C                in  A  and  B  of size  EPSILON  may cause
  19515. C                relative perturbations in  X  of size  EPSILON/RCOND .
  19516. C                If  RCOND  is so small that the logical expression
  19517. C                           1.0 + RCOND .EQ. 1.0
  19518. C                is true, then  A  may be singular to working
  19519. C                precision.  In particular,  RCOND  is zero  if
  19520. C                exact singularity is detected or the estimate
  19521. C                underflows.
  19522. C
  19523. C        Z       COMPLEX(N)
  19524. C                a work vector whose contents are usually unimportant.
  19525. C                If  A  is close to a singular matrix, then  Z  is
  19526. C                an approximate null vector in the sense that
  19527. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  19528. C
  19529. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  19530. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  19531. C***ROUTINES CALLED  CAXPY, CDOTC, CHIFA, CSSCAL, SCASUM
  19532. C***REVISION HISTORY  (YYMMDD)
  19533. C   780814  DATE WRITTEN
  19534. C   890531  Changed all specific intrinsics to generic.  (WRB)
  19535. C   890831  Modified array declarations.  (WRB)
  19536. C   891107  Modified routine equivalence list.  (WRB)
  19537. C   891107  REVISION DATE from Version 3.2
  19538. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  19539. C   900326  Removed duplicate information from DESCRIPTION section.
  19540. C           (WRB)
  19541. C   920501  Reformatted the REFERENCES section.  (WRB)
  19542. C***END PROLOGUE  CHICO
  19543.       INTEGER LDA,N,KPVT(*)
  19544.       COMPLEX A(LDA,*),Z(*)
  19545.       REAL RCOND
  19546. C
  19547.       COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T
  19548.       REAL ANORM,S,SCASUM,YNORM
  19549.       INTEGER I,INFO,J,JM1,K,KP,KPS,KS
  19550.       COMPLEX ZDUM,ZDUM2,CSIGN1
  19551.       REAL CABS1
  19552.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  19553.       CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2))
  19554. C
  19555. C     FIND NORM OF A USING ONLY UPPER HALF
  19556. C
  19557. C***FIRST EXECUTABLE STATEMENT  CHICO
  19558.       DO 30 J = 1, N
  19559.          Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0)
  19560.          JM1 = J - 1
  19561.          IF (JM1 .LT. 1) GO TO 20
  19562.          DO 10 I = 1, JM1
  19563.             Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0)
  19564.    10    CONTINUE
  19565.    20    CONTINUE
  19566.    30 CONTINUE
  19567.       ANORM = 0.0E0
  19568.       DO 40 J = 1, N
  19569.          ANORM = MAX(ANORM,REAL(Z(J)))
  19570.    40 CONTINUE
  19571. C
  19572. C     FACTOR
  19573. C
  19574.       CALL CHIFA(A,LDA,N,KPVT,INFO)
  19575. C
  19576. C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  19577. C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
  19578. C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  19579. C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
  19580. C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  19581. C
  19582. C     SOLVE U*D*W = E
  19583. C
  19584.       EK = (1.0E0,0.0E0)
  19585.       DO 50 J = 1, N
  19586.          Z(J) = (0.0E0,0.0E0)
  19587.    50 CONTINUE
  19588.       K = N
  19589.    60 IF (K .EQ. 0) GO TO 120
  19590.          KS = 1
  19591.          IF (KPVT(K) .LT. 0) KS = 2
  19592.          KP = ABS(KPVT(K))
  19593.          KPS = K + 1 - KS
  19594.          IF (KP .EQ. KPS) GO TO 70
  19595.             T = Z(KPS)
  19596.             Z(KPS) = Z(KP)
  19597.             Z(KP) = T
  19598.    70    CONTINUE
  19599.          IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K))
  19600.          Z(K) = Z(K) + EK
  19601.          CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1)
  19602.          IF (KS .EQ. 1) GO TO 80
  19603.             IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1))
  19604.             Z(K-1) = Z(K-1) + EK
  19605.             CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1)
  19606.    80    CONTINUE
  19607.          IF (KS .EQ. 2) GO TO 100
  19608.             IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 90
  19609.                S = CABS1(A(K,K))/CABS1(Z(K))
  19610.                CALL CSSCAL(N,S,Z,1)
  19611.                EK = CMPLX(S,0.0E0)*EK
  19612.    90       CONTINUE
  19613.             IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
  19614.             IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  19615.          GO TO 110
  19616.   100    CONTINUE
  19617.             AK = A(K,K)/CONJG(A(K-1,K))
  19618.             AKM1 = A(K-1,K-1)/A(K-1,K)
  19619.             BK = Z(K)/CONJG(A(K-1,K))
  19620.             BKM1 = Z(K-1)/A(K-1,K)
  19621.             DENOM = AK*AKM1 - 1.0E0
  19622.             Z(K) = (AKM1*BK - BKM1)/DENOM
  19623.             Z(K-1) = (AK*BKM1 - BK)/DENOM
  19624.   110    CONTINUE
  19625.          K = K - KS
  19626.       GO TO 60
  19627.   120 CONTINUE
  19628.       S = 1.0E0/SCASUM(N,Z,1)
  19629.       CALL CSSCAL(N,S,Z,1)
  19630. C
  19631. C     SOLVE CTRANS(U)*Y = W
  19632. C
  19633.       K = 1
  19634.   130 IF (K .GT. N) GO TO 160
  19635.          KS = 1
  19636.          IF (KPVT(K) .LT. 0) KS = 2
  19637.          IF (K .EQ. 1) GO TO 150
  19638.             Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1)
  19639.             IF (KS .EQ. 2)
  19640.      1         Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1)
  19641.             KP = ABS(KPVT(K))
  19642.             IF (KP .EQ. K) GO TO 140
  19643.                T = Z(K)
  19644.                Z(K) = Z(KP)
  19645.                Z(KP) = T
  19646.   140       CONTINUE
  19647.   150    CONTINUE
  19648.          K = K + KS
  19649.       GO TO 130
  19650.   160 CONTINUE
  19651.       S = 1.0E0/SCASUM(N,Z,1)
  19652.       CALL CSSCAL(N,S,Z,1)
  19653. C
  19654.       YNORM = 1.0E0
  19655. C
  19656. C     SOLVE U*D*V = Y
  19657. C
  19658.       K = N
  19659.   170 IF (K .EQ. 0) GO TO 230
  19660.          KS = 1
  19661.          IF (KPVT(K) .LT. 0) KS = 2
  19662.          IF (K .EQ. KS) GO TO 190
  19663.             KP = ABS(KPVT(K))
  19664.             KPS = K + 1 - KS
  19665.             IF (KP .EQ. KPS) GO TO 180
  19666.                T = Z(KPS)
  19667.                Z(KPS) = Z(KP)
  19668.                Z(KP) = T
  19669.   180       CONTINUE
  19670.             CALL CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1)
  19671.             IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1)
  19672.   190    CONTINUE
  19673.          IF (KS .EQ. 2) GO TO 210
  19674.             IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 200
  19675.                S = CABS1(A(K,K))/CABS1(Z(K))
  19676.                CALL CSSCAL(N,S,Z,1)
  19677.                YNORM = S*YNORM
  19678.   200       CONTINUE
  19679.             IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
  19680.             IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  19681.          GO TO 220
  19682.   210    CONTINUE
  19683.             AK = A(K,K)/CONJG(A(K-1,K))
  19684.             AKM1 = A(K-1,K-1)/A(K-1,K)
  19685.             BK = Z(K)/CONJG(A(K-1,K))
  19686.             BKM1 = Z(K-1)/A(K-1,K)
  19687.             DENOM = AK*AKM1 - 1.0E0
  19688.             Z(K) = (AKM1*BK - BKM1)/DENOM
  19689.             Z(K-1) = (AK*BKM1 - BK)/DENOM
  19690.   220    CONTINUE
  19691.          K = K - KS
  19692.       GO TO 170
  19693.   230 CONTINUE
  19694.       S = 1.0E0/SCASUM(N,Z,1)
  19695.       CALL CSSCAL(N,S,Z,1)
  19696.       YNORM = S*YNORM
  19697. C
  19698. C     SOLVE CTRANS(U)*Z = V
  19699. C
  19700.       K = 1
  19701.   240 IF (K .GT. N) GO TO 270
  19702.          KS = 1
  19703.          IF (KPVT(K) .LT. 0) KS = 2
  19704.          IF (K .EQ. 1) GO TO 260
  19705.             Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1)
  19706.             IF (KS .EQ. 2)
  19707.      1         Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1)
  19708.             KP = ABS(KPVT(K))
  19709.             IF (KP .EQ. K) GO TO 250
  19710.                T = Z(K)
  19711.                Z(K) = Z(KP)
  19712.                Z(KP) = T
  19713.   250       CONTINUE
  19714.   260    CONTINUE
  19715.          K = K + KS
  19716.       GO TO 240
  19717.   270 CONTINUE
  19718. C     MAKE ZNORM = 1.0
  19719.       S = 1.0E0/SCASUM(N,Z,1)
  19720.       CALL CSSCAL(N,S,Z,1)
  19721.       YNORM = S*YNORM
  19722. C
  19723.       IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  19724.       IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  19725.       RETURN
  19726.       END
  19727. *DECK CHIDI
  19728.       SUBROUTINE CHIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB)
  19729. C***BEGIN PROLOGUE  CHIDI
  19730. C***PURPOSE  Compute the determinant, inertia and inverse of a complex
  19731. C            Hermitian matrix using the factors obtained from CHIFA.
  19732. C***LIBRARY   SLATEC (LINPACK)
  19733. C***CATEGORY  D2D1A, D3D1A
  19734. C***TYPE      COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C)
  19735. C***KEYWORDS  DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK,
  19736. C             MATRIX
  19737. C***AUTHOR  Bunch, J., (UCSD)
  19738. C***DESCRIPTION
  19739. C
  19740. C     CHIDI computes the determinant, inertia and inverse
  19741. C     of a complex Hermitian matrix using the factors from CHIFA.
  19742. C
  19743. C     On Entry
  19744. C
  19745. C        A       COMPLEX(LDA,N)
  19746. C                the output from CHIFA.
  19747. C
  19748. C        LDA     INTEGER
  19749. C                the leading dimension of the array A.
  19750. C
  19751. C        N       INTEGER
  19752. C                the order of the matrix A.
  19753. C
  19754. C        KVPT    INTEGER(N)
  19755. C                the pivot vector from CHIFA.
  19756. C
  19757. C        WORK    COMPLEX(N)
  19758. C                work vector.  Contents destroyed.
  19759. C
  19760. C        JOB     INTEGER
  19761. C                JOB has the decimal expansion  ABC  where
  19762. C                   if  C .NE. 0, the inverse is computed,
  19763. C                   if  B .NE. 0, the determinant is computed,
  19764. C                   if  A .NE. 0, the inertia is computed.
  19765. C
  19766. C                For example, JOB = 111  gives all three.
  19767. C
  19768. C     On Return
  19769. C
  19770. C        Variables not requested by JOB are not used.
  19771. C
  19772. C        A      contains the upper triangle of the inverse of
  19773. C               the original matrix.  The strict lower triangle
  19774. C               is never referenced.
  19775. C
  19776. C        DET    REAL(2)
  19777. C               determinant of original matrix.
  19778. C               Determinant = DET(1) * 10.0**DET(2)
  19779. C               with 1.0 .LE. ABS(DET(1)) .LT. 10.0
  19780. C               or DET(1) = 0.0.
  19781. C
  19782. C        INERT  INTEGER(3)
  19783. C               the inertia of the original matrix.
  19784. C               INERT(1)  =  number of positive eigenvalues.
  19785. C               INERT(2)  =  number of negative eigenvalues.
  19786. C               INERT(3)  =  number of zero eigenvalues.
  19787. C
  19788. C     Error Condition
  19789. C
  19790. C        A division by zero may occur if the inverse is requested
  19791. C        and  CHICO  has set RCOND .EQ. 0.0
  19792. C        or  CHIFA  has set  INFO .NE. 0 .
  19793. C
  19794. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  19795. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  19796. C***ROUTINES CALLED  CAXPY, CCOPY, CDOTC, CSWAP
  19797. C***REVISION HISTORY  (YYMMDD)
  19798. C   780814  DATE WRITTEN
  19799. C   890531  Changed all specific intrinsics to generic.  (WRB)
  19800. C   890831  Modified array declarations.  (WRB)
  19801. C   891107  Modified routine equivalence list.  (WRB)
  19802. C   891107  REVISION DATE from Version 3.2
  19803. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  19804. C   900326  Removed duplicate information from DESCRIPTION section.
  19805. C           (WRB)
  19806. C   920501  Reformatted the REFERENCES section.  (WRB)
  19807. C***END PROLOGUE  CHIDI
  19808.       INTEGER LDA,N,JOB
  19809.       COMPLEX A(LDA,*),WORK(*)
  19810.       REAL DET(2)
  19811.       INTEGER KPVT(*),INERT(3)
  19812. C
  19813.       COMPLEX AKKP1,CDOTC,TEMP
  19814.       REAL TEN,D,T,AK,AKP1
  19815.       INTEGER J,JB,K,KM1,KS,KSTEP
  19816.       LOGICAL NOINV,NODET,NOERT
  19817. C***FIRST EXECUTABLE STATEMENT  CHIDI
  19818.       NOINV = MOD(JOB,10) .EQ. 0
  19819.       NODET = MOD(JOB,100)/10 .EQ. 0
  19820.       NOERT = MOD(JOB,1000)/100 .EQ. 0
  19821. C
  19822.       IF (NODET .AND. NOERT) GO TO 140
  19823.          IF (NOERT) GO TO 10
  19824.             INERT(1) = 0
  19825.             INERT(2) = 0
  19826.             INERT(3) = 0
  19827.    10    CONTINUE
  19828.          IF (NODET) GO TO 20
  19829.             DET(1) = 1.0E0
  19830.             DET(2) = 0.0E0
  19831.             TEN = 10.0E0
  19832.    20    CONTINUE
  19833.          T = 0.0E0
  19834.          DO 130 K = 1, N
  19835.             D = REAL(A(K,K))
  19836. C
  19837. C           CHECK IF 1 BY 1
  19838. C
  19839.             IF (KPVT(K) .GT. 0) GO TO 50
  19840. C
  19841. C              2 BY 2 BLOCK
  19842. C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S)
  19843. C                      (S  C)
  19844. C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
  19845. C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
  19846. C
  19847.                IF (T .NE. 0.0E0) GO TO 30
  19848.                   T = ABS(A(K,K+1))
  19849.                   D = (D/T)*REAL(A(K+1,K+1)) - T
  19850.                GO TO 40
  19851.    30          CONTINUE
  19852.                   D = T
  19853.                   T = 0.0E0
  19854.    40          CONTINUE
  19855.    50       CONTINUE
  19856. C
  19857.             IF (NOERT) GO TO 60
  19858.                IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1
  19859.                IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1
  19860.                IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1
  19861.    60       CONTINUE
  19862. C
  19863.             IF (NODET) GO TO 120
  19864.                DET(1) = D*DET(1)
  19865.                IF (DET(1) .EQ. 0.0E0) GO TO 110
  19866.    70             IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80
  19867.                      DET(1) = TEN*DET(1)
  19868.                      DET(2) = DET(2) - 1.0E0
  19869.                   GO TO 70
  19870.    80             CONTINUE
  19871.    90             IF (ABS(DET(1)) .LT. TEN) GO TO 100
  19872.                      DET(1) = DET(1)/TEN
  19873.                      DET(2) = DET(2) + 1.0E0
  19874.                   GO TO 90
  19875.   100             CONTINUE
  19876.   110          CONTINUE
  19877.   120       CONTINUE
  19878.   130    CONTINUE
  19879.   140 CONTINUE
  19880. C
  19881. C     COMPUTE INVERSE(A)
  19882. C
  19883.       IF (NOINV) GO TO 270
  19884.          K = 1
  19885.   150    IF (K .GT. N) GO TO 260
  19886.             KM1 = K - 1
  19887.             IF (KPVT(K) .LT. 0) GO TO 180
  19888. C
  19889. C              1 BY 1
  19890. C
  19891.                A(K,K) = CMPLX(1.0E0/REAL(A(K,K)),0.0E0)
  19892.                IF (KM1 .LT. 1) GO TO 170
  19893.                   CALL CCOPY(KM1,A(1,K),1,WORK,1)
  19894.                   DO 160 J = 1, KM1
  19895.                      A(J,K) = CDOTC(J,A(1,J),1,WORK,1)
  19896.                      CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  19897.   160             CONTINUE
  19898.                   A(K,K) = A(K,K)
  19899.      1                     + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)),
  19900.      2                             0.0E0)
  19901.   170          CONTINUE
  19902.                KSTEP = 1
  19903.             GO TO 220
  19904.   180       CONTINUE
  19905. C
  19906. C              2 BY 2
  19907. C
  19908.                T = ABS(A(K,K+1))
  19909.                AK = REAL(A(K,K))/T
  19910.                AKP1 = REAL(A(K+1,K+1))/T
  19911.                AKKP1 = A(K,K+1)/T
  19912.                D = T*(AK*AKP1 - 1.0E0)
  19913.                A(K,K) = CMPLX(AKP1/D,0.0E0)
  19914.                A(K+1,K+1) = CMPLX(AK/D,0.0E0)
  19915.                A(K,K+1) = -AKKP1/D
  19916.                IF (KM1 .LT. 1) GO TO 210
  19917.                   CALL CCOPY(KM1,A(1,K+1),1,WORK,1)
  19918.                   DO 190 J = 1, KM1
  19919.                      A(J,K+1) = CDOTC(J,A(1,J),1,WORK,1)
  19920.                      CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1)
  19921.   190             CONTINUE
  19922.                   A(K+1,K+1) = A(K+1,K+1)
  19923.      1                         + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K+1),
  19924.      2                                            1)),0.0E0)
  19925.                   A(K,K+1) = A(K,K+1) + CDOTC(KM1,A(1,K),1,A(1,K+1),1)
  19926.                   CALL CCOPY(KM1,A(1,K),1,WORK,1)
  19927.                   DO 200 J = 1, KM1
  19928.                      A(J,K) = CDOTC(J,A(1,J),1,WORK,1)
  19929.                      CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  19930.   200             CONTINUE
  19931.                   A(K,K) = A(K,K)
  19932.      1                     + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)),
  19933.      2                             0.0E0)
  19934.   210          CONTINUE
  19935.                KSTEP = 2
  19936.   220       CONTINUE
  19937. C
  19938. C           SWAP
  19939. C
  19940.             KS = ABS(KPVT(K))
  19941.             IF (KS .EQ. K) GO TO 250
  19942.                CALL CSWAP(KS,A(1,KS),1,A(1,K),1)
  19943.                DO 230 JB = KS, K
  19944.                   J = K + KS - JB
  19945.                   TEMP = CONJG(A(J,K))
  19946.                   A(J,K) = CONJG(A(KS,J))
  19947.                   A(KS,J) = TEMP
  19948.   230          CONTINUE
  19949.                IF (KSTEP .EQ. 1) GO TO 240
  19950.                   TEMP = A(KS,K+1)
  19951.                   A(KS,K+1) = A(K,K+1)
  19952.                   A(K,K+1) = TEMP
  19953.   240          CONTINUE
  19954.   250       CONTINUE
  19955.             K = K + KSTEP
  19956.          GO TO 150
  19957.   260    CONTINUE
  19958.   270 CONTINUE
  19959.       RETURN
  19960.       END
  19961. *DECK CHIEV
  19962.       SUBROUTINE CHIEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO)
  19963. C***BEGIN PROLOGUE  CHIEV
  19964. C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
  19965. C            of a complex Hermitian matrix.
  19966. C***LIBRARY   SLATEC
  19967. C***CATEGORY  D4A3
  19968. C***TYPE      COMPLEX (SSIEV-S, CHIEV-C)
  19969. C***KEYWORDS  COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX,
  19970. C             SYMMETRIC
  19971. C***AUTHOR  Kahaner, D. K., (NBS)
  19972. C           Moler, C. B., (U. of New Mexico)
  19973. C           Stewart, G. W., (U. of Maryland)
  19974. C***DESCRIPTION
  19975. C
  19976. C     David Kahaner, Cleve Moler, G. W. Stewart,
  19977. C       N.B.S.         U.N.M.      N.B.S./U.MD.
  19978. C
  19979. C     Abstract
  19980. C      CHIEV computes the eigenvalues and, optionally,
  19981. C      the eigenvectors of a complex Hermitian matrix.
  19982. C
  19983. C     Call Sequence Parameters-
  19984. C       (the values of parameters marked with * (star) will be changed
  19985. C         by CHIEV.)
  19986. C
  19987. C        A*      COMPLEX(LDA,N)
  19988. C                complex Hermitian input matrix.
  19989. C                Only the upper triangle of A need be
  19990. C                filled in.  Elements on diagonal must be real.
  19991. C
  19992. C        LDA     INTEGER
  19993. C                set by the user to
  19994. C                the leading dimension of the complex array A.
  19995. C
  19996. C        N       INTEGER
  19997. C                set by the user to
  19998. C                the order of the matrices A and V, and
  19999. C                the number of elements in E.
  20000. C
  20001. C        E*      REAL(N)
  20002. C                on return from CHIEV E contains the eigenvalues of A.
  20003. C                See also INFO below.
  20004. C
  20005. C        V*      COMPLEX(LDV,N)
  20006. C                on return from CHIEV if the user has set JOB
  20007. C                = 0        V is not referenced.
  20008. C                = nonzero  the N eigenvectors of A are stored in the
  20009. C                first N columns of V.  See also INFO below.
  20010. C
  20011. C        LDV     INTEGER
  20012. C                set by the user to
  20013. C                the leading dimension of the array V if JOB is also
  20014. C                set nonzero.  In that case N must be .LE. LDV.
  20015. C                If JOB is set to zero LDV is not referenced.
  20016. C
  20017. C        WORK*   REAL(4N)
  20018. C                temporary storage vector.  Contents changed by CHIEV.
  20019. C
  20020. C        JOB     INTEGER
  20021. C                set by the user to
  20022. C                = 0        eigenvalues only to be calculated by CHIEV.
  20023. C                           Neither V nor LDV are referenced.
  20024. C                = nonzero  eigenvalues and vectors to be calculated.
  20025. C                           In this case A and V must be distinct arrays
  20026. C                           also if LDA .GT. LDV CHIEV changes all the
  20027. C                           elements of A thru column N.  If LDA < LDV
  20028. C                           CHIEV changes all the elements of V through
  20029. C                           column N.  If LDA = LDV only A(I,J) and V(I,
  20030. C                           J) for I,J = 1,...,N are changed by CHIEV.
  20031. C
  20032. C        INFO*   INTEGER
  20033. C                on return from CHIEV the value of INFO is
  20034. C                = 0  normal return, calculation successful.
  20035. C                = K  if the eigenvalue iteration fails to converge,
  20036. C                     eigenvalues (and eigenvectors if requested)
  20037. C                     1 through K-1 are correct.
  20038. C
  20039. C      Error Messages
  20040. C           No. 1  recoverable  N is greater than LDA
  20041. C           No. 2  recoverable  N is less than one.
  20042. C           No. 3  recoverable  JOB is nonzero and N is greater than LDV
  20043. C           No. 4  warning      LDA > LDV,  elements of A other than the
  20044. C                               N by N input elements have been changed
  20045. C           No. 5  warning      LDA < LDV,  elements of V other than the
  20046. C                               N by N output elements have been changed
  20047. C           No. 6  recoverable  nonreal element on diagonal of A.
  20048. C
  20049. C***REFERENCES  (NONE)
  20050. C***ROUTINES CALLED  HTRIBK, HTRIDI, IMTQL2, SCOPY, SCOPYM, TQLRAT,
  20051. C                    XERMSG
  20052. C***REVISION HISTORY  (YYMMDD)
  20053. C   800808  DATE WRITTEN
  20054. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20055. C   890531  REVISION DATE from Version 3.2
  20056. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20057. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  20058. C***END PROLOGUE  CHIEV
  20059.       INTEGER I,INFO,J,JOB,K,L,LDA,LDV,M,MDIM,N
  20060.       REAL A(*),E(*),WORK(*),V(*)
  20061. C***FIRST EXECUTABLE STATEMENT  CHIEV
  20062.       IF (N .GT. LDA) CALL XERMSG ('SLATEC', 'CHIEV', 'N .GT. LDA.', 1,
  20063.      +   1)
  20064.       IF(N .GT. LDA) RETURN
  20065.       IF (N .LT. 1) CALL XERMSG ('SLATEC', 'CHIEV', 'N .LT. 1', 2, 1)
  20066.       IF(N .LT. 1) RETURN
  20067.       IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35
  20068.       MDIM = 2 * LDA
  20069.       IF(JOB .EQ. 0) GO TO 5
  20070.       IF (N .GT. LDV) CALL XERMSG ('SLATEC', 'CHIEV',
  20071.      +   'JOB .NE. 0 AND N .GT. LDV.', 3, 1)
  20072.       IF(N .GT. LDV) RETURN
  20073.       IF(N .EQ. 1) GO TO 35
  20074. C
  20075. C       REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0
  20076. C
  20077.       MDIM = MIN(MDIM,2 * LDV)
  20078.       IF (LDA .LT. LDV) CALL XERMSG ('SLATEC', 'CHIEV',
  20079.      +   'LDA.LT.LDV,  ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' //
  20080.      +   'ELEMENTS HAVE BEEN CHANGED.', 5, 0)
  20081.       IF(LDA.LE.LDV) GO TO 5
  20082.       CALL XERMSG ('SLATEC', 'CHIEV',
  20083.      +   'LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' //
  20084.      +   'ELEMENTS HAVE BEEN CHANGED.', 4, 0)
  20085.       L = N - 1
  20086.       DO 4 J=1,L
  20087.          M = 1+J*2*LDV
  20088.          K = 1+J*2*LDA
  20089.          CALL SCOPY(2*N,A(K),1,A(M),1)
  20090.     4 CONTINUE
  20091.     5 CONTINUE
  20092. C
  20093. C     FILL IN LOWER TRIANGLE OF A, COLUMN BY COLUMN.
  20094. C
  20095.       DO 6 J = 1,N
  20096.        K = (J-1)*(MDIM+2)+1
  20097.        IF (A(K+1) .NE. 0.0) CALL XERMSG ('SLATEC', 'CHIEV',
  20098.      +    'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1)
  20099.       IF(A(K+1) .NE.0.0) RETURN
  20100.        CALL SCOPY(N-J+1,A(K),MDIM,A(K),2)
  20101.        CALL SCOPYM(N-J+1,A(K+1),MDIM,A(K+1),2)
  20102.     6 CONTINUE
  20103. C
  20104. C     SEPARATE REAL AND IMAGINARY PARTS
  20105. C
  20106.       DO 10 J = 1, N
  20107.        K = (J-1) * MDIM +1
  20108.        L = K + N
  20109.        CALL SCOPY(N,A(K+1),2,WORK(1),1)
  20110.        CALL SCOPY(N,A(K),2,A(K),1)
  20111.        CALL SCOPY(N,WORK(1),1,A(L),1)
  20112.    10 CONTINUE
  20113. C
  20114. C    REDUCE A TO TRIDIAGONAL MATRIX.
  20115. C
  20116.       CALL HTRIDI(MDIM,N,A(1),A(N+1),E,WORK(1),WORK(N+1),
  20117.      1            WORK(2*N+1))
  20118.       IF(JOB .NE. 0) GOTO 15
  20119. C
  20120. C     EIGENVALUES ONLY.
  20121. C
  20122.       CALL TQLRAT(N,E,WORK(N+1),INFO)
  20123.       RETURN
  20124. C
  20125. C     EIGENVALUES AND EIGENVECTORS.
  20126. C
  20127.    15 DO 17 J = 1,N
  20128.        K = (J-1) * MDIM + 1
  20129.        M = K + N - 1
  20130.        DO 16 I = K,M
  20131.    16   V(I) = 0.
  20132.        I = K + J - 1
  20133.        V(I) = 1.
  20134.    17 CONTINUE
  20135.       CALL IMTQL2(MDIM,N,E,WORK(1),V,INFO)
  20136.       IF(INFO .NE. 0) RETURN
  20137.       CALL HTRIBK(MDIM,N,A(1),A(N+1),WORK(2*N+1),N,V(1),V(N+1))
  20138. C
  20139. C    CONVERT EIGENVECTORS TO COMPLEX STORAGE.
  20140. C
  20141.       DO 20 J = 1,N
  20142.        K = (J-1) * MDIM + 1
  20143.        I = (J-1) * 2 * LDV + 1
  20144.        L = K + N
  20145.        CALL SCOPY(N,V(K),1,WORK(1),1)
  20146.        CALL SCOPY(N,V(L),1,V(I+1),2)
  20147.        CALL SCOPY(N,WORK(1),1,V(I),2)
  20148.    20 CONTINUE
  20149.       RETURN
  20150. C
  20151. C     TAKE CARE OF N=1 CASE.
  20152. C
  20153.    35 IF (A(2) .NE. 0.) CALL XERMSG ('SLATEC', 'CHIEV',
  20154.      +   'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1)
  20155.       IF(A(2) .NE. 0.) RETURN
  20156.       E(1) = A(1)
  20157.       INFO = 0
  20158.       IF(JOB .EQ. 0) RETURN
  20159.       V(1) = A(1)
  20160.       V(2) = 0.
  20161.       RETURN
  20162.       END
  20163. *DECK CHIFA
  20164.       SUBROUTINE CHIFA (A, LDA, N, KPVT, INFO)
  20165. C***BEGIN PROLOGUE  CHIFA
  20166. C***PURPOSE  Factor a complex Hermitian matrix by elimination
  20167. C            (symmetric pivoting).
  20168. C***LIBRARY   SLATEC (LINPACK)
  20169. C***CATEGORY  D2D1A
  20170. C***TYPE      COMPLEX (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C)
  20171. C***KEYWORDS  HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION
  20172. C***AUTHOR  Bunch, J., (UCSD)
  20173. C***DESCRIPTION
  20174. C
  20175. C     CHIFA factors a complex Hermitian matrix by elimination
  20176. C     with symmetric pivoting.
  20177. C
  20178. C     To solve  A*X = B , follow CHIFA by CHISL.
  20179. C     To compute  INVERSE(A)*C , follow CHIFA by CHISL.
  20180. C     To compute  DETERMINANT(A) , follow CHIFA by CHIDI.
  20181. C     To compute  INERTIA(A) , follow CHIFA by CHIDI.
  20182. C     To compute  INVERSE(A) , follow CHIFA by CHIDI.
  20183. C
  20184. C     On Entry
  20185. C
  20186. C        A       COMPLEX(LDA,N)
  20187. C                the Hermitian matrix to be factored.
  20188. C                Only the diagonal and upper triangle are used.
  20189. C
  20190. C        LDA     INTEGER
  20191. C                the leading dimension of the array  A .
  20192. C
  20193. C        N       INTEGER
  20194. C                the order of the matrix  A .
  20195. C
  20196. C     On Return
  20197. C
  20198. C        A       a block diagonal matrix and the multipliers which
  20199. C                were used to obtain it.
  20200. C                The factorization can be written  A = U*D*CTRANS(U)
  20201. C                where  U  is a product of permutation and unit
  20202. C                upper triangular matrices , CTRANS(U) is the
  20203. C                conjugate transpose of  U , and  D  is block diagonal
  20204. C                with 1 by 1 and 2 by 2 blocks.
  20205. C
  20206. C        KVPT    INTEGER(N)
  20207. C                an integer vector of pivot indices.
  20208. C
  20209. C        INFO    INTEGER
  20210. C                = 0  normal value.
  20211. C                = K  if the K-th pivot block is singular.  This is
  20212. C                     not an error condition for this subroutine,
  20213. C                     but it does indicate that CHISL or CHIDI may
  20214. C                     divide by zero if called.
  20215. C
  20216. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  20217. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  20218. C***ROUTINES CALLED  CAXPY, CSWAP, ICAMAX
  20219. C***REVISION HISTORY  (YYMMDD)
  20220. C   780814  DATE WRITTEN
  20221. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20222. C   890831  Modified array declarations.  (WRB)
  20223. C   891107  Modified routine equivalence list.  (WRB)
  20224. C   891107  REVISION DATE from Version 3.2
  20225. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20226. C   900326  Removed duplicate information from DESCRIPTION section.
  20227. C           (WRB)
  20228. C   920501  Reformatted the REFERENCES section.  (WRB)
  20229. C***END PROLOGUE  CHIFA
  20230.       INTEGER LDA,N,KPVT(*),INFO
  20231.       COMPLEX A(LDA,*)
  20232. C
  20233.       COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
  20234.       REAL ABSAKK,ALPHA,COLMAX,ROWMAX
  20235.       INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ICAMAX
  20236.       LOGICAL SWAP
  20237.       COMPLEX ZDUM
  20238.       REAL CABS1
  20239.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  20240. C***FIRST EXECUTABLE STATEMENT  CHIFA
  20241. C
  20242. C     INITIALIZE
  20243. C
  20244. C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
  20245. C
  20246.       ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
  20247. C
  20248.       INFO = 0
  20249. C
  20250. C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
  20251. C
  20252.       K = N
  20253.    10 CONTINUE
  20254. C
  20255. C        LEAVE THE LOOP IF K=0 OR K=1.
  20256. C
  20257.          IF (K .EQ. 0) GO TO 200
  20258.          IF (K .GT. 1) GO TO 20
  20259.             KPVT(1) = 1
  20260.             IF (CABS1(A(1,1)) .EQ. 0.0E0) INFO = 1
  20261.             GO TO 200
  20262.    20    CONTINUE
  20263. C
  20264. C        THIS SECTION OF CODE DETERMINES THE KIND OF
  20265. C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
  20266. C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
  20267. C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
  20268. C        REQUIRED.
  20269. C
  20270.          KM1 = K - 1
  20271.          ABSAKK = CABS1(A(K,K))
  20272. C
  20273. C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
  20274. C        COLUMN K.
  20275. C
  20276.          IMAX = ICAMAX(K-1,A(1,K),1)
  20277.          COLMAX = CABS1(A(IMAX,K))
  20278.          IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
  20279.             KSTEP = 1
  20280.             SWAP = .FALSE.
  20281.          GO TO 90
  20282.    30    CONTINUE
  20283. C
  20284. C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
  20285. C           ROW IMAX.
  20286. C
  20287.             ROWMAX = 0.0E0
  20288.             IMAXP1 = IMAX + 1
  20289.             DO 40 J = IMAXP1, K
  20290.                ROWMAX = MAX(ROWMAX,CABS1(A(IMAX,J)))
  20291.    40       CONTINUE
  20292.             IF (IMAX .EQ. 1) GO TO 50
  20293.                JMAX = ICAMAX(IMAX-1,A(1,IMAX),1)
  20294.                ROWMAX = MAX(ROWMAX,CABS1(A(JMAX,IMAX)))
  20295.    50       CONTINUE
  20296.             IF (CABS1(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60
  20297.                KSTEP = 1
  20298.                SWAP = .TRUE.
  20299.             GO TO 80
  20300.    60       CONTINUE
  20301.             IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
  20302.                KSTEP = 1
  20303.                SWAP = .FALSE.
  20304.             GO TO 80
  20305.    70       CONTINUE
  20306.                KSTEP = 2
  20307.                SWAP = IMAX .NE. KM1
  20308.    80       CONTINUE
  20309.    90    CONTINUE
  20310.          IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
  20311. C
  20312. C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
  20313. C
  20314.             KPVT(K) = K
  20315.             INFO = K
  20316.          GO TO 190
  20317.   100    CONTINUE
  20318.          IF (KSTEP .EQ. 2) GO TO 140
  20319. C
  20320. C           1 X 1 PIVOT BLOCK.
  20321. C
  20322.             IF (.NOT.SWAP) GO TO 120
  20323. C
  20324. C              PERFORM AN INTERCHANGE.
  20325. C
  20326.                CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K),1)
  20327.                DO 110 JJ = IMAX, K
  20328.                   J = K + IMAX - JJ
  20329.                   T = CONJG(A(J,K))
  20330.                   A(J,K) = CONJG(A(IMAX,J))
  20331.                   A(IMAX,J) = T
  20332.   110          CONTINUE
  20333.   120       CONTINUE
  20334. C
  20335. C           PERFORM THE ELIMINATION.
  20336. C
  20337.             DO 130 JJ = 1, KM1
  20338.                J = K - JJ
  20339.                MULK = -A(J,K)/A(K,K)
  20340.                T = CONJG(MULK)
  20341.                CALL CAXPY(J,T,A(1,K),1,A(1,J),1)
  20342.                A(J,J) = CMPLX(REAL(A(J,J)),0.0E0)
  20343.                A(J,K) = MULK
  20344.   130       CONTINUE
  20345. C
  20346. C           SET THE PIVOT ARRAY.
  20347. C
  20348.             KPVT(K) = K
  20349.             IF (SWAP) KPVT(K) = IMAX
  20350.          GO TO 190
  20351.   140    CONTINUE
  20352. C
  20353. C           2 X 2 PIVOT BLOCK.
  20354. C
  20355.             IF (.NOT.SWAP) GO TO 160
  20356. C
  20357. C              PERFORM AN INTERCHANGE.
  20358. C
  20359.                CALL CSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1)
  20360.                DO 150 JJ = IMAX, KM1
  20361.                   J = KM1 + IMAX - JJ
  20362.                   T = CONJG(A(J,K-1))
  20363.                   A(J,K-1) = CONJG(A(IMAX,J))
  20364.                   A(IMAX,J) = T
  20365.   150          CONTINUE
  20366.                T = A(K-1,K)
  20367.                A(K-1,K) = A(IMAX,K)
  20368.                A(IMAX,K) = T
  20369.   160       CONTINUE
  20370. C
  20371. C           PERFORM THE ELIMINATION.
  20372. C
  20373.             KM2 = K - 2
  20374.             IF (KM2 .EQ. 0) GO TO 180
  20375.                AK = A(K,K)/A(K-1,K)
  20376.                AKM1 = A(K-1,K-1)/CONJG(A(K-1,K))
  20377.                DENOM = 1.0E0 - AK*AKM1
  20378.                DO 170 JJ = 1, KM2
  20379.                   J = KM1 - JJ
  20380.                   BK = A(J,K)/A(K-1,K)
  20381.                   BKM1 = A(J,K-1)/CONJG(A(K-1,K))
  20382.                   MULK = (AKM1*BK - BKM1)/DENOM
  20383.                   MULKM1 = (AK*BKM1 - BK)/DENOM
  20384.                   T = CONJG(MULK)
  20385.                   CALL CAXPY(J,T,A(1,K),1,A(1,J),1)
  20386.                   T = CONJG(MULKM1)
  20387.                   CALL CAXPY(J,T,A(1,K-1),1,A(1,J),1)
  20388.                   A(J,K) = MULK
  20389.                   A(J,K-1) = MULKM1
  20390.                   A(J,J) = CMPLX(REAL(A(J,J)),0.0E0)
  20391.   170          CONTINUE
  20392.   180       CONTINUE
  20393. C
  20394. C           SET THE PIVOT ARRAY.
  20395. C
  20396.             KPVT(K) = 1 - K
  20397.             IF (SWAP) KPVT(K) = -IMAX
  20398.             KPVT(K-1) = KPVT(K)
  20399.   190    CONTINUE
  20400.          K = K - KSTEP
  20401.       GO TO 10
  20402.   200 CONTINUE
  20403.       RETURN
  20404.       END
  20405. *DECK CHISL
  20406.       SUBROUTINE CHISL (A, LDA, N, KPVT, B)
  20407. C***BEGIN PROLOGUE  CHISL
  20408. C***PURPOSE  Solve the complex Hermitian system using factors obtained
  20409. C            from CHIFA.
  20410. C***LIBRARY   SLATEC (LINPACK)
  20411. C***CATEGORY  D2D1A
  20412. C***TYPE      COMPLEX (SSISL-S, DSISL-D, CHISL-C, CSISL-C)
  20413. C***KEYWORDS  HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
  20414. C***AUTHOR  Bunch, J., (UCSD)
  20415. C***DESCRIPTION
  20416. C
  20417. C     CHISL solves the complex Hermitian system
  20418. C     A * X = B
  20419. C     using the factors computed by CHIFA.
  20420. C
  20421. C     On Entry
  20422. C
  20423. C        A       COMPLEX(LDA,N)
  20424. C                the output from CHIFA.
  20425. C
  20426. C        LDA     INTEGER
  20427. C                the leading dimension of the array  A .
  20428. C
  20429. C        N       INTEGER
  20430. C                the order of the matrix  A .
  20431. C
  20432. C        KVPT    INTEGER(N)
  20433. C                the pivot vector from CHIFA.
  20434. C
  20435. C        B       COMPLEX(N)
  20436. C                the right hand side vector.
  20437. C
  20438. C     On Return
  20439. C
  20440. C        B       the solution vector  X .
  20441. C
  20442. C     Error Condition
  20443. C
  20444. C        A division by zero may occur if  CHICO  has set RCOND .EQ. 0.0
  20445. C        or  CHIFA  has set INFO .NE. 0  .
  20446. C
  20447. C     To compute  INVERSE(A) * C  where  C  is a matrix
  20448. C     with  P  columns
  20449. C           CALL CHIFA(A,LDA,N,KVPT,INFO)
  20450. C           IF (INFO .NE. 0) GO TO ...
  20451. C           DO 10 J = 1, p
  20452. C              CALL CHISL(A,LDA,N,KVPT,C(1,J))
  20453. C        10 CONTINUE
  20454. C
  20455. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  20456. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  20457. C***ROUTINES CALLED  CAXPY, CDOTC
  20458. C***REVISION HISTORY  (YYMMDD)
  20459. C   780814  DATE WRITTEN
  20460. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20461. C   890831  Modified array declarations.  (WRB)
  20462. C   891107  Modified routine equivalence list.  (WRB)
  20463. C   891107  REVISION DATE from Version 3.2
  20464. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20465. C   900326  Removed duplicate information from DESCRIPTION section.
  20466. C           (WRB)
  20467. C   920501  Reformatted the REFERENCES section.  (WRB)
  20468. C***END PROLOGUE  CHISL
  20469.       INTEGER LDA,N,KPVT(*)
  20470.       COMPLEX A(LDA,*),B(*)
  20471. C
  20472.       COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP
  20473.       INTEGER K,KP
  20474. C
  20475. C     LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND
  20476. C     D INVERSE TO B.
  20477. C
  20478. C***FIRST EXECUTABLE STATEMENT  CHISL
  20479.       K = N
  20480.    10 IF (K .EQ. 0) GO TO 80
  20481.          IF (KPVT(K) .LT. 0) GO TO 40
  20482. C
  20483. C           1 X 1 PIVOT BLOCK.
  20484. C
  20485.             IF (K .EQ. 1) GO TO 30
  20486.                KP = KPVT(K)
  20487.                IF (KP .EQ. K) GO TO 20
  20488. C
  20489. C                 INTERCHANGE.
  20490. C
  20491.                   TEMP = B(K)
  20492.                   B(K) = B(KP)
  20493.                   B(KP) = TEMP
  20494.    20          CONTINUE
  20495. C
  20496. C              APPLY THE TRANSFORMATION.
  20497. C
  20498.                CALL CAXPY(K-1,B(K),A(1,K),1,B(1),1)
  20499.    30       CONTINUE
  20500. C
  20501. C           APPLY D INVERSE.
  20502. C
  20503.             B(K) = B(K)/A(K,K)
  20504.             K = K - 1
  20505.          GO TO 70
  20506.    40    CONTINUE
  20507. C
  20508. C           2 X 2 PIVOT BLOCK.
  20509. C
  20510.             IF (K .EQ. 2) GO TO 60
  20511.                KP = ABS(KPVT(K))
  20512.                IF (KP .EQ. K - 1) GO TO 50
  20513. C
  20514. C                 INTERCHANGE.
  20515. C
  20516.                   TEMP = B(K-1)
  20517.                   B(K-1) = B(KP)
  20518.                   B(KP) = TEMP
  20519.    50          CONTINUE
  20520. C
  20521. C              APPLY THE TRANSFORMATION.
  20522. C
  20523.                CALL CAXPY(K-2,B(K),A(1,K),1,B(1),1)
  20524.                CALL CAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1)
  20525.    60       CONTINUE
  20526. C
  20527. C           APPLY D INVERSE.
  20528. C
  20529.             AK = A(K,K)/CONJG(A(K-1,K))
  20530.             AKM1 = A(K-1,K-1)/A(K-1,K)
  20531.             BK = B(K)/CONJG(A(K-1,K))
  20532.             BKM1 = B(K-1)/A(K-1,K)
  20533.             DENOM = AK*AKM1 - 1.0E0
  20534.             B(K) = (AKM1*BK - BKM1)/DENOM
  20535.             B(K-1) = (AK*BKM1 - BK)/DENOM
  20536.             K = K - 2
  20537.    70    CONTINUE
  20538.       GO TO 10
  20539.    80 CONTINUE
  20540. C
  20541. C     LOOP FORWARD APPLYING THE TRANSFORMATIONS.
  20542. C
  20543.       K = 1
  20544.    90 IF (K .GT. N) GO TO 160
  20545.          IF (KPVT(K) .LT. 0) GO TO 120
  20546. C
  20547. C           1 X 1 PIVOT BLOCK.
  20548. C
  20549.             IF (K .EQ. 1) GO TO 110
  20550. C
  20551. C              APPLY THE TRANSFORMATION.
  20552. C
  20553.                B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1)
  20554.                KP = KPVT(K)
  20555.                IF (KP .EQ. K) GO TO 100
  20556. C
  20557. C                 INTERCHANGE.
  20558. C
  20559.                   TEMP = B(K)
  20560.                   B(K) = B(KP)
  20561.                   B(KP) = TEMP
  20562.   100          CONTINUE
  20563.   110       CONTINUE
  20564.             K = K + 1
  20565.          GO TO 150
  20566.   120    CONTINUE
  20567. C
  20568. C           2 X 2 PIVOT BLOCK.
  20569. C
  20570.             IF (K .EQ. 1) GO TO 140
  20571. C
  20572. C              APPLY THE TRANSFORMATION.
  20573. C
  20574.                B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1)
  20575.                B(K+1) = B(K+1) + CDOTC(K-1,A(1,K+1),1,B(1),1)
  20576.                KP = ABS(KPVT(K))
  20577.                IF (KP .EQ. K) GO TO 130
  20578. C
  20579. C                 INTERCHANGE.
  20580. C
  20581.                   TEMP = B(K)
  20582.                   B(K) = B(KP)
  20583.                   B(KP) = TEMP
  20584.   130          CONTINUE
  20585.   140       CONTINUE
  20586.             K = K + 2
  20587.   150    CONTINUE
  20588.       GO TO 90
  20589.   160 CONTINUE
  20590.       RETURN
  20591.       END
  20592. *DECK CHKDER
  20593.       SUBROUTINE CHKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE,
  20594.      +   ERR)
  20595. C***BEGIN PROLOGUE  CHKDER
  20596. C***PURPOSE  Check the gradients of M nonlinear functions in N
  20597. C            variables, evaluated at a point X, for consistency
  20598. C            with the functions themselves.
  20599. C***LIBRARY   SLATEC
  20600. C***CATEGORY  F3, G4C
  20601. C***TYPE      SINGLE PRECISION (CHKDER-S, DCKDER-D)
  20602. C***KEYWORDS  GRADIENTS, JACOBIAN, MINPACK, NONLINEAR
  20603. C***AUTHOR  Hiebert, K. L. (SNLA)
  20604. C***DESCRIPTION
  20605. C
  20606. C   This subroutine is a companion routine to SNLS1,SNLS1E,SNSQ,and
  20607. C   SNSQE which may be used to check the calculation of the Jacobian.
  20608. C
  20609. C     SUBROUTINE CHKDER
  20610. C
  20611. C     This subroutine checks the gradients of M nonlinear functions
  20612. C     in N variables, evaluated at a point X, for consistency with
  20613. C     the functions themselves. The user must call CKDER twice,
  20614. C     first with MODE = 1 and then with MODE = 2.
  20615. C
  20616. C     MODE = 1. On input, X must contain the point of evaluation.
  20617. C               On output, XP is set to a neighboring point.
  20618. C
  20619. C     MODE = 2. On input, FVEC must contain the functions and the
  20620. C                         rows of FJAC must contain the gradients
  20621. C                         of the respective functions each evaluated
  20622. C                         at X, and FVECP must contain the functions
  20623. C                         evaluated at XP.
  20624. C               On output, ERR contains measures of correctness of
  20625. C                          the respective gradients.
  20626. C
  20627. C     The subroutine does not perform reliably if cancellation or
  20628. C     rounding errors cause a severe loss of significance in the
  20629. C     evaluation of a function. Therefore, none of the components
  20630. C     of X should be unusually small (in particular, zero) or any
  20631. C     other value which may cause loss of significance.
  20632. C
  20633. C     The SUBROUTINE statement is
  20634. C
  20635. C       SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR)
  20636. C
  20637. C     where
  20638. C
  20639. C       M is a positive integer input variable set to the number
  20640. C         of functions.
  20641. C
  20642. C       N is a positive integer input variable set to the number
  20643. C         of variables.
  20644. C
  20645. C       X is an input array of length N.
  20646. C
  20647. C       FVEC is an array of length M. On input when MODE = 2,
  20648. C         FVEC must contain the functions evaluated at X.
  20649. C
  20650. C       FJAC is an M by N array. On input when MODE = 2,
  20651. C         the rows of FJAC must contain the gradients of
  20652. C         the respective functions evaluated at X.
  20653. C
  20654. C       LDFJAC is a positive integer input parameter not less than M
  20655. C         which specifies the leading dimension of the array FJAC.
  20656. C
  20657. C       XP is an array of length N. On output when MODE = 1,
  20658. C         XP is set to a neighboring point of X.
  20659. C
  20660. C       FVECP is an array of length M. On input when MODE = 2,
  20661. C         FVECP must contain the functions evaluated at XP.
  20662. C
  20663. C       MODE is an integer input variable set to 1 on the first call
  20664. C         and 2 on the second. Other values of MODE are equivalent
  20665. C         to MODE = 1.
  20666. C
  20667. C       ERR is an array of length M. On output when MODE = 2,
  20668. C         ERR contains measures of correctness of the respective
  20669. C         gradients. If there is no severe loss of significance,
  20670. C         then if ERR(I) is 1.0 the I-th gradient is correct,
  20671. C         while if ERR(I) is 0.0 the I-th gradient is incorrect.
  20672. C         For values of ERR between 0.0 and 1.0, the categorization
  20673. C         is less certain. In general, a value of ERR(I) greater
  20674. C         than 0.5 indicates that the I-th gradient is probably
  20675. C         correct, while a value of ERR(I) less than 0.5 indicates
  20676. C         that the I-th gradient is probably incorrect.
  20677. C
  20678. C***REFERENCES  M. J. D. Powell, A hybrid method for nonlinear equa-
  20679. C                 tions. In Numerical Methods for Nonlinear Algebraic
  20680. C                 Equations, P. Rabinowitz, Editor.  Gordon and Breach,
  20681. C                 1988.
  20682. C***ROUTINES CALLED  R1MACH
  20683. C***REVISION HISTORY  (YYMMDD)
  20684. C   800301  DATE WRITTEN
  20685. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20686. C   890831  Modified array declarations.  (WRB)
  20687. C   890831  REVISION DATE from Version 3.2
  20688. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20689. C   900326  Removed duplicate information from DESCRIPTION section.
  20690. C           (WRB)
  20691. C   920501  Reformatted the REFERENCES section.  (WRB)
  20692. C***END PROLOGUE  CHKDER
  20693.       INTEGER M,N,LDFJAC,MODE
  20694.       REAL X(*),FVEC(*),FJAC(LDFJAC,*),XP(*),FVECP(*),ERR(*)
  20695.       INTEGER I,J
  20696.       REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO
  20697.       REAL R1MACH
  20698.       SAVE FACTOR, ONE, ZERO
  20699. C
  20700.       DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
  20701. C***FIRST EXECUTABLE STATEMENT  CHKDER
  20702.       EPSMCH = R1MACH(4)
  20703. C
  20704.       EPS = SQRT(EPSMCH)
  20705. C
  20706.       IF (MODE .EQ. 2) GO TO 20
  20707. C
  20708. C        MODE = 1.
  20709. C
  20710.          DO 10 J = 1, N
  20711.             TEMP = EPS*ABS(X(J))
  20712.             IF (TEMP .EQ. ZERO) TEMP = EPS
  20713.             XP(J) = X(J) + TEMP
  20714.    10       CONTINUE
  20715.          GO TO 70
  20716.    20 CONTINUE
  20717. C
  20718. C        MODE = 2.
  20719. C
  20720.          EPSF = FACTOR*EPSMCH
  20721.          EPSLOG = LOG10(EPS)
  20722.          DO 30 I = 1, M
  20723.             ERR(I) = ZERO
  20724.    30       CONTINUE
  20725.          DO 50 J = 1, N
  20726.             TEMP = ABS(X(J))
  20727.             IF (TEMP .EQ. ZERO) TEMP = ONE
  20728.             DO 40 I = 1, M
  20729.                ERR(I) = ERR(I) + TEMP*FJAC(I,J)
  20730.    40          CONTINUE
  20731.    50       CONTINUE
  20732.          DO 60 I = 1, M
  20733.             TEMP = ONE
  20734.             IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO
  20735.      1          .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I)))
  20736.      2         TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I))
  20737.      3                /(ABS(FVEC(I)) + ABS(FVECP(I)))
  20738.             ERR(I) = ONE
  20739.             IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS)
  20740.      1         ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG
  20741.             IF (TEMP .GE. EPS) ERR(I) = ZERO
  20742.    60       CONTINUE
  20743.    70 CONTINUE
  20744. C
  20745.       RETURN
  20746. C
  20747. C     LAST CARD OF SUBROUTINE CHKDER.
  20748. C
  20749.       END
  20750. *DECK CHKPR4
  20751.       SUBROUTINE CHKPR4 (IORDER, A, B, M, MBDCND, C, D, N, NBDCND, COFX,
  20752.      +   IDMN, IERROR)
  20753. C***BEGIN PROLOGUE  CHKPR4
  20754. C***SUBSIDIARY
  20755. C***PURPOSE  Subsidiary to SEPX4
  20756. C***LIBRARY   SLATEC
  20757. C***TYPE      SINGLE PRECISION (CHKPR4-S)
  20758. C***AUTHOR  (UNKNOWN)
  20759. C***DESCRIPTION
  20760. C
  20761. C     This program checks the input parameters for errors.
  20762. C
  20763. C***SEE ALSO  SEPX4
  20764. C***ROUTINES CALLED  (NONE)
  20765. C***REVISION HISTORY  (YYMMDD)
  20766. C   801001  DATE WRITTEN
  20767. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20768. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20769. C   900402  Added TYPE section.  (WRB)
  20770. C***END PROLOGUE  CHKPR4
  20771.       EXTERNAL COFX
  20772. C***FIRST EXECUTABLE STATEMENT  CHKPR4
  20773.       IERROR = 1
  20774.       IF (A.GE.B .OR. C.GE.D) RETURN
  20775. C
  20776. C     CHECK BOUNDARY SWITCHES
  20777. C
  20778.       IERROR = 2
  20779.       IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN
  20780.       IERROR = 3
  20781.       IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN
  20782. C
  20783. C     CHECK FIRST DIMENSION IN CALLING ROUTINE
  20784. C
  20785.       IERROR = 5
  20786.       IF (IDMN .LT. 7) RETURN
  20787. C
  20788. C     CHECK M
  20789. C
  20790.       IERROR = 6
  20791.       IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN
  20792. C
  20793. C     CHECK N
  20794. C
  20795.       IERROR = 7
  20796.       IF (N .LT. 5) RETURN
  20797. C
  20798. C     CHECK IORDER
  20799. C
  20800.       IERROR = 8
  20801.       IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN
  20802. C
  20803. C     CHECK THAT EQUATION IS ELLIPTIC
  20804. C
  20805.       DLX = (B-A)/M
  20806.       DO  30 I=2,M
  20807.          XI = A+(I-1)*DLX
  20808.          CALL COFX (XI,AI,BI,CI)
  20809.       IF (AI.GT.0.0) GO TO 10
  20810.       IERROR=10
  20811.       RETURN
  20812.    10 CONTINUE
  20813.    30 CONTINUE
  20814. C
  20815. C     NO ERROR FOUND
  20816. C
  20817.       IERROR = 0
  20818.       RETURN
  20819.       END
  20820. *DECK CHKPRM
  20821.       SUBROUTINE CHKPRM (INTL, IORDER, A, B, M, MBDCND, C, D, N, NBDCND,
  20822.      +   COFX, COFY, IDMN, IERROR)
  20823. C***BEGIN PROLOGUE  CHKPRM
  20824. C***SUBSIDIARY
  20825. C***PURPOSE  Subsidiary to SEPELI
  20826. C***LIBRARY   SLATEC
  20827. C***TYPE      SINGLE PRECISION (CHKPRM-S)
  20828. C***AUTHOR  (UNKNOWN)
  20829. C***DESCRIPTION
  20830. C
  20831. C     This program checks the input parameters for errors.
  20832. C
  20833. C***SEE ALSO  SEPELI
  20834. C***ROUTINES CALLED  (NONE)
  20835. C***REVISION HISTORY  (YYMMDD)
  20836. C   801001  DATE WRITTEN
  20837. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20838. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20839. C   900402  Added TYPE section.  (WRB)
  20840. C***END PROLOGUE  CHKPRM
  20841. C
  20842.       EXTERNAL        COFX       ,COFY
  20843. C***FIRST EXECUTABLE STATEMENT  CHKPRM
  20844.       IERROR = 1
  20845.       IF (A.GE.B .OR. C.GE.D) RETURN
  20846. C
  20847. C     CHECK BOUNDARY SWITCHES
  20848. C
  20849.       IERROR = 2
  20850.       IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN
  20851.       IERROR = 3
  20852.       IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN
  20853. C
  20854. C     CHECK FIRST DIMENSION IN CALLING ROUTINE
  20855. C
  20856.       IERROR = 5
  20857.       IF (IDMN .LT. 7) RETURN
  20858. C
  20859. C     CHECK M
  20860. C
  20861.       IERROR = 6
  20862.       IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN
  20863. C
  20864. C     CHECK N
  20865. C
  20866.       IERROR = 7
  20867.       IF (N .LT. 5) RETURN
  20868. C
  20869. C     CHECK IORDER
  20870. C
  20871.       IERROR = 8
  20872.       IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN
  20873. C
  20874. C     CHECK INTL
  20875. C
  20876.       IERROR = 9
  20877.       IF (INTL.NE.0 .AND. INTL.NE.1) RETURN
  20878. C
  20879. C     CHECK THAT EQUATION IS ELLIPTIC
  20880. C
  20881.       DLX = (B-A)/M
  20882.       DLY = (D-C)/N
  20883.       DO  30 I=2,M
  20884.          XI = A+(I-1)*DLX
  20885.          CALL COFX (XI,AI,BI,CI)
  20886.          DO  20 J=2,N
  20887.             YJ = C+(J-1)*DLY
  20888.             CALL COFY (YJ,DJ,EJ,FJ)
  20889.             IF (AI*DJ .GT. 0.0) GO TO  10
  20890.             IERROR = 10
  20891.             RETURN
  20892.    10       CONTINUE
  20893.    20    CONTINUE
  20894.    30 CONTINUE
  20895. C
  20896. C     NO ERROR FOUND
  20897. C
  20898.       IERROR = 0
  20899.       RETURN
  20900.       END
  20901. *DECK CHKSN4
  20902.       SUBROUTINE CHKSN4 (MBDCND, NBDCND, ALPHA, BETA, COFX, SINGLR)
  20903. C***BEGIN PROLOGUE  CHKSN4
  20904. C***SUBSIDIARY
  20905. C***PURPOSE  Subsidiary to SEPX4
  20906. C***LIBRARY   SLATEC
  20907. C***TYPE      SINGLE PRECISION (CHKSN4-S)
  20908. C***AUTHOR  (UNKNOWN)
  20909. C***DESCRIPTION
  20910. C
  20911. C     This subroutine checks if the PDE SEPX4
  20912. C     must solve is a singular operator.
  20913. C
  20914. C***SEE ALSO  SEPX4
  20915. C***ROUTINES CALLED  (NONE)
  20916. C***COMMON BLOCKS    SPL4
  20917. C***REVISION HISTORY  (YYMMDD)
  20918. C   801001  DATE WRITTEN
  20919. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20920. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20921. C   900402  Added TYPE section.  (WRB)
  20922. C***END PROLOGUE  CHKSN4
  20923. C
  20924.       COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
  20925.      1                AIT        ,BIT        ,CIT        ,DIT        ,
  20926.      2                MIT        ,NIT        ,IS         ,MS         ,
  20927.      3                JS         ,NS         ,DLX        ,DLY        ,
  20928.      4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
  20929.       LOGICAL         SINGLR
  20930.       EXTERNAL COFX
  20931. C***FIRST EXECUTABLE STATEMENT  CHKSN4
  20932.       SINGLR = .FALSE.
  20933. C
  20934. C     CHECK IF THE BOUNDARY CONDITIONS ARE
  20935. C     ENTIRELY PERIODIC AND/OR MIXED
  20936. C
  20937.       IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR.
  20938.      1    (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN
  20939. C
  20940. C     CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN
  20941. C
  20942.       IF (MBDCND .NE. 3) GO TO  10
  20943.       IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN
  20944.    10 CONTINUE
  20945. C
  20946. C     CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS
  20947. C     ARE ZERO
  20948. C
  20949.       DO  30 I=IS,MS
  20950.          XI = AIT+(I-1)*DLX
  20951.          CALL COFX (XI,AI,BI,CI)
  20952.          IF (CI .NE. 0.0) RETURN
  20953.    30 CONTINUE
  20954. C
  20955. C     THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED
  20956. C
  20957.       SINGLR = .TRUE.
  20958.       RETURN
  20959.       END
  20960. *DECK CHKSNG
  20961.       SUBROUTINE CHKSNG (MBDCND, NBDCND, ALPHA, BETA, GAMA, XNU, COFX,
  20962.      +   COFY, SINGLR)
  20963. C***BEGIN PROLOGUE  CHKSNG
  20964. C***SUBSIDIARY
  20965. C***PURPOSE  Subsidiary to SEPELI
  20966. C***LIBRARY   SLATEC
  20967. C***TYPE      SINGLE PRECISION (CHKSNG-S)
  20968. C***AUTHOR  (UNKNOWN)
  20969. C***DESCRIPTION
  20970. C
  20971. C     This subroutine checks if the PDE SEPELI
  20972. C     must solve is a singular operator.
  20973. C
  20974. C***SEE ALSO  SEPELI
  20975. C***ROUTINES CALLED  (NONE)
  20976. C***COMMON BLOCKS    SPLPCM
  20977. C***REVISION HISTORY  (YYMMDD)
  20978. C   801001  DATE WRITTEN
  20979. C   890531  Changed all specific intrinsics to generic.  (WRB)
  20980. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  20981. C   900402  Added TYPE section.  (WRB)
  20982. C***END PROLOGUE  CHKSNG
  20983. C
  20984.       COMMON /SPLPCM/ KSWX       ,KSWY       ,K          ,L          ,
  20985.      1                AIT        ,BIT        ,CIT        ,DIT        ,
  20986.      2                MIT        ,NIT        ,IS         ,MS         ,
  20987.      3                JS         ,NS         ,DLX        ,DLY        ,
  20988.      4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
  20989.       LOGICAL         SINGLR
  20990. C***FIRST EXECUTABLE STATEMENT  CHKSNG
  20991.       SINGLR = .FALSE.
  20992. C
  20993. C     CHECK IF THE BOUNDARY CONDITIONS ARE
  20994. C     ENTIRELY PERIODIC AND/OR MIXED
  20995. C
  20996.       IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR.
  20997.      1    (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN
  20998. C
  20999. C     CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN
  21000. C
  21001.       IF (MBDCND .NE. 3) GO TO  10
  21002.       IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN
  21003.    10 IF (NBDCND .NE. 3) GO TO  20
  21004.       IF (GAMA.NE.0.0 .OR. XNU.NE.0.0) RETURN
  21005.    20 CONTINUE
  21006. C
  21007. C     CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS
  21008. C     ARE ZERO
  21009. C
  21010.       DO  30 I=IS,MS
  21011.          XI = AIT+(I-1)*DLX
  21012.          CALL COFX (XI,AI,BI,CI)
  21013.          IF (CI .NE. 0.0) RETURN
  21014.    30 CONTINUE
  21015.       DO  40 J=JS,NS
  21016.          YJ = CIT+(J-1)*DLY
  21017.          CALL COFY (YJ,DJ,EJ,FJ)
  21018.          IF (FJ .NE. 0.0) RETURN
  21019.    40 CONTINUE
  21020. C
  21021. C     THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED
  21022. C
  21023.       SINGLR = .TRUE.
  21024.       RETURN
  21025.       END
  21026. *DECK CHPCO
  21027.       SUBROUTINE CHPCO (AP, N, KPVT, RCOND, Z)
  21028. C***BEGIN PROLOGUE  CHPCO
  21029. C***PURPOSE  Factor a complex Hermitian matrix stored in packed form by
  21030. C            elimination with symmetric pivoting and estimate the
  21031. C            condition number of the matrix.
  21032. C***LIBRARY   SLATEC (LINPACK)
  21033. C***CATEGORY  D2D1A
  21034. C***TYPE      COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C)
  21035. C***KEYWORDS  CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK,
  21036. C             MATRIX FACTORIZATION, PACKED
  21037. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  21038. C***DESCRIPTION
  21039. C
  21040. C     CHPCO factors a complex Hermitian matrix stored in packed
  21041. C     form by elimination with symmetric pivoting and estimates
  21042. C     the condition of the matrix.
  21043. C
  21044. C     if  RCOND  is not needed, CHPFA is slightly faster.
  21045. C     To solve  A*X = B , follow CHPCO by CHPSL.
  21046. C     To compute  INVERSE(A)*C , follow CHPCO by CHPSL.
  21047. C     To compute  INVERSE(A) , follow CHPCO by CHPDI.
  21048. C     To compute  DETERMINANT(A) , follow CHPCO by CHPDI.
  21049. C     To compute  INERTIA(A), follow CHPCO by CHPDI.
  21050. C
  21051. C     On Entry
  21052. C
  21053. C        AP      COMPLEX (N*(N+1)/2)
  21054. C                the packed form of a Hermitian matrix  A .  The
  21055. C                columns of the upper triangle are stored sequentially
  21056. C                in a one-dimensional array of length  N*(N+1)/2 .
  21057. C                See comments below for details.
  21058. C
  21059. C        N       INTEGER
  21060. C                the order of the matrix  A .
  21061. C
  21062. C     Output
  21063. C
  21064. C        AP      a block diagonal matrix and the multipliers which
  21065. C                were used to obtain it stored in packed form.
  21066. C                The factorization can be written  A = U*D*CTRANS(U)
  21067. C                where  U  is a product of permutation and unit
  21068. C                upper triangular matrices , CTRANS(U) is the
  21069. C                conjugate transpose of  U , and  D  is block diagonal
  21070. C                with 1 by 1 and 2 by 2 blocks.
  21071. C
  21072. C        KVPT    INTEGER(N)
  21073. C                an integer vector of pivot indices.
  21074. C
  21075. C        RCOND   REAL
  21076. C                an estimate of the reciprocal condition of  A .
  21077. C                For the system  A*X = B , relative perturbations
  21078. C                in  A  and  B  of size  EPSILON  may cause
  21079. C                relative perturbations in  X  of size  EPSILON/RCOND .
  21080. C                If  RCOND  is so small that the logical expression
  21081. C                           1.0 + RCOND .EQ. 1.0
  21082. C                is true, then  A  may be singular to working
  21083. C                precision.  In particular,  RCOND  is zero  if
  21084. C                exact singularity is detected or the estimate
  21085. C                underflows.
  21086. C
  21087. C        Z       COMPLEX(N)
  21088. C                a work vector whose contents are usually unimportant.
  21089. C                If  A  is close to a singular matrix, then  Z  is
  21090. C                an approximate null vector in the sense that
  21091. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  21092. C
  21093. C     Packed Storage
  21094. C
  21095. C          The following program segment will pack the upper
  21096. C          triangle of a Hermitian matrix.
  21097. C
  21098. C                K = 0
  21099. C                DO 20 J = 1, N
  21100. C                   DO 10 I = 1, J
  21101. C                      K = K + 1
  21102. C                      AP(K) = A(I,J)
  21103. C             10    CONTINUE
  21104. C             20 CONTINUE
  21105. C
  21106. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  21107. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  21108. C***ROUTINES CALLED  CAXPY, CDOTC, CHPFA, CSSCAL, SCASUM
  21109. C***REVISION HISTORY  (YYMMDD)
  21110. C   780814  DATE WRITTEN
  21111. C   890531  Changed all specific intrinsics to generic.  (WRB)
  21112. C   890831  Modified array declarations.  (WRB)
  21113. C   891107  Modified routine equivalence list.  (WRB)
  21114. C   891107  REVISION DATE from Version 3.2
  21115. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  21116. C   900326  Removed duplicate information from DESCRIPTION section.
  21117. C           (WRB)
  21118. C   920501  Reformatted the REFERENCES section.  (WRB)
  21119. C***END PROLOGUE  CHPCO
  21120.       INTEGER N,KPVT(*)
  21121.       COMPLEX AP(*),Z(*)
  21122.       REAL RCOND
  21123. C
  21124.       COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T
  21125.       REAL ANORM,S,SCASUM,YNORM
  21126.       INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1
  21127.       INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS
  21128.       COMPLEX ZDUM,ZDUM2,CSIGN1
  21129.       REAL CABS1
  21130.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  21131.       CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2))
  21132. C
  21133. C     FIND NORM OF A USING ONLY UPPER HALF
  21134. C
  21135. C***FIRST EXECUTABLE STATEMENT  CHPCO
  21136.       J1 = 1
  21137.       DO 30 J = 1, N
  21138.          Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0)
  21139.          IJ = J1
  21140.          J1 = J1 + J
  21141.          JM1 = J - 1
  21142.          IF (JM1 .LT. 1) GO TO 20
  21143.          DO 10 I = 1, JM1
  21144.             Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0)
  21145.             IJ = IJ + 1
  21146.    10    CONTINUE
  21147.    20    CONTINUE
  21148.    30 CONTINUE
  21149.       ANORM = 0.0E0
  21150.       DO 40 J = 1, N
  21151.          ANORM = MAX(ANORM,REAL(Z(J)))
  21152.    40 CONTINUE
  21153. C
  21154. C     FACTOR
  21155. C
  21156.       CALL CHPFA(AP,N,KPVT,INFO)
  21157. C
  21158. C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  21159. C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
  21160. C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  21161. C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
  21162. C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  21163. C
  21164. C     SOLVE U*D*W = E
  21165. C
  21166.       EK = (1.0E0,0.0E0)
  21167.       DO 50 J = 1, N
  21168.          Z(J) = (0.0E0,0.0E0)
  21169.    50 CONTINUE
  21170.       K = N
  21171.       IK = (N*(N - 1))/2
  21172.    60 IF (K .EQ. 0) GO TO 120
  21173.          KK = IK + K
  21174.          IKM1 = IK - (K - 1)
  21175.          KS = 1
  21176.          IF (KPVT(K) .LT. 0) KS = 2
  21177.          KP = ABS(KPVT(K))
  21178.          KPS = K + 1 - KS
  21179.          IF (KP .EQ. KPS) GO TO 70
  21180.             T = Z(KPS)
  21181.             Z(KPS) = Z(KP)
  21182.             Z(KP) = T
  21183.    70    CONTINUE
  21184.          IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K))
  21185.          Z(K) = Z(K) + EK
  21186.          CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
  21187.          IF (KS .EQ. 1) GO TO 80
  21188.             IF (CABS1(Z(K-1)) .NE. 0.0E0) EK = CSIGN1(EK,Z(K-1))
  21189.             Z(K-1) = Z(K-1) + EK
  21190.             CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
  21191.    80    CONTINUE
  21192.          IF (KS .EQ. 2) GO TO 100
  21193.             IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 90
  21194.                S = CABS1(AP(KK))/CABS1(Z(K))
  21195.                CALL CSSCAL(N,S,Z,1)
  21196.                EK = CMPLX(S,0.0E0)*EK
  21197.    90       CONTINUE
  21198.             IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK)
  21199.             IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  21200.          GO TO 110
  21201.   100    CONTINUE
  21202.             KM1K = IK + K - 1
  21203.             KM1KM1 = IKM1 + K - 1
  21204.             AK = AP(KK)/CONJG(AP(KM1K))
  21205.             AKM1 = AP(KM1KM1)/AP(KM1K)
  21206.             BK = Z(K)/CONJG(AP(KM1K))
  21207.             BKM1 = Z(K-1)/AP(KM1K)
  21208.             DENOM = AK*AKM1 - 1.0E0
  21209.             Z(K) = (AKM1*BK - BKM1)/DENOM
  21210.             Z(K-1) = (AK*BKM1 - BK)/DENOM
  21211.   110    CONTINUE
  21212.          K = K - KS
  21213.          IK = IK - K
  21214.          IF (KS .EQ. 2) IK = IK - (K + 1)
  21215.       GO TO 60
  21216.   120 CONTINUE
  21217.       S = 1.0E0/SCASUM(N,Z,1)
  21218.       CALL CSSCAL(N,S,Z,1)
  21219. C
  21220. C     SOLVE CTRANS(U)*Y = W
  21221. C
  21222.       K = 1
  21223.       IK = 0
  21224.   130 IF (K .GT. N) GO TO 160
  21225.          KS = 1
  21226.          IF (KPVT(K) .LT. 0) KS = 2
  21227.          IF (K .EQ. 1) GO TO 150
  21228.             Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1)
  21229.             IKP1 = IK + K
  21230.             IF (KS .EQ. 2)
  21231.      1         Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1)
  21232.             KP = ABS(KPVT(K))
  21233.             IF (KP .EQ. K) GO TO 140
  21234.                T = Z(K)
  21235.                Z(K) = Z(KP)
  21236.                Z(KP) = T
  21237.   140       CONTINUE
  21238.   150    CONTINUE
  21239.          IK = IK + K
  21240.          IF (KS .EQ. 2) IK = IK + (K + 1)
  21241.          K = K + KS
  21242.       GO TO 130
  21243.   160 CONTINUE
  21244.       S = 1.0E0/SCASUM(N,Z,1)
  21245.       CALL CSSCAL(N,S,Z,1)
  21246. C
  21247.       YNORM = 1.0E0
  21248. C
  21249. C     SOLVE U*D*V = Y
  21250. C
  21251.       K = N
  21252.       IK = N*(N - 1)/2
  21253.   170 IF (K .EQ. 0) GO TO 230
  21254.          KK = IK + K
  21255.          IKM1 = IK - (K - 1)
  21256.          KS = 1
  21257.          IF (KPVT(K) .LT. 0) KS = 2
  21258.          IF (K .EQ. KS) GO TO 190
  21259.             KP = ABS(KPVT(K))
  21260.             KPS = K + 1 - KS
  21261.             IF (KP .EQ. KPS) GO TO 180
  21262.                T = Z(KPS)
  21263.                Z(KPS) = Z(KP)
  21264.                Z(KP) = T
  21265.   180       CONTINUE
  21266.             CALL CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
  21267.             IF (KS .EQ. 2) CALL CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
  21268.   190    CONTINUE
  21269.          IF (KS .EQ. 2) GO TO 210
  21270.             IF (CABS1(Z(K)) .LE. CABS1(AP(KK))) GO TO 200
  21271.                S = CABS1(AP(KK))/CABS1(Z(K))
  21272.                CALL CSSCAL(N,S,Z,1)
  21273.                YNORM = S*YNORM
  21274.   200       CONTINUE
  21275.             IF (CABS1(AP(KK)) .NE. 0.0E0) Z(K) = Z(K)/AP(KK)
  21276.             IF (CABS1(AP(KK)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
  21277.          GO TO 220
  21278.   210    CONTINUE
  21279.             KM1K = IK + K - 1
  21280.             KM1KM1 = IKM1 + K - 1
  21281.             AK = AP(KK)/CONJG(AP(KM1K))
  21282.             AKM1 = AP(KM1KM1)/AP(KM1K)
  21283.             BK = Z(K)/CONJG(AP(KM1K))
  21284.             BKM1 = Z(K-1)/AP(KM1K)
  21285.             DENOM = AK*AKM1 - 1.0E0
  21286.             Z(K) = (AKM1*BK - BKM1)/DENOM
  21287.             Z(K-1) = (AK*BKM1 - BK)/DENOM
  21288.   220    CONTINUE
  21289.          K = K - KS
  21290.          IK = IK - K
  21291.          IF (KS .EQ. 2) IK = IK - (K + 1)
  21292.       GO TO 170
  21293.   230 CONTINUE
  21294.       S = 1.0E0/SCASUM(N,Z,1)
  21295.       CALL CSSCAL(N,S,Z,1)
  21296.       YNORM = S*YNORM
  21297. C
  21298. C     SOLVE CTRANS(U)*Z = V
  21299. C
  21300.       K = 1
  21301.       IK = 0
  21302.   240 IF (K .GT. N) GO TO 270
  21303.          KS = 1
  21304.          IF (KPVT(K) .LT. 0) KS = 2
  21305.          IF (K .EQ. 1) GO TO 260
  21306.             Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1)
  21307.             IKP1 = IK + K
  21308.             IF (KS .EQ. 2)
  21309.      1         Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1)
  21310.             KP = ABS(KPVT(K))
  21311.             IF (KP .EQ. K) GO TO 250
  21312.                T = Z(K)
  21313.                Z(K) = Z(KP)
  21314.                Z(KP) = T
  21315.   250       CONTINUE
  21316.   260    CONTINUE
  21317.          IK = IK + K
  21318.          IF (KS .EQ. 2) IK = IK + (K + 1)
  21319.          K = K + KS
  21320.       GO TO 240
  21321.   270 CONTINUE
  21322. C     MAKE ZNORM = 1.0
  21323.       S = 1.0E0/SCASUM(N,Z,1)
  21324.       CALL CSSCAL(N,S,Z,1)
  21325.       YNORM = S*YNORM
  21326. C
  21327.       IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  21328.       IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  21329.       RETURN
  21330.       END
  21331. *DECK CHPDI
  21332.       SUBROUTINE CHPDI (AP, N, KPVT, DET, INERT, WORK, JOB)
  21333. C***BEGIN PROLOGUE  CHPDI
  21334. C***PURPOSE  Compute the determinant, inertia and inverse of a complex
  21335. C            Hermitian matrix stored in packed form using the factors
  21336. C            obtained from CHPFA.
  21337. C***LIBRARY   SLATEC (LINPACK)
  21338. C***CATEGORY  D2D1A, D3D1A
  21339. C***TYPE      COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, DSPDI-C)
  21340. C***KEYWORDS  DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK,
  21341. C             MATRIX, PACKED
  21342. C***AUTHOR  Bunch, J., (UCSD)
  21343. C***DESCRIPTION
  21344. C
  21345. C     CHPDI computes the determinant, inertia and inverse
  21346. C     of a complex Hermitian matrix using the factors from CHPFA,
  21347. C     where the matrix is stored in packed form.
  21348. C
  21349. C     On Entry
  21350. C
  21351. C        AP      COMPLEX (N*(N+1)/2)
  21352. C                the output from CHPFA.
  21353. C
  21354. C        N       INTEGER
  21355. C                the order of the matrix A.
  21356. C
  21357. C        KVPT    INTEGER(N)
  21358. C                the pivot vector from CHPFA.
  21359. C
  21360. C        WORK    COMPLEX(N)
  21361. C                work vector.  Contents ignored.
  21362. C
  21363. C        JOB     INTEGER
  21364. C                JOB has the decimal expansion  ABC  where
  21365. C                   if  C .NE. 0, the inverse is computed,
  21366. C                   if  B .NE. 0, the determinant is computed,
  21367. C                   if  A .NE. 0, the inertia is computed.
  21368. C
  21369. C                For example, JOB = 111  gives all three.
  21370. C
  21371. C     On Return
  21372. C
  21373. C        Variables not requested by JOB are not used.
  21374. C
  21375. C        AP     contains the upper triangle of the inverse of
  21376. C               the original matrix, stored in packed form.
  21377. C               The columns of the upper triangle are stored
  21378. C               sequentially in a one-dimensional array.
  21379. C
  21380. C        DET    REAL(2)
  21381. C               determinant of original matrix.
  21382. C               Determinant = DET(1) * 10.0**DET(2)
  21383. C               with 1.0 .LE. ABS(DET(1)) .LT. 10.0
  21384. C               or DET(1) = 0.0.
  21385. C
  21386. C        INERT  INTEGER(3)
  21387. C               the inertia of the original matrix.
  21388. C               INERT(1)  =  number of positive eigenvalues.
  21389. C               INERT(2)  =  number of negative eigenvalues.
  21390. C               INERT(3)  =  number of zero eigenvalues.
  21391. C
  21392. C     Error Condition
  21393. C
  21394. C        A division by zero will occur if the inverse is requested
  21395. C        and  CHPCO  has set RCOND .EQ. 0.0
  21396. C        or  CHPFA  has set  INFO .NE. 0 .
  21397. C
  21398. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  21399. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  21400. C***ROUTINES CALLED  CAXPY, CCOPY, CDOTC, CSWAP
  21401. C***REVISION HISTORY  (YYMMDD)
  21402. C   780814  DATE WRITTEN
  21403. C   890531  Changed all specific intrinsics to generic.  (WRB)
  21404. C   890831  Modified array declarations.  (WRB)
  21405. C   891107  Modified routine equivalence list.  (WRB)
  21406. C   891107  REVISION DATE from Version 3.2
  21407. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  21408. C   900326  Removed duplicate information from DESCRIPTION section.
  21409. C           (WRB)
  21410. C   920501  Reformatted the REFERENCES section.  (WRB)
  21411. C***END PROLOGUE  CHPDI
  21412.       INTEGER N,JOB
  21413.       COMPLEX AP(*),WORK(*)
  21414.       REAL DET(2)
  21415.       INTEGER KPVT(*),INERT(3)
  21416. C
  21417.       COMPLEX AKKP1,CDOTC,TEMP
  21418.       REAL TEN,D,T,AK,AKP1
  21419.       INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1
  21420.       INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP
  21421.       LOGICAL NOINV,NODET,NOERT
  21422. C***FIRST EXECUTABLE STATEMENT  CHPDI
  21423.       NOINV = MOD(JOB,10) .EQ. 0
  21424.       NODET = MOD(JOB,100)/10 .EQ. 0
  21425.       NOERT = MOD(JOB,1000)/100 .EQ. 0
  21426. C
  21427.       IF (NODET .AND. NOERT) GO TO 140
  21428.          IF (NOERT) GO TO 10
  21429.             INERT(1) = 0
  21430.             INERT(2) = 0
  21431.             INERT(3) = 0
  21432.    10    CONTINUE
  21433.          IF (NODET) GO TO 20
  21434.             DET(1) = 1.0E0
  21435.             DET(2) = 0.0E0
  21436.             TEN = 10.0E0
  21437.    20    CONTINUE
  21438.          T = 0.0E0
  21439.          IK = 0
  21440.          DO 130 K = 1, N
  21441.             KK = IK + K
  21442.             D = REAL(AP(KK))
  21443. C
  21444. C           CHECK IF 1 BY 1
  21445. C
  21446.             IF (KPVT(K) .GT. 0) GO TO 50
  21447. C
  21448. C              2 BY 2 BLOCK
  21449. C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S)
  21450. C                      (S  C)
  21451. C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
  21452. C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
  21453. C
  21454.                IF (T .NE. 0.0E0) GO TO 30
  21455.                   IKP1 = IK + K
  21456.                   KKP1 = IKP1 + K
  21457.                   T = ABS(AP(KKP1))
  21458.                   D = (D/T)*REAL(AP(KKP1+1)) - T
  21459.                GO TO 40
  21460.    30          CONTINUE
  21461.                   D = T
  21462.                   T = 0.0E0
  21463.    40          CONTINUE
  21464.    50       CONTINUE
  21465. C
  21466.             IF (NOERT) GO TO 60
  21467.                IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1
  21468.                IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1
  21469.                IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1
  21470.    60       CONTINUE
  21471. C
  21472.             IF (NODET) GO TO 120
  21473.                DET(1) = D*DET(1)
  21474.                IF (DET(1) .EQ. 0.0E0) GO TO 110
  21475.    70             IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80
  21476.                      DET(1) = TEN*DET(1)
  21477.                      DET(2) = DET(2) - 1.0E0
  21478.                   GO TO 70
  21479.    80             CONTINUE
  21480.    90             IF (ABS(DET(1)) .LT. TEN) GO TO 100
  21481.                      DET(1) = DET(1)/TEN
  21482.                      DET(2) = DET(2) + 1.0E0
  21483.                   GO TO 90
  21484.   100             CONTINUE
  21485.   110          CONTINUE
  21486.   120       CONTINUE
  21487.             IK = IK + K
  21488.   130    CONTINUE
  21489.   140 CONTINUE
  21490. C
  21491. C     COMPUTE INVERSE(A)
  21492. C
  21493.       IF (NOINV) GO TO 270
  21494.          K = 1
  21495.          IK = 0
  21496.   150    IF (K .GT. N) GO TO 260
  21497.             KM1 = K - 1
  21498.             KK = IK + K
  21499.             IKP1 = IK + K
  21500.             KKP1 = IKP1 + K
  21501.             IF (KPVT(K) .LT. 0) GO TO 180
  21502. C
  21503. C              1 BY 1
  21504. C
  21505.                AP(KK) = CMPLX(1.0E0/REAL(AP(KK)),0.0E0)
  21506.                IF (KM1 .LT. 1) GO TO 170
  21507.                   CALL CCOPY(KM1,AP(IK+1),1,WORK,1)
  21508.                   IJ = 0
  21509.                   DO 160 J = 1, KM1
  21510.                      JK = IK + J
  21511.                      AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1)
  21512.                      CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
  21513.                      IJ = IJ + J
  21514.   160             CONTINUE
  21515.                   AP(KK) = AP(KK)
  21516.      1                     + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)),
  21517.      2                             0.0E0)
  21518.   170          CONTINUE
  21519.                KSTEP = 1
  21520.             GO TO 220
  21521.   180       CONTINUE
  21522. C
  21523. C              2 BY 2
  21524. C
  21525.                T = ABS(AP(KKP1))
  21526.                AK = REAL(AP(KK))/T
  21527.                AKP1 = REAL(AP(KKP1+1))/T
  21528.                AKKP1 = AP(KKP1)/T
  21529.                D = T*(AK*AKP1 - 1.0E0)
  21530.                AP(KK) = CMPLX(AKP1/D,0.0E0)
  21531.                AP(KKP1+1) = CMPLX(AK/D,0.0E0)
  21532.                AP(KKP1) = -AKKP1/D
  21533.                IF (KM1 .LT. 1) GO TO 210
  21534.                   CALL CCOPY(KM1,AP(IKP1+1),1,WORK,1)
  21535.                   IJ = 0
  21536.                   DO 190 J = 1, KM1
  21537.                      JKP1 = IKP1 + J
  21538.                      AP(JKP1) = CDOTC(J,AP(IJ+1),1,WORK,1)
  21539.                      CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1)
  21540.                      IJ = IJ + J
  21541.   190             CONTINUE
  21542.                   AP(KKP1+1) = AP(KKP1+1)
  21543.      1                         + CMPLX(REAL(CDOTC(KM1,WORK,1,
  21544.      2                                            AP(IKP1+1),1)),0.0E0)
  21545.                   AP(KKP1) = AP(KKP1)
  21546.      1                       + CDOTC(KM1,AP(IK+1),1,AP(IKP1+1),1)
  21547.                   CALL CCOPY(KM1,AP(IK+1),1,WORK,1)
  21548.                   IJ = 0
  21549.                   DO 200 J = 1, KM1
  21550.                      JK = IK + J
  21551.                      AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1)
  21552.                      CALL CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
  21553.                      IJ = IJ + J
  21554.   200             CONTINUE
  21555.                   AP(KK) = AP(KK)
  21556.      1                     + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)),
  21557.      2                             0.0E0)
  21558.   210          CONTINUE
  21559.                KSTEP = 2
  21560.   220       CONTINUE
  21561. C
  21562. C           SWAP
  21563. C
  21564.             KS = ABS(KPVT(K))
  21565.             IF (KS .EQ. K) GO TO 250
  21566.                IKS = (KS*(KS - 1))/2
  21567.                CALL CSWAP(KS,AP(IKS+1),1,AP(IK+1),1)
  21568.                KSJ = IK + KS
  21569.                DO 230 JB = KS, K
  21570.                   J = K + KS - JB
  21571.                   JK = IK + J
  21572.                   TEMP = CONJG(AP(JK))
  21573.                   AP(JK) = CONJG(AP(KSJ))
  21574.                   AP(KSJ) = TEMP
  21575.                   KSJ = KSJ - (J - 1)
  21576.   230          CONTINUE
  21577.                IF (KSTEP .EQ. 1) GO TO 240
  21578.                   KSKP1 = IKP1 + KS
  21579.                   TEMP = AP(KSKP1)
  21580.                   AP(KSKP1) = AP(KKP1)
  21581.                   AP(KKP1) = TEMP
  21582.   240          CONTINUE
  21583.   250       CONTINUE
  21584.             IK = IK + K
  21585.             IF (KSTEP .EQ. 2) IK = IK + K + 1
  21586.             K = K + KSTEP
  21587.          GO TO 150
  21588.   260    CONTINUE
  21589.   270 CONTINUE
  21590.       RETURN
  21591.       END
  21592. *DECK CHPFA
  21593.       SUBROUTINE CHPFA (AP, N, KPVT, INFO)
  21594. C***BEGIN PROLOGUE  CHPFA
  21595. C***PURPOSE  Factor a complex Hermitian matrix stored in packed form by
  21596. C            elimination with symmetric pivoting.
  21597. C***LIBRARY   SLATEC (LINPACK)
  21598. C***CATEGORY  D2D1A
  21599. C***TYPE      COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, DSPFA-C)
  21600. C***KEYWORDS  HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
  21601. C             PACKED
  21602. C***AUTHOR  Bunch, J., (UCSD)
  21603. C***DESCRIPTION
  21604. C
  21605. C     CHPFA factors a complex Hermitian matrix stored in
  21606. C     packed form by elimination with symmetric pivoting.
  21607. C
  21608. C     To solve  A*X = B , follow CHPFA by CHPSL.
  21609. C     To compute  INVERSE(A)*C , follow CHPFA by CHPSL.
  21610. C     To compute  DETERMINANT(A) , follow CHPFA by CHPDI.
  21611. C     To compute  INERTIA(A) , follow CHPFA by CHPDI.
  21612. C     To compute  INVERSE(A) , follow CHPFA by CHPDI.
  21613. C
  21614. C     On Entry
  21615. C
  21616. C        AP      COMPLEX (N*(N+1)/2)
  21617. C                the packed form of a Hermitian matrix  A .  The
  21618. C                columns of the upper triangle are stored sequentially
  21619. C                in a one-dimensional array of length  N*(N+1)/2 .
  21620. C                See comments below for details.
  21621. C
  21622. C        N       INTEGER
  21623. C                the order of the matrix  A .
  21624. C
  21625. C     Output
  21626. C
  21627. C        AP      A block diagonal matrix and the multipliers which
  21628. C                were used to obtain it stored in packed form.
  21629. C                The factorization can be written  A = U*D*CTRANS(U)
  21630. C                where  U  is a product of permutation and unit
  21631. C                upper triangular matrices , CTRANS(U) is the
  21632. C                conjugate transpose of  U , and  D  is block diagonal
  21633. C                with 1 by 1 and 2 by 2 blocks.
  21634. C
  21635. C        KVPT    INTEGER(N)
  21636. C                an integer vector of pivot indices.
  21637. C
  21638. C        INFO    INTEGER
  21639. C                = 0  normal value.
  21640. C                = K  if the K-th pivot block is singular.  This is
  21641. C                     not an error condition for this subroutine,
  21642. C                     but it does indicate that CHPSL or CHPDI may
  21643. C                     divide by zero if called.
  21644. C
  21645. C     Packed Storage
  21646. C
  21647. C          The following program segment will pack the upper
  21648. C          triangle of a Hermitian matrix.
  21649. C
  21650. C                K = 0
  21651. C                DO 20 J = 1, N
  21652. C                   DO 10 I = 1, J
  21653. C                      K = K + 1
  21654. C                      AP(K)  = A(I,J)
  21655. C             10    CONTINUE
  21656. C             20 CONTINUE
  21657. C
  21658. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  21659. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  21660. C***ROUTINES CALLED  CAXPY, CSWAP, ICAMAX
  21661. C***REVISION HISTORY  (YYMMDD)
  21662. C   780814  DATE WRITTEN
  21663. C   890531  Changed all specific intrinsics to generic.  (WRB)
  21664. C   890831  Modified array declarations.  (WRB)
  21665. C   891107  Modified routine equivalence list.  (WRB)
  21666. C   891107  REVISION DATE from Version 3.2
  21667. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  21668. C   900326  Removed duplicate information from DESCRIPTION section.
  21669. C           (WRB)
  21670. C   920501  Reformatted the REFERENCES section.  (WRB)
  21671. C***END PROLOGUE  CHPFA
  21672.       INTEGER N,KPVT(*),INFO
  21673.       COMPLEX AP(*)
  21674. C
  21675.       COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
  21676.       REAL ABSAKK,ALPHA,COLMAX,ROWMAX
  21677.       INTEGER ICAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK
  21678.       INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP
  21679.       LOGICAL SWAP
  21680.       COMPLEX ZDUM
  21681.       REAL CABS1
  21682.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  21683. C***FIRST EXECUTABLE STATEMENT  CHPFA
  21684. C
  21685. C     INITIALIZE
  21686. C
  21687. C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
  21688. C
  21689.       ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
  21690. C
  21691.       INFO = 0
  21692. C
  21693. C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
  21694. C
  21695.       K = N
  21696.       IK = (N*(N - 1))/2
  21697.    10 CONTINUE
  21698. C
  21699. C        LEAVE THE LOOP IF K=0 OR K=1.
  21700. C
  21701.          IF (K .EQ. 0) GO TO 200
  21702.          IF (K .GT. 1) GO TO 20
  21703.             KPVT(1) = 1
  21704.             IF (CABS1(AP(1)) .EQ. 0.0E0) INFO = 1
  21705.             GO TO 200
  21706.    20    CONTINUE
  21707. C
  21708. C        THIS SECTION OF CODE DETERMINES THE KIND OF
  21709. C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
  21710. C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
  21711. C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
  21712. C        REQUIRED.
  21713. C
  21714.          KM1 = K - 1
  21715.          KK = IK + K
  21716.          ABSAKK = CABS1(AP(KK))
  21717. C
  21718. C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
  21719. C        COLUMN K.
  21720. C
  21721.          IMAX = ICAMAX(K-1,AP(IK+1),1)
  21722.          IMK = IK + IMAX
  21723.          COLMAX = CABS1(AP(IMK))
  21724.          IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
  21725.             KSTEP = 1
  21726.             SWAP = .FALSE.
  21727.          GO TO 90
  21728.    30    CONTINUE
  21729. C
  21730. C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
  21731. C           ROW IMAX.
  21732. C
  21733.             ROWMAX = 0.0E0
  21734.             IMAXP1 = IMAX + 1
  21735.             IM = IMAX*(IMAX - 1)/2
  21736.             IMJ = IM + 2*IMAX
  21737.             DO 40 J = IMAXP1, K
  21738.                ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ)))
  21739.                IMJ = IMJ + J
  21740.    40       CONTINUE
  21741.             IF (IMAX .EQ. 1) GO TO 50
  21742.                JMAX = ICAMAX(IMAX-1,AP(IM+1),1)
  21743.                JMIM = JMAX + IM
  21744.                ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM)))
  21745.    50       CONTINUE
  21746.             IMIM = IMAX + IM
  21747.             IF (CABS1(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60
  21748.                KSTEP = 1
  21749.                SWAP = .TRUE.
  21750.             GO TO 80
  21751.    60       CONTINUE
  21752.             IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
  21753.                KSTEP = 1
  21754.                SWAP = .FALSE.
  21755.             GO TO 80
  21756.    70       CONTINUE
  21757.                KSTEP = 2
  21758.                SWAP = IMAX .NE. KM1
  21759.    80       CONTINUE
  21760.    90    CONTINUE
  21761.          IF (MAX(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
  21762. C
  21763. C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
  21764. C
  21765.             KPVT(K) = K
  21766.             INFO = K
  21767.          GO TO 190
  21768.   100    CONTINUE
  21769.          IF (KSTEP .EQ. 2) GO TO 140
  21770. C
  21771. C           1 X 1 PIVOT BLOCK.
  21772. C
  21773.             IF (.NOT.SWAP) GO TO 120
  21774. C
  21775. C              PERFORM AN INTERCHANGE.
  21776. C
  21777.                CALL CSWAP(IMAX,AP(IM+1),1,AP(IK+1),1)
  21778.                IMJ = IK + IMAX
  21779.                DO 110 JJ = IMAX, K
  21780.                   J = K + IMAX - JJ
  21781.                   JK = IK + J
  21782.                   T = CONJG(AP(JK))
  21783.                   AP(JK) = CONJG(AP(IMJ))
  21784.                   AP(IMJ) = T
  21785.                   IMJ = IMJ - (J - 1)
  21786.   110          CONTINUE
  21787.   120       CONTINUE
  21788. C
  21789. C           PERFORM THE ELIMINATION.
  21790. C
  21791.             IJ = IK - (K - 1)
  21792.             DO 130 JJ = 1, KM1
  21793.                J = K - JJ
  21794.                JK = IK + J
  21795.                MULK = -AP(JK)/AP(KK)
  21796.                T = CONJG(MULK)
  21797.                CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
  21798.                IJJ = IJ + J
  21799.                AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0)
  21800.                AP(JK) = MULK
  21801.                IJ = IJ - (J - 1)
  21802.   130       CONTINUE
  21803. C
  21804. C           SET THE PIVOT ARRAY.
  21805. C
  21806.             KPVT(K) = K
  21807.             IF (SWAP) KPVT(K) = IMAX
  21808.          GO TO 190
  21809.   140    CONTINUE
  21810. C
  21811. C           2 X 2 PIVOT BLOCK.
  21812. C
  21813.             KM1K = IK + K - 1
  21814.             IKM1 = IK - (K - 1)
  21815.             IF (.NOT.SWAP) GO TO 160
  21816. C
  21817. C              PERFORM AN INTERCHANGE.
  21818. C
  21819.                CALL CSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1)
  21820.                IMJ = IKM1 + IMAX
  21821.                DO 150 JJ = IMAX, KM1
  21822.                   J = KM1 + IMAX - JJ
  21823.                   JKM1 = IKM1 + J
  21824.                   T = CONJG(AP(JKM1))
  21825.                   AP(JKM1) = CONJG(AP(IMJ))
  21826.                   AP(IMJ) = T
  21827.                   IMJ = IMJ - (J - 1)
  21828.   150          CONTINUE
  21829.                T = AP(KM1K)
  21830.                AP(KM1K) = AP(IMK)
  21831.                AP(IMK) = T
  21832.   160       CONTINUE
  21833. C
  21834. C           PERFORM THE ELIMINATION.
  21835. C
  21836.             KM2 = K - 2
  21837.             IF (KM2 .EQ. 0) GO TO 180
  21838.                AK = AP(KK)/AP(KM1K)
  21839.                KM1KM1 = IKM1 + K - 1
  21840.                AKM1 = AP(KM1KM1)/CONJG(AP(KM1K))
  21841.                DENOM = 1.0E0 - AK*AKM1
  21842.                IJ = IK - (K - 1) - (K - 2)
  21843.                DO 170 JJ = 1, KM2
  21844.                   J = KM1 - JJ
  21845.                   JK = IK + J
  21846.                   BK = AP(JK)/AP(KM1K)
  21847.                   JKM1 = IKM1 + J
  21848.                   BKM1 = AP(JKM1)/CONJG(AP(KM1K))
  21849.                   MULK = (AKM1*BK - BKM1)/DENOM
  21850.                   MULKM1 = (AK*BKM1 - BK)/DENOM
  21851.                   T = CONJG(MULK)
  21852.                   CALL CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
  21853.                   T = CONJG(MULKM1)
  21854.                   CALL CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1)
  21855.                   AP(JK) = MULK
  21856.                   AP(JKM1) = MULKM1
  21857.                   IJJ = IJ + J
  21858.                   AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0)
  21859.                   IJ = IJ - (J - 1)
  21860.   170          CONTINUE
  21861.   180       CONTINUE
  21862. C
  21863. C           SET THE PIVOT ARRAY.
  21864. C
  21865.             KPVT(K) = 1 - K
  21866.             IF (SWAP) KPVT(K) = -IMAX
  21867.             KPVT(K-1) = KPVT(K)
  21868.   190    CONTINUE
  21869.          IK = IK - (K - 1)
  21870.          IF (KSTEP .EQ. 2) IK = IK - (K - 2)
  21871.          K = K - KSTEP
  21872.       GO TO 10
  21873.   200 CONTINUE
  21874.       RETURN
  21875.       END
  21876. *DECK CHPSL
  21877.       SUBROUTINE CHPSL (AP, N, KPVT, B)
  21878. C***BEGIN PROLOGUE  CHPSL
  21879. C***PURPOSE  Solve a complex Hermitian system using factors obtained
  21880. C            from CHPFA.
  21881. C***LIBRARY   SLATEC (LINPACK)
  21882. C***CATEGORY  D2D1A
  21883. C***TYPE      COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C)
  21884. C***KEYWORDS  HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE
  21885. C***AUTHOR  Bunch, J., (UCSD)
  21886. C***DESCRIPTION
  21887. C
  21888. C     CHISL solves the complex Hermitian system
  21889. C     A * X = B
  21890. C     using the factors computed by CHPFA.
  21891. C
  21892. C     On Entry
  21893. C
  21894. C        AP      COMPLEX(N*(N+1)/2)
  21895. C                the output from CHPFA.
  21896. C
  21897. C        N       INTEGER
  21898. C                the order of the matrix  A .
  21899. C
  21900. C        KVPT    INTEGER(N)
  21901. C                the pivot vector from CHPFA.
  21902. C
  21903. C        B       COMPLEX(N)
  21904. C                the right hand side vector.
  21905. C
  21906. C     On Return
  21907. C
  21908. C        B       the solution vector  X .
  21909. C
  21910. C     Error Condition
  21911. C
  21912. C        A division by zero may occur if  CHPCO  has set RCOND .EQ. 0.0
  21913. C        or  CHPFA  has set INFO .NE. 0  .
  21914. C
  21915. C     To compute  INVERSE(A) * C  where  C  is a matrix
  21916. C     with  P  columns
  21917. C           CALL CHPFA(AP,N,KVPT,INFO)
  21918. C           IF (INFO .NE. 0) GO TO ...
  21919. C           DO 10 J = 1, P
  21920. C              CALL CHPSL(AP,N,KVPT,C(1,J))
  21921. C        10 CONTINUE
  21922. C
  21923. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  21924. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  21925. C***ROUTINES CALLED  CAXPY, CDOTC
  21926. C***REVISION HISTORY  (YYMMDD)
  21927. C   780814  DATE WRITTEN
  21928. C   890531  Changed all specific intrinsics to generic.  (WRB)
  21929. C   890831  Modified array declarations.  (WRB)
  21930. C   891107  Modified routine equivalence list.  (WRB)
  21931. C   891107  REVISION DATE from Version 3.2
  21932. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  21933. C   900326  Removed duplicate information from DESCRIPTION section.
  21934. C           (WRB)
  21935. C   920501  Reformatted the REFERENCES section.  (WRB)
  21936. C***END PROLOGUE  CHPSL
  21937.       INTEGER N,KPVT(*)
  21938.       COMPLEX AP(*),B(*)
  21939. C
  21940.       COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP
  21941.       INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP
  21942. C
  21943. C     LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND
  21944. C     D INVERSE TO B.
  21945. C
  21946. C***FIRST EXECUTABLE STATEMENT  CHPSL
  21947.       K = N
  21948.       IK = (N*(N - 1))/2
  21949.    10 IF (K .EQ. 0) GO TO 80
  21950.          KK = IK + K
  21951.          IF (KPVT(K) .LT. 0) GO TO 40
  21952. C
  21953. C           1 X 1 PIVOT BLOCK.
  21954. C
  21955.             IF (K .EQ. 1) GO TO 30
  21956.                KP = KPVT(K)
  21957.                IF (KP .EQ. K) GO TO 20
  21958. C
  21959. C                 INTERCHANGE.
  21960. C
  21961.                   TEMP = B(K)
  21962.                   B(K) = B(KP)
  21963.                   B(KP) = TEMP
  21964.    20          CONTINUE
  21965. C
  21966. C              APPLY THE TRANSFORMATION.
  21967. C
  21968.                CALL CAXPY(K-1,B(K),AP(IK+1),1,B(1),1)
  21969.    30       CONTINUE
  21970. C
  21971. C           APPLY D INVERSE.
  21972. C
  21973.             B(K) = B(K)/AP(KK)
  21974.             K = K - 1
  21975.             IK = IK - K
  21976.          GO TO 70
  21977.    40    CONTINUE
  21978. C
  21979. C           2 X 2 PIVOT BLOCK.
  21980. C
  21981.             IKM1 = IK - (K - 1)
  21982.             IF (K .EQ. 2) GO TO 60
  21983.                KP = ABS(KPVT(K))
  21984.                IF (KP .EQ. K - 1) GO TO 50
  21985. C
  21986. C                 INTERCHANGE.
  21987. C
  21988.                   TEMP = B(K-1)
  21989.                   B(K-1) = B(KP)
  21990.                   B(KP) = TEMP
  21991.    50          CONTINUE
  21992. C
  21993. C              APPLY THE TRANSFORMATION.
  21994. C
  21995.                CALL CAXPY(K-2,B(K),AP(IK+1),1,B(1),1)
  21996.                CALL CAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1)
  21997.    60       CONTINUE
  21998. C
  21999. C           APPLY D INVERSE.
  22000. C
  22001.             KM1K = IK + K - 1
  22002.             KK = IK + K
  22003.             AK = AP(KK)/CONJG(AP(KM1K))
  22004.             KM1KM1 = IKM1 + K - 1
  22005.             AKM1 = AP(KM1KM1)/AP(KM1K)
  22006.             BK = B(K)/CONJG(AP(KM1K))
  22007.             BKM1 = B(K-1)/AP(KM1K)
  22008.             DENOM = AK*AKM1 - 1.0E0
  22009.             B(K) = (AKM1*BK - BKM1)/DENOM
  22010.             B(K-1) = (AK*BKM1 - BK)/DENOM
  22011.             K = K - 2
  22012.             IK = IK - (K + 1) - K
  22013.    70    CONTINUE
  22014.       GO TO 10
  22015.    80 CONTINUE
  22016. C
  22017. C     LOOP FORWARD APPLYING THE TRANSFORMATIONS.
  22018. C
  22019.       K = 1
  22020.       IK = 0
  22021.    90 IF (K .GT. N) GO TO 160
  22022.          IF (KPVT(K) .LT. 0) GO TO 120
  22023. C
  22024. C           1 X 1 PIVOT BLOCK.
  22025. C
  22026.             IF (K .EQ. 1) GO TO 110
  22027. C
  22028. C              APPLY THE TRANSFORMATION.
  22029. C
  22030.                B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1)
  22031.                KP = KPVT(K)
  22032.                IF (KP .EQ. K) GO TO 100
  22033. C
  22034. C                 INTERCHANGE.
  22035. C
  22036.                   TEMP = B(K)
  22037.                   B(K) = B(KP)
  22038.                   B(KP) = TEMP
  22039.   100          CONTINUE
  22040.   110       CONTINUE
  22041.             IK = IK + K
  22042.             K = K + 1
  22043.          GO TO 150
  22044.   120    CONTINUE
  22045. C
  22046. C           2 X 2 PIVOT BLOCK.
  22047. C
  22048.             IF (K .EQ. 1) GO TO 140
  22049. C
  22050. C              APPLY THE TRANSFORMATION.
  22051. C
  22052.                B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1)
  22053.                IKP1 = IK + K
  22054.                B(K+1) = B(K+1) + CDOTC(K-1,AP(IKP1+1),1,B(1),1)
  22055.                KP = ABS(KPVT(K))
  22056.                IF (KP .EQ. K) GO TO 130
  22057. C
  22058. C                 INTERCHANGE.
  22059. C
  22060.                   TEMP = B(K)
  22061.                   B(K) = B(KP)
  22062.                   B(KP) = TEMP
  22063.   130          CONTINUE
  22064.   140       CONTINUE
  22065.             IK = IK + K + K + 1
  22066.             K = K + 2
  22067.   150    CONTINUE
  22068.       GO TO 90
  22069.   160 CONTINUE
  22070.       RETURN
  22071.       END
  22072. *DECK CHU
  22073.       FUNCTION CHU (A, B, X)
  22074. C***BEGIN PROLOGUE  CHU
  22075. C***PURPOSE  Compute the logarithmic confluent hypergeometric function.
  22076. C***LIBRARY   SLATEC (FNLIB)
  22077. C***CATEGORY  C11
  22078. C***TYPE      SINGLE PRECISION (CHU-S, DCHU-D)
  22079. C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
  22080. C             SPECIAL FUNCTIONS
  22081. C***AUTHOR  Fullerton, W., (LANL)
  22082. C***DESCRIPTION
  22083. C
  22084. C CHU computes the logarithmic confluent hypergeometric function,
  22085. C U(A,B,X).
  22086. C
  22087. C Input Parameters:
  22088. C       A   real
  22089. C       B   real
  22090. C       X   real and positive
  22091. C
  22092. C This routine is not valid when 1+A-B is close to zero if X is small.
  22093. C
  22094. C***REFERENCES  (NONE)
  22095. C***ROUTINES CALLED  EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU,
  22096. C                    XERMSG
  22097. C***REVISION HISTORY  (YYMMDD)
  22098. C   770801  DATE WRITTEN
  22099. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22100. C   890531  REVISION DATE from Version 3.2
  22101. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22102. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  22103. C   900727  Added EXTERNAL statement.  (WRB)
  22104. C***END PROLOGUE  CHU
  22105.       EXTERNAL GAMMA
  22106.       SAVE PI, EPS
  22107.       DATA PI / 3.1415926535 8979324 E0 /
  22108.       DATA EPS / 0.0 /
  22109. C***FIRST EXECUTABLE STATEMENT  CHU
  22110.       IF (EPS.EQ.0.0) EPS = R1MACH(3)
  22111. C
  22112.       IF (X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CHU',
  22113.      +   'X IS ZERO SO CHU IS INFINITE', 1, 2)
  22114.       IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'CHU',
  22115.      +   'X IS NEGATIVE, USE CCHU', 2, 2)
  22116. C
  22117.       IF (MAX(ABS(A),1.0)*MAX(ABS(1.0+A-B),1.0).LT.0.99*ABS(X))
  22118.      1  GO TO 120
  22119. C
  22120. C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL
  22121. C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE.
  22122. C
  22123.       IF (ABS(1.0+A-B) .LT. SQRT(EPS)) CALL XERMSG ('SLATEC', 'CHU',
  22124.      +   'ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2)
  22125. C
  22126.       AINTB = AINT(B+0.5)
  22127.       IF (B.LT.0.0) AINTB = AINT(B-0.5)
  22128.       BEPS = B - AINTB
  22129.       N = AINTB
  22130. C
  22131.       ALNX = LOG(X)
  22132.       XTOEPS = EXP(-BEPS*ALNX)
  22133. C
  22134. C EVALUATE THE FINITE SUM.     -----------------------------------------
  22135. C
  22136.       IF (N.GE.1) GO TO 40
  22137. C
  22138. C CONSIDER THE CASE B .LT. 1.0 FIRST.
  22139. C
  22140.       SUM = 1.0
  22141.       IF (N.EQ.0) GO TO 30
  22142. C
  22143.       T = 1.0
  22144.       M = -N
  22145.       DO 20 I=1,M
  22146.         XI1 = I - 1
  22147.         T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0))
  22148.         SUM = SUM + T
  22149.  20   CONTINUE
  22150. C
  22151.  30   SUM = POCH(1.0+A-B, -A) * SUM
  22152.       GO TO 70
  22153. C
  22154. C NOW CONSIDER THE CASE B .GE. 1.0.
  22155. C
  22156.  40   SUM = 0.0
  22157.       M = N - 2
  22158.       IF (M.LT.0) GO TO 70
  22159.       T = 1.0
  22160.       SUM = 1.0
  22161.       IF (M.EQ.0) GO TO 60
  22162. C
  22163.       DO 50 I=1,M
  22164.         XI = I
  22165.         T = T * (A-B+XI)*X/((1.0-B+XI)*XI)
  22166.         SUM = SUM + T
  22167.  50   CONTINUE
  22168. C
  22169.  60   SUM = GAMMA(B-1.0) * GAMR(A) * X**(1-N) * XTOEPS * SUM
  22170. C
  22171. C NOW EVALUATE THE INFINITE SUM.     -----------------------------------
  22172. C
  22173.  70   ISTRT = 0
  22174.       IF (N.LT.1) ISTRT = 1 - N
  22175.       XI = ISTRT
  22176. C
  22177.       FACTOR = (-1.0)**N * GAMR(1.0+A-B) * X**ISTRT
  22178.       IF (BEPS.NE.0.0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI)
  22179. C
  22180.       POCHAI = POCH (A, XI)
  22181.       GAMRI1 = GAMR (XI+1.0)
  22182.       GAMRNI = GAMR (AINTB+XI)
  22183.       B0 = FACTOR * POCH(A,XI-BEPS) * GAMRNI * GAMR(XI+1.0-BEPS)
  22184. C
  22185.       IF (ABS(XTOEPS-1.0).GT.0.5) GO TO 90
  22186. C
  22187. C X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING
  22188. C THE DIFFERENCES
  22189. C
  22190.       PCH1AI = POCH1 (A+XI, -BEPS)
  22191.       PCH1I = POCH1 (XI+1.0-BEPS, BEPS)
  22192.       C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * (
  22193.      1  -POCH1(B+XI, -BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I )
  22194. C
  22195. C XEPS1 = (1.0 - X**(-BEPS)) / BEPS
  22196.       XEPS1 = ALNX * EXPREL(-BEPS*ALNX)
  22197. C
  22198.       CHU = SUM + C0 + XEPS1*B0
  22199.       XN = N
  22200.       DO 80 I=1,1000
  22201.         XI = ISTRT + I
  22202.         XI1 = ISTRT + I - 1
  22203.         B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS))
  22204.         C0 = (A+XI1)*C0*X/((B+XI1)*XI) - ((A-1.0)*(XN+2.*XI-1.0)
  22205.      1    + XI*(XI-BEPS)) * B0/(XI*(B+XI1)*(A+XI1-BEPS))
  22206.         T = C0 + XEPS1*B0
  22207.         CHU = CHU + T
  22208.         IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130
  22209.  80   CONTINUE
  22210.       CALL XERMSG ('SLATEC', 'CHU',
  22211.      +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
  22212. C
  22213. C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD
  22214. C FORMULATION IS STABLE.
  22215. C
  22216.  90   A0 = FACTOR * POCHAI * GAMR(B+XI) * GAMRI1 / BEPS
  22217.       B0 = XTOEPS*B0/BEPS
  22218. C
  22219.       CHU = SUM + A0 - B0
  22220.       DO 100 I=1,1000
  22221.         XI = ISTRT + I
  22222.         XI1 = ISTRT + I - 1
  22223.         A0 = (A+XI1)*A0*X/((B+XI1)*XI)
  22224.         B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS))
  22225.         T = A0 - B0
  22226.         CHU = CHU + T
  22227.         IF (ABS(T).LT.EPS*ABS(CHU)) GO TO 130
  22228.  100  CONTINUE
  22229.       CALL XERMSG ('SLATEC', 'CHU',
  22230.      +   'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2)
  22231. C
  22232. C USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION.
  22233. C
  22234.  120  CHU = X**(-A) * R9CHU(A, B, X)
  22235. C
  22236.  130  RETURN
  22237.       END
  22238. *DECK CINVIT
  22239.       SUBROUTINE CINVIT (NM, N, AR, AI, WR, WI, SELECT, MM, M, ZR, ZI,
  22240.      +   IERR, RM1, RM2, RV1, RV2)
  22241. C***BEGIN PROLOGUE  CINVIT
  22242. C***PURPOSE  Compute the eigenvectors of a complex upper Hessenberg
  22243. C            associated with specified eigenvalues using inverse
  22244. C            iteration.
  22245. C***LIBRARY   SLATEC (EISPACK)
  22246. C***CATEGORY  D4C2B
  22247. C***TYPE      COMPLEX (INVIT-S, CINVIT-C)
  22248. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  22249. C***AUTHOR  Smith, B. T., et al.
  22250. C***DESCRIPTION
  22251. C
  22252. C     This subroutine is a translation of the ALGOL procedure CXINVIT
  22253. C     by Peters and Wilkinson.
  22254. C     HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971).
  22255. C
  22256. C     This subroutine finds those eigenvectors of A COMPLEX UPPER
  22257. C     Hessenberg matrix corresponding to specified eigenvalues,
  22258. C     using inverse iteration.
  22259. C
  22260. C     On INPUT
  22261. C
  22262. C        NM must be set to the row dimension of the two-dimensional
  22263. C          array parameters, AR, AI, ZR and ZI, as declared in the
  22264. C          calling program dimension statement.  NM is an INTEGER
  22265. C          variable.
  22266. C
  22267. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  22268. C          variable.  N must be less than or equal to NM.
  22269. C
  22270. C        AR and AI contain the real and imaginary parts, respectively,
  22271. C          of the complex upper Hessenberg matrix.  AR and AI are
  22272. C          two-dimensional REAL arrays, dimensioned AR(NM,N)
  22273. C          and AI(NM,N).
  22274. C
  22275. C        WR and WI contain the real and imaginary parts, respectively,
  22276. C          of the eigenvalues of the matrix.  The eigenvalues must be
  22277. C          stored in a manner identical to that of subroutine  COMLR,
  22278. C          which recognizes possible splitting of the matrix.  WR and
  22279. C          WI are one-dimensional REAL arrays, dimensioned WR(N) and
  22280. C          WI(N).
  22281. C
  22282. C        SELECT specifies the eigenvectors to be found.  The
  22283. C          eigenvector corresponding to the J-th eigenvalue is
  22284. C          specified by setting SELECT(J) to .TRUE.  SELECT is a
  22285. C          one-dimensional LOGICAL array, dimensioned SELECT(N).
  22286. C
  22287. C        MM should be set to an upper bound for the number of
  22288. C          eigenvectors to be found.  MM is an INTEGER variable.
  22289. C
  22290. C     On OUTPUT
  22291. C
  22292. C        AR, AI, WI, and SELECT are unaltered.
  22293. C
  22294. C        WR may have been altered since close eigenvalues are perturbed
  22295. C          slightly in searching for independent eigenvectors.
  22296. C
  22297. C        M is the number of eigenvectors actually found.  M is an
  22298. C          INTEGER variable.
  22299. C
  22300. C        ZR and ZI contain the real and imaginary parts, respectively,
  22301. C          of the eigenvectors corresponding to the flagged eigenvalues.
  22302. C          The eigenvectors are normalized so that the component of
  22303. C          largest magnitude is 1.  Any vector which fails the
  22304. C          acceptance test is set to zero.  ZR and ZI are
  22305. C          two-dimensional REAL arrays, dimensioned ZR(NM,MM) and
  22306. C          ZI(NM,MM).
  22307. C
  22308. C        IERR is an INTEGER flag set to
  22309. C          Zero       for normal return,
  22310. C          -(2*N+1)   if more than MM eigenvectors have been requested
  22311. C                     (the MM eigenvectors calculated to this point are
  22312. C                     in ZR and ZI),
  22313. C          -K         if the iteration corresponding to the K-th
  22314. C                     value fails (if this occurs more than once, K
  22315. C                     is the index of the last occurrence); the
  22316. C                     corresponding columns of ZR and ZI are set to
  22317. C                     zero vectors,
  22318. C          -(N+K)     if both error situations occur.
  22319. C
  22320. C        RV1 and RV2 are one-dimensional REAL arrays used for
  22321. C          temporary storage, dimensioned RV1(N) and RV2(N).
  22322. C          They hold the approximate eigenvectors during the inverse
  22323. C          iteration process.
  22324. C
  22325. C        RM1 and RM2 are two-dimensional REAL arrays used for
  22326. C          temporary storage, dimensioned RM1(N,N) and RM2(N,N).
  22327. C          These arrays hold the triangularized form of the upper
  22328. C          Hessenberg matrix used in the inverse iteration process.
  22329. C
  22330. C     The ALGOL procedure GUESSVEC appears in CINVIT in-line.
  22331. C
  22332. C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
  22333. C     Calls CDIV for complex division.
  22334. C
  22335. C     Questions and comments should be directed to B. S. Garbow,
  22336. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  22337. C     ------------------------------------------------------------------
  22338. C
  22339. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  22340. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  22341. C                 system Routines - EISPACK Guide, Springer-Verlag,
  22342. C                 1976.
  22343. C***ROUTINES CALLED  CDIV, PYTHAG
  22344. C***REVISION HISTORY  (YYMMDD)
  22345. C   760101  DATE WRITTEN
  22346. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22347. C   890831  Modified array declarations.  (WRB)
  22348. C   890831  REVISION DATE from Version 3.2
  22349. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22350. C   920501  Reformatted the REFERENCES section.  (WRB)
  22351. C***END PROLOGUE  CINVIT
  22352. C
  22353.       INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR
  22354.       REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
  22355.       REAL RM1(N,*),RM2(N,*),RV1(*),RV2(*)
  22356.       REAL X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT
  22357.       REAL PYTHAG
  22358.       LOGICAL SELECT(N)
  22359. C
  22360. C***FIRST EXECUTABLE STATEMENT  CINVIT
  22361.       IERR = 0
  22362.       UK = 0
  22363.       S = 1
  22364. C
  22365.       DO 980 K = 1, N
  22366.          IF (.NOT. SELECT(K)) GO TO 980
  22367.          IF (S .GT. MM) GO TO 1000
  22368.          IF (UK .GE. K) GO TO 200
  22369. C     .......... CHECK FOR POSSIBLE SPLITTING ..........
  22370.          DO 120 UK = K, N
  22371.             IF (UK .EQ. N) GO TO 140
  22372.             IF (AR(UK+1,UK) .EQ. 0.0E0 .AND. AI(UK+1,UK) .EQ. 0.0E0)
  22373.      1         GO TO 140
  22374.   120    CONTINUE
  22375. C     .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
  22376. C                (HESSENBERG) MATRIX ..........
  22377.   140    NORM = 0.0E0
  22378.          MP = 1
  22379. C
  22380.          DO 180 I = 1, UK
  22381.             X = 0.0E0
  22382. C
  22383.             DO 160 J = MP, UK
  22384.   160       X = X + PYTHAG(AR(I,J),AI(I,J))
  22385. C
  22386.             IF (X .GT. NORM) NORM = X
  22387.             MP = I
  22388.   180    CONTINUE
  22389. C     .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
  22390. C                AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
  22391.          IF (NORM .EQ. 0.0E0) NORM = 1.0E0
  22392.          EPS3 = NORM
  22393.   190    EPS3 = 0.5E0*EPS3
  22394.          IF (NORM + EPS3 .GT. NORM) GO TO 190
  22395.          EPS3 = 2.0E0*EPS3
  22396. C     .......... GROWTO IS THE CRITERION FOR GROWTH ..........
  22397.          UKROOT = SQRT(REAL(UK))
  22398.          GROWTO = 0.1E0 / UKROOT
  22399.   200    RLAMBD = WR(K)
  22400.          ILAMBD = WI(K)
  22401.          IF (K .EQ. 1) GO TO 280
  22402.          KM1 = K - 1
  22403.          GO TO 240
  22404. C     .......... PERTURB EIGENVALUE IF IT IS CLOSE
  22405. C                TO ANY PREVIOUS EIGENVALUE ..........
  22406.   220    RLAMBD = RLAMBD + EPS3
  22407. C     .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
  22408.   240    DO 260 II = 1, KM1
  22409.             I = K - II
  22410.             IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
  22411.      1         ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
  22412.   260    CONTINUE
  22413. C
  22414.          WR(K) = RLAMBD
  22415. C     .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I
  22416. C                AND INITIAL COMPLEX VECTOR ..........
  22417.   280    MP = 1
  22418. C
  22419.          DO 320 I = 1, UK
  22420. C
  22421.             DO 300 J = MP, UK
  22422.                RM1(I,J) = AR(I,J)
  22423.                RM2(I,J) = AI(I,J)
  22424.   300       CONTINUE
  22425. C
  22426.             RM1(I,I) = RM1(I,I) - RLAMBD
  22427.             RM2(I,I) = RM2(I,I) - ILAMBD
  22428.             MP = I
  22429.             RV1(I) = EPS3
  22430.   320    CONTINUE
  22431. C     .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
  22432. C                REPLACING ZERO PIVOTS BY EPS3 ..........
  22433.          IF (UK .EQ. 1) GO TO 420
  22434. C
  22435.          DO 400 I = 2, UK
  22436.             MP = I - 1
  22437.             IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE.
  22438.      1         PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360
  22439. C
  22440.             DO 340 J = MP, UK
  22441.                Y = RM1(I,J)
  22442.                RM1(I,J) = RM1(MP,J)
  22443.                RM1(MP,J) = Y
  22444.                Y = RM2(I,J)
  22445.                RM2(I,J) = RM2(MP,J)
  22446.                RM2(MP,J) = Y
  22447.   340       CONTINUE
  22448. C
  22449.   360       IF (RM1(MP,MP) .EQ. 0.0E0 .AND. RM2(MP,MP) .EQ. 0.0E0)
  22450.      1         RM1(MP,MP) = EPS3
  22451.             CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y)
  22452.             IF (X .EQ. 0.0E0 .AND. Y .EQ. 0.0E0) GO TO 400
  22453. C
  22454.             DO 380 J = I, UK
  22455.                RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J)
  22456.                RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J)
  22457.   380       CONTINUE
  22458. C
  22459.   400    CONTINUE
  22460. C
  22461.   420    IF (RM1(UK,UK) .EQ. 0.0E0 .AND. RM2(UK,UK) .EQ. 0.0E0)
  22462.      1      RM1(UK,UK) = EPS3
  22463.          ITS = 0
  22464. C     .......... BACK SUBSTITUTION
  22465. C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  22466.   660    DO 720 II = 1, UK
  22467.             I = UK + 1 - II
  22468.             X = RV1(I)
  22469.             Y = 0.0E0
  22470.             IF (I .EQ. UK) GO TO 700
  22471.             IP1 = I + 1
  22472. C
  22473.             DO 680 J = IP1, UK
  22474.                X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J)
  22475.                Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J)
  22476.   680       CONTINUE
  22477. C
  22478.   700       CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I))
  22479.   720    CONTINUE
  22480. C     .......... ACCEPTANCE TEST FOR EIGENVECTOR
  22481. C                AND NORMALIZATION ..........
  22482.          ITS = ITS + 1
  22483.          NORM = 0.0E0
  22484.          NORMV = 0.0E0
  22485. C
  22486.          DO 780 I = 1, UK
  22487.             X = PYTHAG(RV1(I),RV2(I))
  22488.             IF (NORMV .GE. X) GO TO 760
  22489.             NORMV = X
  22490.             J = I
  22491.   760       NORM = NORM + X
  22492.   780    CONTINUE
  22493. C
  22494.          IF (NORM .LT. GROWTO) GO TO 840
  22495. C     .......... ACCEPT VECTOR ..........
  22496.          X = RV1(J)
  22497.          Y = RV2(J)
  22498. C
  22499.          DO 820 I = 1, UK
  22500.             CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S))
  22501.   820    CONTINUE
  22502. C
  22503.          IF (UK .EQ. N) GO TO 940
  22504.          J = UK + 1
  22505.          GO TO 900
  22506. C     .......... IN-LINE PROCEDURE FOR CHOOSING
  22507. C                A NEW STARTING VECTOR ..........
  22508.   840    IF (ITS .GE. UK) GO TO 880
  22509.          X = UKROOT
  22510.          Y = EPS3 / (X + 1.0E0)
  22511.          RV1(1) = EPS3
  22512. C
  22513.          DO 860 I = 2, UK
  22514.   860    RV1(I) = Y
  22515. C
  22516.          J = UK - ITS + 1
  22517.          RV1(J) = RV1(J) - EPS3 * X
  22518.          GO TO 660
  22519. C     .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
  22520.   880    J = 1
  22521.          IERR = -K
  22522. C     .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
  22523.   900    DO 920 I = J, N
  22524.             ZR(I,S) = 0.0E0
  22525.             ZI(I,S) = 0.0E0
  22526.   920    CONTINUE
  22527. C
  22528.   940    S = S + 1
  22529.   980 CONTINUE
  22530. C
  22531.       GO TO 1001
  22532. C     .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
  22533. C                SPACE REQUIRED ..........
  22534.  1000 IF (IERR .NE. 0) IERR = IERR - N
  22535.       IF (IERR .EQ. 0) IERR = -(2 * N + 1)
  22536.  1001 M = S - 1
  22537.       RETURN
  22538.       END
  22539. *DECK CLBETA
  22540.       COMPLEX FUNCTION CLBETA (A, B)
  22541. C***BEGIN PROLOGUE  CLBETA
  22542. C***PURPOSE  Compute the natural logarithm of the complete Beta
  22543. C            function.
  22544. C***LIBRARY   SLATEC (FNLIB)
  22545. C***CATEGORY  C7B
  22546. C***TYPE      COMPLEX (ALBETA-S, DLBETA-D, CLBETA-C)
  22547. C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
  22548. C             SPECIAL FUNCTIONS
  22549. C***AUTHOR  Fullerton, W., (LANL)
  22550. C***DESCRIPTION
  22551. C
  22552. C CLBETA computes the natural log of the complex valued complete beta
  22553. C function of complex parameters A and B.  This is a preliminary version
  22554. C which is not accurate.
  22555. C
  22556. C Input Parameters:
  22557. C       A   complex and the real part of A positive
  22558. C       B   complex and the real part of B positive
  22559. C
  22560. C***REFERENCES  (NONE)
  22561. C***ROUTINES CALLED  CLNGAM, XERMSG
  22562. C***REVISION HISTORY  (YYMMDD)
  22563. C   770701  DATE WRITTEN
  22564. C   861211  REVISION DATE from Version 3.2
  22565. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22566. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  22567. C***END PROLOGUE  CLBETA
  22568.       COMPLEX A, B, CLNGAM
  22569. C***FIRST EXECUTABLE STATEMENT  CLBETA
  22570.       IF (REAL(A) .LE. 0.0 .OR. REAL(B) .LE. 0.0) CALL XERMSG ('SLATEC',
  22571.      +   'CLBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2)
  22572. C
  22573.       CLBETA = CLNGAM(A) + CLNGAM(B) - CLNGAM(A+B)
  22574. C
  22575.       RETURN
  22576.       END
  22577. *DECK CLNGAM
  22578.       COMPLEX FUNCTION CLNGAM (ZIN)
  22579. C***BEGIN PROLOGUE  CLNGAM
  22580. C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
  22581. C            function.
  22582. C***LIBRARY   SLATEC (FNLIB)
  22583. C***CATEGORY  C7A
  22584. C***TYPE      COMPLEX (ALNGAM-S, DLNGAM-D, CLNGAM-C)
  22585. C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
  22586. C             SPECIAL FUNCTIONS
  22587. C***AUTHOR  Fullerton, W., (LANL)
  22588. C***DESCRIPTION
  22589. C
  22590. C CLNGAM computes the natural log of the complex valued gamma function
  22591. C at ZIN, where ZIN is a complex number.  This is a preliminary version,
  22592. C which is not accurate.
  22593. C
  22594. C***REFERENCES  (NONE)
  22595. C***ROUTINES CALLED  C9LGMC, CARG, CLNREL, R1MACH, XERMSG
  22596. C***REVISION HISTORY  (YYMMDD)
  22597. C   780401  DATE WRITTEN
  22598. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22599. C   890531  REVISION DATE from Version 3.2
  22600. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22601. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  22602. C***END PROLOGUE  CLNGAM
  22603.       COMPLEX ZIN, Z, CORR, CLNREL, C9LGMC
  22604.       LOGICAL FIRST
  22605.       SAVE PI, SQ2PIL, BOUND, DXREL, FIRST
  22606.       DATA PI / 3.1415926535 8979324E0 /
  22607.       DATA SQ2PIL / 0.9189385332 0467274E0 /
  22608.       DATA FIRST /.TRUE./
  22609. C***FIRST EXECUTABLE STATEMENT  CLNGAM
  22610.       IF (FIRST) THEN
  22611.          N = -0.30*LOG(R1MACH(3))
  22612. C BOUND = N*(0.1*EPS)**(-1/(2*N-1))/(PI*EXP(1))
  22613.          BOUND = 0.1171*N*(0.1*R1MACH(3))**(-1./(2*N-1))
  22614.          DXREL = SQRT (R1MACH(4))
  22615.       ENDIF
  22616.       FIRST = .FALSE.
  22617. C
  22618.       Z = ZIN
  22619.       X = REAL(ZIN)
  22620.       Y = AIMAG(ZIN)
  22621. C
  22622.       CORR = (0.0, 0.0)
  22623.       CABSZ = ABS(Z)
  22624.       IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50
  22625.       IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50
  22626. C
  22627.       IF (CABSZ.LT.BOUND) GO TO 20
  22628. C
  22629. C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND
  22630. C ABS(AIMAG(Y)) SMALL.
  22631. C
  22632.       IF (Y.GT.0.0) Z = CONJG (Z)
  22633.       CORR = EXP (-CMPLX(0.0,2.0*PI)*Z)
  22634.       IF (REAL(CORR) .EQ. 1.0 .AND. AIMAG(CORR) .EQ. 0.0) CALL XERMSG
  22635.      +   ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2)
  22636. C
  22637.       CLNGAM = SQ2PIL + 1.0 - CMPLX(0.0,PI)*(Z-0.5) - CLNREL(-CORR)
  22638.      1  + (Z-0.5)*LOG(1.0-Z) - Z - C9LGMC(1.0-Z)
  22639.       IF (Y.GT.0.0) CLNGAM = CONJG (CLNGAM)
  22640.       RETURN
  22641. C
  22642. C USE THE RECURSION RELATION FOR ABS(Z) SMALL.
  22643. C
  22644.  20   IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30
  22645.       IF (ABS((Z-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
  22646.      +   'CLNGAM',
  22647.      +   'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER',
  22648.      +   1, 1)
  22649. C
  22650.  30   N = SQRT (BOUND**2 - Y**2) - X + 1.0
  22651.       ARGSUM = 0.0
  22652.       CORR = (1.0, 0.0)
  22653.       DO 40 I=1,N
  22654.         ARGSUM = ARGSUM + CARG(Z)
  22655.         CORR = Z*CORR
  22656.         Z = 1.0 + Z
  22657.  40   CONTINUE
  22658. C
  22659.       IF (REAL(CORR) .EQ. 0.0 .AND. AIMAG(CORR) .EQ. 0.0) CALL XERMSG
  22660.      +   ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2)
  22661.       CORR = -CMPLX (LOG(ABS(CORR)), ARGSUM)
  22662. C
  22663. C USE STIRLING-S APPROXIMATION FOR LARGE Z.
  22664. C
  22665.  50   CLNGAM = SQ2PIL + (Z-0.5)*LOG(Z) - Z + CORR + C9LGMC(Z)
  22666.       RETURN
  22667. C
  22668.       END
  22669. *DECK CLNREL
  22670.       COMPLEX FUNCTION CLNREL (Z)
  22671. C***BEGIN PROLOGUE  CLNREL
  22672. C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
  22673. C***LIBRARY   SLATEC (FNLIB)
  22674. C***CATEGORY  C4B
  22675. C***TYPE      COMPLEX (ALNREL-S, DLNREL-D, CLNREL-C)
  22676. C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
  22677. C***AUTHOR  Fullerton, W., (LANL)
  22678. C***DESCRIPTION
  22679. C
  22680. C CLNREL(Z) = LOG(1+Z) with relative error accuracy near Z = 0.
  22681. C Let   RHO = ABS(Z)  and
  22682. C       R**2 = ABS(1+Z)**2 = (1+X)**2 + Y**2 = 1 + 2*X + RHO**2 .
  22683. C Now if RHO is small we may evaluate CLNREL(Z) accurately by
  22684. C       LOG(1+Z) = CMPLX  (LOG(R), CARG(1+Z))
  22685. C                 = CMPLX  (0.5*LOG(R**2), CARG(1+Z))
  22686. C                 = CMPLX  (0.5*ALNREL(2*X+RHO**2), CARG(1+Z))
  22687. C
  22688. C***REFERENCES  (NONE)
  22689. C***ROUTINES CALLED  ALNREL, CARG, R1MACH, XERMSG
  22690. C***REVISION HISTORY  (YYMMDD)
  22691. C   770401  DATE WRITTEN
  22692. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22693. C   890531  REVISION DATE from Version 3.2
  22694. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22695. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  22696. C***END PROLOGUE  CLNREL
  22697.       COMPLEX Z
  22698.       SAVE SQEPS
  22699.       DATA SQEPS /0.0/
  22700. C***FIRST EXECUTABLE STATEMENT  CLNREL
  22701.       IF (SQEPS.EQ.0.) SQEPS = SQRT (R1MACH(4))
  22702. C
  22703.       IF (ABS(1.+Z) .LT. SQEPS) CALL XERMSG ('SLATEC', 'CLNREL',
  22704.      +   'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR -1', 1, 1)
  22705. C
  22706.       RHO = ABS(Z)
  22707.       IF (RHO.GT.0.375) CLNREL = LOG (1.0+Z)
  22708.       IF (RHO.GT.0.375) RETURN
  22709. C
  22710.       X = REAL(Z)
  22711.       CLNREL = CMPLX (0.5*ALNREL(2.*X+RHO**2), CARG(1.0+Z))
  22712. C
  22713.       RETURN
  22714.       END
  22715. *DECK CLOG10
  22716.       COMPLEX FUNCTION CLOG10 (Z)
  22717. C***BEGIN PROLOGUE  CLOG10
  22718. C***PURPOSE  Compute the principal value of the complex base 10
  22719. C            logarithm.
  22720. C***LIBRARY   SLATEC (FNLIB)
  22721. C***CATEGORY  C4B
  22722. C***TYPE      COMPLEX (CLOG10-C)
  22723. C***KEYWORDS  BASE TEN LOGARITHM, ELEMENTARY FUNCTIONS, FNLIB
  22724. C***AUTHOR  Fullerton, W., (LANL)
  22725. C***DESCRIPTION
  22726. C
  22727. C CLOG10(Z) calculates the principal value of the complex common
  22728. C or base 10 logarithm of Z for -PI .LT. arg(Z) .LE. +PI.
  22729. C
  22730. C***REFERENCES  (NONE)
  22731. C***ROUTINES CALLED  (NONE)
  22732. C***REVISION HISTORY  (YYMMDD)
  22733. C   770401  DATE WRITTEN
  22734. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22735. C   890531  REVISION DATE from Version 3.2
  22736. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22737. C***END PROLOGUE  CLOG10
  22738.       COMPLEX Z
  22739.       SAVE ALOGE
  22740.       DATA ALOGE / 0.4342944819 0325182765E0 /
  22741. C***FIRST EXECUTABLE STATEMENT  CLOG10
  22742.       CLOG10 = ALOGE * LOG(Z)
  22743. C
  22744.       RETURN
  22745.       END
  22746. *DECK CMGNBN
  22747.       SUBROUTINE CMGNBN (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y,
  22748.      +   IERROR, W)
  22749. C***BEGIN PROLOGUE  CMGNBN
  22750. C***PURPOSE  Solve a complex block tridiagonal linear system of
  22751. C            equations by a cyclic reduction algorithm.
  22752. C***LIBRARY   SLATEC (FISHPACK)
  22753. C***CATEGORY  I2B4B
  22754. C***TYPE      COMPLEX (GENBUN-S, CMGNBN-C)
  22755. C***KEYWORDS  CYCLIC REDUCTION, ELLIPTIC PDE, FISHPACK,
  22756. C             TRIDIAGONAL LINEAR SYSTEM
  22757. C***AUTHOR  Adams, J., (NCAR)
  22758. C           Swarztrauber, P. N., (NCAR)
  22759. C           Sweet, R., (NCAR)
  22760. C***DESCRIPTION
  22761. C
  22762. C     Subroutine CMGNBN solves the complex linear system of equations
  22763. C
  22764. C          A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
  22765. C
  22766. C          + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
  22767. C
  22768. C               For I = 1,2,...,M  and  J = 1,2,...,N.
  22769. C
  22770. C     The indices I+1 and I-1 are evaluated modulo M, i.e.,
  22771. C     X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to
  22772. C     0, X(I,2), or X(I,N) and X(I,N+1) may be equal to 0, X(I,N-1), or
  22773. C     X(I,1) depending on an input parameter.
  22774. C
  22775. C
  22776. C     * * * * * * * *    Parameter Description     * * * * * * * * * *
  22777. C
  22778. C             * * * * * *   On Input    * * * * * *
  22779. C
  22780. C     NPEROD
  22781. C       Indicates the values that X(I,0) and X(I,N+1) are assumed to
  22782. C       have.
  22783. C
  22784. C       = 0  If X(I,0) = X(I,N) and X(I,N+1) = X(I,1).
  22785. C       = 1  If X(I,0) = X(I,N+1) = 0  .
  22786. C       = 2  If X(I,0) = 0 and X(I,N+1) = X(I,N-1).
  22787. C       = 3  If X(I,0) = X(I,2) and X(I,N+1) = X(I,N-1).
  22788. C       = 4  If X(I,0) = X(I,2) and X(I,N+1) = 0.
  22789. C
  22790. C     N
  22791. C       The number of unknowns in the J-direction.  N must be greater
  22792. C       than 2.
  22793. C
  22794. C     MPEROD
  22795. C       = 0 If A(1) and C(M) are not zero
  22796. C       = 1 If A(1) = C(M) = 0
  22797. C
  22798. C     M
  22799. C       The number of unknowns in the I-direction.  N must be greater
  22800. C       than 2.
  22801. C
  22802. C     A,B,C
  22803. C       One-dimensional complex arrays of length M that specify the
  22804. C       coefficients in the linear equations given above.  If MPEROD = 0
  22805. C       the array elements must not depend upon the index I, but must be
  22806. C       constant.  Specifically, the subroutine checks the following
  22807. C       condition
  22808. C
  22809. C             A(I) = C(1)
  22810. C             C(I) = C(1)
  22811. C             B(I) = B(1)
  22812. C
  22813. C       For I=1,2,...,M.
  22814. C
  22815. C     IDIMY
  22816. C       The row (or first) dimension of the two-dimensional array Y as
  22817. C       it appears in the program calling CMGNBN.  This parameter is
  22818. C       used to specify the variable dimension of Y.  IDIMY must be at
  22819. C       least M.
  22820. C
  22821. C     Y
  22822. C       A two-dimensional complex array that specifies the values of the
  22823. C       right side of the linear system of equations given above.  Y
  22824. C       must be dimensioned at least M*N.
  22825. C
  22826. C     W
  22827. C       A one-dimensional complex array that must be provided by the
  22828. C       user for work space.  W may require up to 4*N +
  22829. C       (10 + INT(log2(N)))*M LOCATIONS.  The actual number of locations
  22830. C       used is computed by CMGNBN and is returned in location W(1).
  22831. C
  22832. C
  22833. C             * * * * * *   On Output     * * * * * *
  22834. C
  22835. C     Y
  22836. C       Contains the solution X.
  22837. C
  22838. C     IERROR
  22839. C       An error flag which indicates invalid input parameters.  Except
  22840. C       for number zero, a solution is not attempted.
  22841. C
  22842. C       = 0  No error.
  22843. C       = 1  M .LE. 2
  22844. C       = 2  N .LE. 2
  22845. C       = 3  IDIMY .LT. M
  22846. C       = 4  NPEROD .LT. 0 or NPEROD .GT. 4
  22847. C       = 5  MPEROD .LT. 0 or MPEROD .GT. 1
  22848. C       = 6  A(I) .NE. C(1) or C(I) .NE. C(1) or B(I) .NE. B(1) for
  22849. C            some I=1,2,...,M.
  22850. C       = 7  A(1) .NE. 0 or C(M) .NE. 0 and MPEROD = 1
  22851. C
  22852. C     W
  22853. C       W(1) contains the required length of W.
  22854. C
  22855. C *Long Description:
  22856. C
  22857. C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
  22858. C
  22859. C     Dimension of   A(M),B(M),C(M),Y(IDIMY,N),W(see parameter list)
  22860. C     Arguments
  22861. C
  22862. C     Latest         June 1979
  22863. C     Revision
  22864. C
  22865. C     Subprograms    CMGNBN,CMPOSD,CMPOSN,CMPOSP,CMPCSG,CMPMRG,
  22866. C     Required       CMPTRX,CMPTR3,PIMACH
  22867. C
  22868. C     Special        None
  22869. C     Conditions
  22870. C
  22871. C     Common         None
  22872. C     Blocks
  22873. C
  22874. C     I/O            None
  22875. C
  22876. C     Precision      Single
  22877. C
  22878. C     Specialist     Roland Sweet
  22879. C
  22880. C     Language       FORTRAN
  22881. C
  22882. C     History        Written by Roland Sweet at NCAR in June, 1977
  22883. C
  22884. C     Algorithm      The linear system is solved by a cyclic reduction
  22885. C                    algorithm described in the reference.
  22886. C
  22887. C     Space          4944(DECIMAL) = 11520(octal) locations on the NCAR
  22888. C     Required       Control Data 7600
  22889. C
  22890. C     Timing and      The execution time T on the NCAR Control Data
  22891. C     Accuracy       7600 for subroutine CMGNBN is roughly proportional
  22892. C                    to M*N*log2(N), but also depends on the input
  22893. C                    parameter NPEROD.  Some typical values are listed
  22894. C                    in the table below.
  22895. C                       To measure the accuracy of the algorithm a
  22896. C                    uniform random number generator was used to create
  22897. C                    a solution array X for the system given in the
  22898. C                    'PURPOSE' with
  22899. C
  22900. C                       A(I) = C(I) = -0.5*B(I) = 1,       I=1,2,...,M
  22901. C
  22902. C                    and, when MPEROD = 1
  22903. C
  22904. C                       A(1) = C(M) = 0
  22905. C                       A(M) = C(1) = 2.
  22906. C
  22907. C                    The solution X was substituted into the given sys-
  22908. C                    tem and a right side Y was computed.  Using this
  22909. C                    array Y subroutine CMGNBN was called to produce an
  22910. C                    approximate solution Z.  Then the relative error,
  22911. C                    defined as
  22912. C
  22913. C                       E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
  22914. C
  22915. C                    where the two maxima are taken over all I=1,2,...,M
  22916. C                    and J=1,2,...,N, was computed.  The value of E is
  22917. C                    given in the table below for some typical values of
  22918. C                    M and N.
  22919. C
  22920. C
  22921. C                       M (=N)    MPEROD    NPEROD    T(MSECS)    E
  22922. C                       ------    ------    ------    --------  ------
  22923. C
  22924. C                         31        0         0          77     1.E-12
  22925. C                         31        1         1          45     4.E-13
  22926. C                         31        1         3          91     2.E-12
  22927. C                         32        0         0          59     7.E-14
  22928. C                         32        1         1          65     5.E-13
  22929. C                         32        1         3          97     2.E-13
  22930. C                         33        0         0          80     6.E-13
  22931. C                         33        1         1          67     5.E-13
  22932. C                         33        1         3          76     3.E-12
  22933. C                         63        0         0         350     5.E-12
  22934. C                         63        1         1         215     6.E-13
  22935. C                         63        1         3         412     1.E-11
  22936. C                         64        0         0         264     1.E-13
  22937. C                         64        1         1         287     3.E-12
  22938. C                         64        1         3         421     3.E-13
  22939. C                         65        0         0         338     2.E-12
  22940. C                         65        1         1         292     5.E-13
  22941. C                         65        1         3         329     1.E-11
  22942. C
  22943. C     Portability    American National Standards Institute Fortran.
  22944. C                    The machine dependent constant PI is defined in
  22945. C                    function PIMACH.
  22946. C
  22947. C     Required       COS
  22948. C     Resident
  22949. C     Routines
  22950. C
  22951. C     Reference      Sweet, R., 'A Cyclic Reduction Algorithm for
  22952. C                    Solving Block Tridiagonal Systems Of Arbitrary
  22953. C                    Dimensions,' SIAM J. on Numer. Anal.,
  22954. C                    14(SEPT., 1977), PP. 706-720.
  22955. C
  22956. C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  22957. C
  22958. C***REFERENCES  R. Sweet, A cyclic reduction algorithm for solving
  22959. C                 block tridiagonal systems of arbitrary dimensions,
  22960. C                 SIAM Journal on Numerical Analysis 14, (September
  22961. C                 1977), pp. 706-720.
  22962. C***ROUTINES CALLED  CMPOSD, CMPOSN, CMPOSP
  22963. C***REVISION HISTORY  (YYMMDD)
  22964. C   801001  DATE WRITTEN
  22965. C   890531  Changed all specific intrinsics to generic.  (WRB)
  22966. C   890531  REVISION DATE from Version 3.2
  22967. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  22968. C   920501  Reformatted the REFERENCES section.  (WRB)
  22969. C***END PROLOGUE  CMGNBN
  22970. C
  22971. C
  22972.       COMPLEX         A          ,B          ,C          ,Y          ,
  22973.      1                W          ,A1
  22974.       DIMENSION       Y(IDIMY,*)
  22975.       DIMENSION       W(*)       ,B(*)       ,A(*)       ,C(*)
  22976. C***FIRST EXECUTABLE STATEMENT  CMGNBN
  22977.       IERROR = 0
  22978.       IF (M .LE. 2) IERROR = 1
  22979.       IF (N .LE. 2) IERROR = 2
  22980.       IF (IDIMY .LT. M) IERROR = 3
  22981.       IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4
  22982.       IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
  22983.       IF (MPEROD .EQ. 1) GO TO 102
  22984.       DO 101 I=2,M
  22985.          IF (ABS(A(I)-C(1)) .NE. 0.) GO TO 103
  22986.          IF (ABS(C(I)-C(1)) .NE. 0.) GO TO 103
  22987.          IF (ABS(B(I)-B(1)) .NE. 0.) GO TO 103
  22988.   101 CONTINUE
  22989.       GO TO 104
  22990.   102 IF (ABS(A(1)).NE.0. .AND. ABS(C(M)).NE.0.) IERROR = 7
  22991.       GO TO 104
  22992.   103 IERROR = 6
  22993.   104 IF (IERROR .NE. 0) RETURN
  22994.       IWBA = M+1
  22995.       IWBB = IWBA+M
  22996.       IWBC = IWBB+M
  22997.       IWB2 = IWBC+M
  22998.       IWB3 = IWB2+M
  22999.       IWW1 = IWB3+M
  23000.       IWW2 = IWW1+M
  23001.       IWW3 = IWW2+M
  23002.       IWD = IWW3+M
  23003.       IWTCOS = IWD+M
  23004.       IWP = IWTCOS+4*N
  23005.       DO 106 I=1,M
  23006.          K = IWBA+I-1
  23007.          W(K) = -A(I)
  23008.          K = IWBC+I-1
  23009.          W(K) = -C(I)
  23010.          K = IWBB+I-1
  23011.          W(K) = 2.-B(I)
  23012.          DO 105 J=1,N
  23013.             Y(I,J) = -Y(I,J)
  23014.   105    CONTINUE
  23015.   106 CONTINUE
  23016.       MP = MPEROD+1
  23017.       NP = NPEROD+1
  23018.       GO TO (114,107),MP
  23019.   107 GO TO (108,109,110,111,123),NP
  23020.   108 CALL CMPOSP (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
  23021.      1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
  23022.      2             W(IWP))
  23023.       GO TO 112
  23024.   109 CALL CMPOSD (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1),
  23025.      1             W(IWD),W(IWTCOS),W(IWP))
  23026.       GO TO 112
  23027.   110 CALL CMPOSN (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
  23028.      1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
  23029.      2             W(IWP))
  23030.       GO TO 112
  23031.   111 CALL CMPOSN (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
  23032.      1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
  23033.      2             W(IWP))
  23034.   112 IPSTOR = REAL(W(IWW1))
  23035.       IREV = 2
  23036.       IF (NPEROD .EQ. 4) GO TO 124
  23037.   113 GO TO (127,133),MP
  23038.   114 CONTINUE
  23039. C
  23040. C     REORDER UNKNOWNS WHEN MP =0
  23041. C
  23042.       MH = (M+1)/2
  23043.       MHM1 = MH-1
  23044.       MODD = 1
  23045.       IF (MH*2 .EQ. M) MODD = 2
  23046.       DO 119 J=1,N
  23047.          DO 115 I=1,MHM1
  23048.             MHPI = MH+I
  23049.             MHMI = MH-I
  23050.             W(I) = Y(MHMI,J)-Y(MHPI,J)
  23051.             W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  23052.   115    CONTINUE
  23053.          W(MH) = 2.*Y(MH,J)
  23054.          GO TO (117,116),MODD
  23055.   116    W(M) = 2.*Y(M,J)
  23056.   117    CONTINUE
  23057.          DO 118 I=1,M
  23058.             Y(I,J) = W(I)
  23059.   118    CONTINUE
  23060.   119 CONTINUE
  23061.       K = IWBC+MHM1-1
  23062.       I = IWBA+MHM1
  23063.       W(K) = (0.,0.)
  23064.       W(I) = (0.,0.)
  23065.       W(K+1) = 2.*W(K+1)
  23066.       GO TO (120,121),MODD
  23067.   120 CONTINUE
  23068.       K = IWBB+MHM1-1
  23069.       W(K) = W(K)-W(I-1)
  23070.       W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
  23071.       GO TO 122
  23072.   121 W(IWBB-1) = W(K+1)
  23073.   122 CONTINUE
  23074.       GO TO 107
  23075. C
  23076. C     REVERSE COLUMNS WHEN NPEROD = 4
  23077. C
  23078.   123 IREV = 1
  23079.       NBY2 = N/2
  23080.   124 DO 126 J=1,NBY2
  23081.          MSKIP = N+1-J
  23082.          DO 125 I=1,M
  23083.             A1 = Y(I,J)
  23084.             Y(I,J) = Y(I,MSKIP)
  23085.             Y(I,MSKIP) = A1
  23086.   125    CONTINUE
  23087.   126 CONTINUE
  23088.       GO TO (110,113),IREV
  23089.   127 CONTINUE
  23090.       DO 132 J=1,N
  23091.          DO 128 I=1,MHM1
  23092.             MHMI = MH-I
  23093.             MHPI = MH+I
  23094.             W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
  23095.             W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  23096.   128    CONTINUE
  23097.          W(MH) = .5*Y(MH,J)
  23098.          GO TO (130,129),MODD
  23099.   129    W(M) = .5*Y(M,J)
  23100.   130    CONTINUE
  23101.          DO 131 I=1,M
  23102.             Y(I,J) = W(I)
  23103.   131    CONTINUE
  23104.   132 CONTINUE
  23105.   133 CONTINUE
  23106. C
  23107. C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
  23108. C
  23109.       W(1) = CMPLX(REAL(IPSTOR+IWP-1),0.)
  23110.       RETURN
  23111.       END
  23112. *DECK CMPCSG
  23113.       SUBROUTINE CMPCSG (N, IJUMP, FNUM, FDEN, A)
  23114. C***BEGIN PROLOGUE  CMPCSG
  23115. C***SUBSIDIARY
  23116. C***PURPOSE  Subsidiary to CMGNBN
  23117. C***LIBRARY   SLATEC
  23118. C***TYPE      COMPLEX (COSGEN-S, CMPCSG-C)
  23119. C***AUTHOR  (UNKNOWN)
  23120. C***DESCRIPTION
  23121. C
  23122. C     This subroutine computes required cosine values in ascending
  23123. C     order.  When IJUMP .GT. 1 the routine computes values
  23124. C
  23125. C        2*COS(J*PI/L) , J=1,2,...,L and J .NE. 0(MOD N/IJUMP+1)
  23126. C
  23127. C     where L = IJUMP*(N/IJUMP+1).
  23128. C
  23129. C
  23130. C     when IJUMP = 1 it computes
  23131. C
  23132. C            2*COS((J-FNUM)*PI/(N+FDEN)) ,  J=1, 2, ... ,N
  23133. C
  23134. C     where
  23135. C        FNUM = 0.5, FDEN = 0.0,  for regular reduction values.
  23136. C        FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1
  23137. C        FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2
  23138. C        FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2
  23139. C                                in CMPOSN only.
  23140. C
  23141. C***SEE ALSO  CMGNBN
  23142. C***ROUTINES CALLED  PIMACH
  23143. C***REVISION HISTORY  (YYMMDD)
  23144. C   801001  DATE WRITTEN
  23145. C   890531  Changed all specific intrinsics to generic.  (WRB)
  23146. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  23147. C   900402  Added TYPE section.  (WRB)
  23148. C***END PROLOGUE  CMPCSG
  23149.       COMPLEX         A
  23150.       DIMENSION       A(*)
  23151. C
  23152. C
  23153. C***FIRST EXECUTABLE STATEMENT  CMPCSG
  23154.       PI = PIMACH(DUM)
  23155.       IF (N .EQ. 0) GO TO 105
  23156.       IF (IJUMP .EQ. 1) GO TO 103
  23157.       K3 = N/IJUMP+1
  23158.       K4 = K3-1
  23159.       PIBYN = PI/(N+IJUMP)
  23160.       DO 102 K=1,IJUMP
  23161.          K1 = (K-1)*K3
  23162.          K5 = (K-1)*K4
  23163.          DO 101 I=1,K4
  23164.             X = K1+I
  23165.             K2 = K5+I
  23166.             A(K2) = CMPLX(-2.*COS(X*PIBYN),0.)
  23167.   101    CONTINUE
  23168.   102 CONTINUE
  23169.       GO TO 105
  23170.   103 CONTINUE
  23171.       NP1 = N+1
  23172.       Y = PI/(N+FDEN)
  23173.       DO 104 I=1,N
  23174.          X = NP1-I-FNUM
  23175.          A(I) = CMPLX(2.*COS(X*Y),0.)
  23176.   104 CONTINUE
  23177.   105 CONTINUE
  23178.       RETURN
  23179.       END
  23180. *DECK CMPOSD
  23181.       SUBROUTINE CMPOSD (MR, NR, ISTAG, BA, BB, BC, Q, IDIMQ, B, W, D,
  23182.      +   TCOS, P)
  23183. C***BEGIN PROLOGUE  CMPOSD
  23184. C***SUBSIDIARY
  23185. C***PURPOSE  Subsidiary to CMGNBN
  23186. C***LIBRARY   SLATEC
  23187. C***TYPE      COMPLEX (POISD2-S, CMPOSD-C)
  23188. C***AUTHOR  (UNKNOWN)
  23189. C***DESCRIPTION
  23190. C
  23191. C     Subroutine to solve Poisson's equation for Dirichlet boundary
  23192. C     conditions.
  23193. C
  23194. C     ISTAG = 1 if the last diagonal block is the matrix A.
  23195. C     ISTAG = 2 if the last diagonal block is the matrix A+I.
  23196. C
  23197. C***SEE ALSO  CMGNBN
  23198. C***ROUTINES CALLED  C1MERG, CMPCSG, CMPTRX
  23199. C***REVISION HISTORY  (YYMMDD)
  23200. C   801001  DATE WRITTEN
  23201. C   890531  Changed all specific intrinsics to generic.  (WRB)
  23202. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  23203. C   900402  Added TYPE section.  (WRB)
  23204. C   920130  Modified to use merge routine C1MERG rather than deleted
  23205. C           routine CMPMRG.  (WRB)
  23206. C***END PROLOGUE  CMPOSD
  23207. C
  23208.       COMPLEX         BA         ,BB         ,BC         ,Q          ,
  23209.      1                B          ,W          ,D          ,TCOS       ,
  23210.      2                P          ,T
  23211.       DIMENSION       Q(IDIMQ,*) ,BA(*)      ,BB(*)      ,BC(*)      ,
  23212.      1                TCOS(*)    ,B(*)       ,D(*)       ,W(*)       ,
  23213.      2                P(*)
  23214. C***FIRST EXECUTABLE STATEMENT  CMPOSD
  23215.       M = MR
  23216.       N = NR
  23217.       FI = 1./ISTAG
  23218.       IP = -M
  23219.       IPSTOR = 0
  23220.       JSH = 0
  23221.       GO TO (101,102),ISTAG
  23222.   101 KR = 0
  23223.       IRREG = 1
  23224.       IF (N .GT. 1) GO TO 106
  23225.       TCOS(1) = (0.,0.)
  23226.       GO TO 103
  23227.   102 KR = 1
  23228.       JSTSAV = 1
  23229.       IRREG = 2
  23230.       IF (N .GT. 1) GO TO 106
  23231.       TCOS(1) = CMPLX(-1.,0.)
  23232.   103 DO 104 I=1,M
  23233.          B(I) = Q(I,1)
  23234.   104 CONTINUE
  23235.       CALL CMPTRX (1,0,M,BA,BB,BC,B,TCOS,D,W)
  23236.       DO 105 I=1,M
  23237.          Q(I,1) = B(I)
  23238.   105 CONTINUE
  23239.       GO TO 183
  23240.   106 LR = 0
  23241.       DO 107 I=1,M
  23242.          P(I) = CMPLX(0.,0.)
  23243.   107 CONTINUE
  23244.       NUN = N
  23245.       JST = 1
  23246.       JSP = N
  23247. C
  23248. C     IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2.
  23249. C
  23250.   108 L = 2*JST
  23251.       NODD = 2-2*((NUN+1)/2)+NUN
  23252. C
  23253. C     NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2.
  23254. C
  23255.       GO TO (110,109),NODD
  23256.   109 JSP = JSP-L
  23257.       GO TO 111
  23258.   110 JSP = JSP-JST
  23259.       IF (IRREG .NE. 1) JSP = JSP-L
  23260.   111 CONTINUE
  23261. C
  23262. C     REGULAR REDUCTION
  23263. C
  23264.       CALL CMPCSG (JST,1,0.5,0.0,TCOS)
  23265.       IF (L .GT. JSP) GO TO 118
  23266.       DO 117 J=L,JSP,L
  23267.          JM1 = J-JSH
  23268.          JP1 = J+JSH
  23269.          JM2 = J-JST
  23270.          JP2 = J+JST
  23271.          JM3 = JM2-JSH
  23272.          JP3 = JP2+JSH
  23273.          IF (JST .NE. 1) GO TO 113
  23274.          DO 112 I=1,M
  23275.             B(I) = 2.*Q(I,J)
  23276.             Q(I,J) = Q(I,JM2)+Q(I,JP2)
  23277.   112    CONTINUE
  23278.          GO TO 115
  23279.   113    DO 114 I=1,M
  23280.             T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2)
  23281.             B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3)
  23282.             Q(I,J) = T
  23283.   114    CONTINUE
  23284.   115    CONTINUE
  23285.          CALL CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W)
  23286.          DO 116 I=1,M
  23287.             Q(I,J) = Q(I,J)+B(I)
  23288.   116    CONTINUE
  23289.   117 CONTINUE
  23290. C
  23291. C     REDUCTION FOR LAST UNKNOWN
  23292. C
  23293.   118 GO TO (119,136),NODD
  23294.   119 GO TO (152,120),IRREG
  23295. C
  23296. C     ODD NUMBER OF UNKNOWNS
  23297. C
  23298.   120 JSP = JSP+L
  23299.       J = JSP
  23300.       JM1 = J-JSH
  23301.       JP1 = J+JSH
  23302.       JM2 = J-JST
  23303.       JP2 = J+JST
  23304.       JM3 = JM2-JSH
  23305.       GO TO (123,121),ISTAG
  23306.   121 CONTINUE
  23307.       IF (JST .NE. 1) GO TO 123
  23308.       DO 122 I=1,M
  23309.          B(I) = Q(I,J)
  23310.          Q(I,J) = CMPLX(0.,0.)
  23311.   122 CONTINUE
  23312.       GO TO 130
  23313.   123 GO TO (124,126),NODDPR
  23314.   124 DO 125 I=1,M
  23315.          IP1 = IP+I
  23316.          B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J)
  23317.   125 CONTINUE
  23318.       GO TO 128
  23319.   126 DO 127 I=1,M
  23320.          B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J)
  23321.   127 CONTINUE
  23322.   128 DO 129 I=1,M
  23323.          Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  23324.   129 CONTINUE
  23325.   130 CALL CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W)
  23326.       IP = IP+M
  23327.       IPSTOR = MAX(IPSTOR,IP+M)
  23328.       DO 131 I=1,M
  23329.          IP1 = IP+I
  23330.          P(IP1) = Q(I,J)+B(I)
  23331.          B(I) = Q(I,JP2)+P(IP1)
  23332.   131 CONTINUE
  23333.       IF (LR .NE. 0) GO TO 133
  23334.       DO 132 I=1,JST
  23335.          KRPI = KR+I
  23336.          TCOS(KRPI) = TCOS(I)
  23337.   132 CONTINUE
  23338.       GO TO 134
  23339.   133 CONTINUE
  23340.       CALL CMPCSG (LR,JSTSAV,0.,FI,TCOS(JST+1))
  23341.       CALL C1MERG (TCOS,0,JST,JST,LR,KR)
  23342.   134 CONTINUE
  23343.       CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS)
  23344.       CALL CMPTRX (KR,KR,M,BA,BB,BC,B,TCOS,D,W)
  23345.       DO 135 I=1,M
  23346.          IP1 = IP+I
  23347.          Q(I,J) = Q(I,JM2)+B(I)+P(IP1)
  23348.   135 CONTINUE
  23349.       LR = KR
  23350.       KR = KR+L
  23351.       GO TO 152
  23352. C
  23353. C     EVEN NUMBER OF UNKNOWNS
  23354. C
  23355.   136 JSP = JSP+L
  23356.       J = JSP
  23357.       JM1 = J-JSH
  23358.       JP1 = J+JSH
  23359.       JM2 = J-JST
  23360.       JP2 = J+JST
  23361.       JM3 = JM2-JSH
  23362.       GO TO (137,138),IRREG
  23363.   137 CONTINUE
  23364.       JSTSAV = JST
  23365.       IDEG = JST
  23366.       KR = L
  23367.       GO TO 139
  23368.   138 CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS)
  23369.       CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1))
  23370.       IDEG = KR
  23371.       KR = KR+JST
  23372.   139 IF (JST .NE. 1) GO TO 141
  23373.       IRREG = 2
  23374.       DO 140 I=1,M
  23375.          B(I) = Q(I,J)
  23376.          Q(I,J) = Q(I,JM2)
  23377.   140 CONTINUE
  23378.       GO TO 150
  23379.   141 DO 142 I=1,M
  23380.          B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  23381.   142 CONTINUE
  23382.       GO TO (143,145),IRREG
  23383.   143 DO 144 I=1,M
  23384.          Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  23385.   144 CONTINUE
  23386.       IRREG = 2
  23387.       GO TO 150
  23388.   145 CONTINUE
  23389.       GO TO (146,148),NODDPR
  23390.   146 DO 147 I=1,M
  23391.          IP1 = IP+I
  23392.          Q(I,J) = Q(I,JM2)+P(IP1)
  23393.   147 CONTINUE
  23394.       IP = IP-M
  23395.       GO TO 150
  23396.   148 DO 149 I=1,M
  23397.          Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1)
  23398.   149 CONTINUE
  23399.   150 CALL CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W)
  23400.       DO 151 I=1,M
  23401.          Q(I,J) = Q(I,J)+B(I)
  23402.   151 CONTINUE
  23403.   152 NUN = NUN/2
  23404.       NODDPR = NODD
  23405.       JSH = JST
  23406.       JST = 2*JST
  23407.       IF (NUN .GE. 2) GO TO 108
  23408. C
  23409. C     START SOLUTION.
  23410. C
  23411.       J = JSP
  23412.       DO 153 I=1,M
  23413.          B(I) = Q(I,J)
  23414.   153 CONTINUE
  23415.       GO TO (154,155),IRREG
  23416.   154 CONTINUE
  23417.       CALL CMPCSG (JST,1,0.5,0.0,TCOS)
  23418.       IDEG = JST
  23419.       GO TO 156
  23420.   155 KR = LR+JST
  23421.       CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS)
  23422.       CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1))
  23423.       IDEG = KR
  23424.   156 CONTINUE
  23425.       CALL CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W)
  23426.       JM1 = J-JSH
  23427.       JP1 = J+JSH
  23428.       GO TO (157,159),IRREG
  23429.   157 DO 158 I=1,M
  23430.          Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
  23431.   158 CONTINUE
  23432.       GO TO 164
  23433.   159 GO TO (160,162),NODDPR
  23434.   160 DO 161 I=1,M
  23435.          IP1 = IP+I
  23436.          Q(I,J) = P(IP1)+B(I)
  23437.   161 CONTINUE
  23438.       IP = IP-M
  23439.       GO TO 164
  23440.   162 DO 163 I=1,M
  23441.          Q(I,J) = Q(I,J)-Q(I,JM1)+B(I)
  23442.   163 CONTINUE
  23443.   164 CONTINUE
  23444. C
  23445. C     START BACK SUBSTITUTION.
  23446. C
  23447.       JST = JST/2
  23448.       JSH = JST/2
  23449.       NUN = 2*NUN
  23450.       IF (NUN .GT. N) GO TO 183
  23451.       DO 182 J=JST,N,L
  23452.          JM1 = J-JSH
  23453.          JP1 = J+JSH
  23454.          JM2 = J-JST
  23455.          JP2 = J+JST
  23456.          IF (J .GT. JST) GO TO 166
  23457.          DO 165 I=1,M
  23458.             B(I) = Q(I,J)+Q(I,JP2)
  23459.   165    CONTINUE
  23460.          GO TO 170
  23461.   166    IF (JP2 .LE. N) GO TO 168
  23462.          DO 167 I=1,M
  23463.             B(I) = Q(I,J)+Q(I,JM2)
  23464.   167    CONTINUE
  23465.          IF (JST .LT. JSTSAV) IRREG = 1
  23466.          GO TO (170,171),IRREG
  23467.   168    DO 169 I=1,M
  23468.             B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2)
  23469.   169    CONTINUE
  23470.   170    CONTINUE
  23471.          CALL CMPCSG (JST,1,0.5,0.0,TCOS)
  23472.          IDEG = JST
  23473.          JDEG = 0
  23474.          GO TO 172
  23475.   171    IF (J+L .GT. N) LR = LR-JST
  23476.          KR = JST+LR
  23477.          CALL CMPCSG (KR,JSTSAV,0.0,FI,TCOS)
  23478.          CALL CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1))
  23479.          IDEG = KR
  23480.          JDEG = LR
  23481.   172    CONTINUE
  23482.          CALL CMPTRX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W)
  23483.          IF (JST .GT. 1) GO TO 174
  23484.          DO 173 I=1,M
  23485.             Q(I,J) = B(I)
  23486.   173    CONTINUE
  23487.          GO TO 182
  23488.   174    IF (JP2 .GT. N) GO TO 177
  23489.   175    DO 176 I=1,M
  23490.             Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
  23491.   176    CONTINUE
  23492.          GO TO 182
  23493.   177    GO TO (175,178),IRREG
  23494.   178    IF (J+JSH .GT. N) GO TO 180
  23495.          DO 179 I=1,M
  23496.             IP1 = IP+I
  23497.             Q(I,J) = B(I)+P(IP1)
  23498.   179    CONTINUE
  23499.          IP = IP-M
  23500.          GO TO 182
  23501.   180    DO 181 I=1,M
  23502.             Q(I,J) = B(I)+Q(I,J)-Q(I,JM1)
  23503.   181    CONTINUE
  23504.   182 CONTINUE
  23505.       L = L/2
  23506.       GO TO 164
  23507.   183 CONTINUE
  23508. C
  23509. C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
  23510. C
  23511.       W(1) = CMPLX(REAL(IPSTOR),0.)
  23512.       RETURN
  23513.       END
  23514. *DECK CMPOSN
  23515.       SUBROUTINE CMPOSN (M, N, ISTAG, MIXBND, A, BB, C, Q, IDIMQ, B, B2,
  23516.      +   B3, W, W2, W3, D, TCOS, P)
  23517. C***BEGIN PROLOGUE  CMPOSN
  23518. C***SUBSIDIARY
  23519. C***PURPOSE  Subsidiary to CMGNBN
  23520. C***LIBRARY   SLATEC
  23521. C***TYPE      COMPLEX (POISN2-S, CMPOSN-C)
  23522. C***AUTHOR  (UNKNOWN)
  23523. C***DESCRIPTION
  23524. C
  23525. C     Subroutine to solve Poisson's equation with Neumann boundary
  23526. C     conditions.
  23527. C
  23528. C     ISTAG = 1 if the last diagonal block is A.
  23529. C     ISTAG = 2 if the last diagonal block is A-I.
  23530. C     MIXBND = 1 if have Neumann boundary conditions at both boundaries.
  23531. C     MIXBND = 2 if have Neumann boundary conditions at bottom and
  23532. C     Dirichlet condition at top.  (For this case, must have ISTAG = 1)
  23533. C
  23534. C***SEE ALSO  CMGNBN
  23535. C***ROUTINES CALLED  C1MERG, CMPCSG, CMPTR3, CMPTRX
  23536. C***REVISION HISTORY  (YYMMDD)
  23537. C   801001  DATE WRITTEN
  23538. C   890531  Changed all specific intrinsics to generic.  (WRB)
  23539. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  23540. C   900402  Added TYPE section.  (WRB)
  23541. C   920130  Modified to use merge routine C1MERG rather than deleted
  23542. C           routine CMPMRG.  (WRB)
  23543. C***END PROLOGUE  CMPOSN
  23544. C
  23545.       COMPLEX         A          ,BB         ,C          ,Q          ,
  23546.      1                B          ,B2         ,B3         ,W          ,
  23547.      2                W2         ,W3         ,D          ,TCOS       ,
  23548.      3                P          ,FI         ,T
  23549.       DIMENSION       A(*)       ,BB(*)      ,C(*)       ,Q(IDIMQ,*) ,
  23550.      1                B(*)       ,B2(*)      ,B3(*)      ,W(*)       ,
  23551.      2                W2(*)      ,W3(*)      ,D(*)       ,TCOS(*)    ,
  23552.      3                K(4)       ,P(*)
  23553.       EQUIVALENCE     (K(1),K1)  ,(K(2),K2)  ,(K(3),K3)  ,(K(4),K4)
  23554. C***FIRST EXECUTABLE STATEMENT  CMPOSN
  23555.       FISTAG = 3-ISTAG
  23556.       FNUM = 1./ISTAG
  23557.       FDEN = 0.5*(ISTAG-1)
  23558.       MR = M
  23559.       IP = -MR
  23560.       IPSTOR = 0
  23561.       I2R = 1
  23562.       JR = 2
  23563.       NR = N
  23564.       NLAST = N
  23565.       KR = 1
  23566.       LR = 0
  23567.       GO TO (101,103),ISTAG
  23568.   101 CONTINUE
  23569.       DO 102 I=1,MR
  23570.          Q(I,N) = .5*Q(I,N)
  23571.   102 CONTINUE
  23572.       GO TO (103,104),MIXBND
  23573.   103 IF (N .LE. 3) GO TO 155
  23574.   104 CONTINUE
  23575.       JR = 2*I2R
  23576.       NROD = 1
  23577.       IF ((NR/2)*2 .EQ. NR) NROD = 0
  23578.       GO TO (105,106),MIXBND
  23579.   105 JSTART = 1
  23580.       GO TO 107
  23581.   106 JSTART = JR
  23582.       NROD = 1-NROD
  23583.   107 CONTINUE
  23584.       JSTOP = NLAST-JR
  23585.       IF (NROD .EQ. 0) JSTOP = JSTOP-I2R
  23586.       CALL CMPCSG (I2R,1,0.5,0.0,TCOS)
  23587.       I2RBY2 = I2R/2
  23588.       IF (JSTOP .GE. JSTART) GO TO 108
  23589.       J = JR
  23590.       GO TO 116
  23591.   108 CONTINUE
  23592. C
  23593. C     REGULAR REDUCTION.
  23594. C
  23595.       DO 115 J=JSTART,JSTOP,JR
  23596.          JP1 = J+I2RBY2
  23597.          JP2 = J+I2R
  23598.          JP3 = JP2+I2RBY2
  23599.          JM1 = J-I2RBY2
  23600.          JM2 = J-I2R
  23601.          JM3 = JM2-I2RBY2
  23602.          IF (J .NE. 1) GO TO 109
  23603.          JM1 = JP1
  23604.          JM2 = JP2
  23605.          JM3 = JP3
  23606.   109    CONTINUE
  23607.          IF (I2R .NE. 1) GO TO 111
  23608.          IF (J .EQ. 1) JM2 = JP2
  23609.          DO 110 I=1,MR
  23610.             B(I) = 2.*Q(I,J)
  23611.             Q(I,J) = Q(I,JM2)+Q(I,JP2)
  23612.   110    CONTINUE
  23613.          GO TO 113
  23614.   111    CONTINUE
  23615.          DO 112 I=1,MR
  23616.             FI = Q(I,J)
  23617.             Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2)
  23618.             B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3)
  23619.   112    CONTINUE
  23620.   113    CONTINUE
  23621.          CALL CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
  23622.          DO 114 I=1,MR
  23623.             Q(I,J) = Q(I,J)+B(I)
  23624.   114    CONTINUE
  23625. C
  23626. C     END OF REDUCTION FOR REGULAR UNKNOWNS.
  23627. C
  23628.   115 CONTINUE
  23629. C
  23630. C     BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN.
  23631. C
  23632.       J = JSTOP+JR
  23633.   116 NLAST = J
  23634.       JM1 = J-I2RBY2
  23635.       JM2 = J-I2R
  23636.       JM3 = JM2-I2RBY2
  23637.       IF (NROD .EQ. 0) GO TO 128
  23638. C
  23639. C     ODD NUMBER OF UNKNOWNS
  23640. C
  23641.       IF (I2R .NE. 1) GO TO 118
  23642.       DO 117 I=1,MR
  23643.          B(I) = FISTAG*Q(I,J)
  23644.          Q(I,J) = Q(I,JM2)
  23645.   117 CONTINUE
  23646.       GO TO 126
  23647.   118 DO 119 I=1,MR
  23648.          B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  23649.   119 CONTINUE
  23650.       IF (NRODPR .NE. 0) GO TO 121
  23651.       DO 120 I=1,MR
  23652.          II = IP+I
  23653.          Q(I,J) = Q(I,JM2)+P(II)
  23654.   120 CONTINUE
  23655.       IP = IP-MR
  23656.       GO TO 123
  23657.   121 CONTINUE
  23658.       DO 122 I=1,MR
  23659.          Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2)
  23660.   122 CONTINUE
  23661.   123 IF (LR .EQ. 0) GO TO 124
  23662.       CALL CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1))
  23663.       GO TO 126
  23664.   124 CONTINUE
  23665.       DO 125 I=1,MR
  23666.          B(I) = FISTAG*B(I)
  23667.   125 CONTINUE
  23668.   126 CONTINUE
  23669.       CALL CMPCSG (KR,1,0.5,FDEN,TCOS)
  23670.       CALL CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
  23671.       DO 127 I=1,MR
  23672.          Q(I,J) = Q(I,J)+B(I)
  23673.   127 CONTINUE
  23674.       KR = KR+I2R
  23675.       GO TO 151
  23676.   128 CONTINUE
  23677. C
  23678. C     EVEN NUMBER OF UNKNOWNS
  23679. C
  23680.       JP1 = J+I2RBY2
  23681.       JP2 = J+I2R
  23682.       IF (I2R .NE. 1) GO TO 135
  23683.       DO 129 I=1,MR
  23684.          B(I) = Q(I,J)
  23685.   129 CONTINUE
  23686.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23687.       IP = 0
  23688.       IPSTOR = MR
  23689.       GO TO (133,130),ISTAG
  23690.   130 DO 131 I=1,MR
  23691.          P(I) = B(I)
  23692.          B(I) = B(I)+Q(I,N)
  23693.   131 CONTINUE
  23694.       TCOS(1) = CMPLX(1.,0.)
  23695.       TCOS(2) = CMPLX(0.,0.)
  23696.       CALL CMPTRX (1,1,MR,A,BB,C,B,TCOS,D,W)
  23697.       DO 132 I=1,MR
  23698.          Q(I,J) = Q(I,JM2)+P(I)+B(I)
  23699.   132 CONTINUE
  23700.       GO TO 150
  23701.   133 CONTINUE
  23702.       DO 134 I=1,MR
  23703.          P(I) = B(I)
  23704.          Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I)
  23705.   134 CONTINUE
  23706.       GO TO 150
  23707.   135 CONTINUE
  23708.       DO 136 I=1,MR
  23709.          B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  23710.   136 CONTINUE
  23711.       IF (NRODPR .NE. 0) GO TO 138
  23712.       DO 137 I=1,MR
  23713.          II = IP+I
  23714.          B(I) = B(I)+P(II)
  23715.   137 CONTINUE
  23716.       GO TO 140
  23717.   138 CONTINUE
  23718.       DO 139 I=1,MR
  23719.          B(I) = B(I)+Q(I,JP2)-Q(I,JP1)
  23720.   139 CONTINUE
  23721.   140 CONTINUE
  23722.       CALL CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
  23723.       IP = IP+MR
  23724.       IPSTOR = MAX(IPSTOR,IP+MR)
  23725.       DO 141 I=1,MR
  23726.          II = IP+I
  23727.          P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  23728.          B(I) = P(II)+Q(I,JP2)
  23729.   141 CONTINUE
  23730.       IF (LR .EQ. 0) GO TO 142
  23731.       CALL CMPCSG (LR,1,0.5,FDEN,TCOS(I2R+1))
  23732.       CALL C1MERG (TCOS,0,I2R,I2R,LR,KR)
  23733.       GO TO 144
  23734.   142 DO 143 I=1,I2R
  23735.          II = KR+I
  23736.          TCOS(II) = TCOS(I)
  23737.   143 CONTINUE
  23738.   144 CALL CMPCSG (KR,1,0.5,FDEN,TCOS)
  23739.       IF (LR .NE. 0) GO TO 145
  23740.       GO TO (146,145),ISTAG
  23741.   145 CONTINUE
  23742.       CALL CMPTRX (KR,KR,MR,A,BB,C,B,TCOS,D,W)
  23743.       GO TO 148
  23744.   146 CONTINUE
  23745.       DO 147 I=1,MR
  23746.          B(I) = FISTAG*B(I)
  23747.   147 CONTINUE
  23748.   148 CONTINUE
  23749.       DO 149 I=1,MR
  23750.          II = IP+I
  23751.          Q(I,J) = Q(I,JM2)+P(II)+B(I)
  23752.   149 CONTINUE
  23753.   150 CONTINUE
  23754.       LR = KR
  23755.       KR = KR+JR
  23756.   151 CONTINUE
  23757.       GO TO (152,153),MIXBND
  23758.   152 NR = (NLAST-1)/JR+1
  23759.       IF (NR .LE. 3) GO TO 155
  23760.       GO TO 154
  23761.   153 NR = NLAST/JR
  23762.       IF (NR .LE. 1) GO TO 192
  23763.   154 I2R = JR
  23764.       NRODPR = NROD
  23765.       GO TO 104
  23766.   155 CONTINUE
  23767. C
  23768. C      BEGIN SOLUTION
  23769. C
  23770.       J = 1+JR
  23771.       JM1 = J-I2R
  23772.       JP1 = J+I2R
  23773.       JM2 = NLAST-I2R
  23774.       IF (NR .EQ. 2) GO TO 184
  23775.       IF (LR .NE. 0) GO TO 170
  23776.       IF (N .NE. 3) GO TO 161
  23777. C
  23778. C     CASE N = 3.
  23779. C
  23780.       GO TO (156,168),ISTAG
  23781.   156 CONTINUE
  23782.       DO 157 I=1,MR
  23783.          B(I) = Q(I,2)
  23784.   157 CONTINUE
  23785.       TCOS(1) = CMPLX(0.,0.)
  23786.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23787.       DO 158 I=1,MR
  23788.          Q(I,2) = B(I)
  23789.          B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3)
  23790.   158 CONTINUE
  23791.       TCOS(1) = CMPLX(-2.,0.)
  23792.       TCOS(2) = CMPLX(2.,0.)
  23793.       I1 = 2
  23794.       I2 = 0
  23795.       CALL CMPTRX (I1,I2,MR,A,BB,C,B,TCOS,D,W)
  23796.       DO 159 I=1,MR
  23797.          Q(I,2) = Q(I,2)+B(I)
  23798.          B(I) = Q(I,1)+2.*Q(I,2)
  23799.   159 CONTINUE
  23800.       TCOS(1) = (0.,0.)
  23801.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23802.       DO 160 I=1,MR
  23803.          Q(I,1) = B(I)
  23804.   160 CONTINUE
  23805.       JR = 1
  23806.       I2R = 0
  23807.       GO TO 194
  23808. C
  23809. C     CASE N = 2**P+1
  23810. C
  23811.   161 CONTINUE
  23812.       GO TO (162,170),ISTAG
  23813.   162 CONTINUE
  23814.       DO 163 I=1,MR
  23815.          B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2)
  23816.   163 CONTINUE
  23817.       CALL CMPCSG (JR,1,0.5,0.0,TCOS)
  23818.       CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W)
  23819.       DO 164 I=1,MR
  23820.          Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
  23821.          B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J)
  23822.   164 CONTINUE
  23823.       JR2 = 2*JR
  23824.       CALL CMPCSG (JR,1,0.0,0.0,TCOS)
  23825.       DO 165 I=1,JR
  23826.          I1 = JR+I
  23827.          I2 = JR+1-I
  23828.          TCOS(I1) = -TCOS(I2)
  23829.   165 CONTINUE
  23830.       CALL CMPTRX (JR2,0,MR,A,BB,C,B,TCOS,D,W)
  23831.       DO 166 I=1,MR
  23832.          Q(I,J) = Q(I,J)+B(I)
  23833.          B(I) = Q(I,1)+2.*Q(I,J)
  23834.   166 CONTINUE
  23835.       CALL CMPCSG (JR,1,0.5,0.0,TCOS)
  23836.       CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W)
  23837.       DO 167 I=1,MR
  23838.          Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I)
  23839.   167 CONTINUE
  23840.       GO TO 194
  23841. C
  23842. C     CASE OF GENERAL N WITH NR = 3 .
  23843. C
  23844.   168 DO 169 I=1,MR
  23845.          B(I) = Q(I,2)
  23846.          Q(I,2) = (0.,0.)
  23847.          B2(I) = Q(I,3)
  23848.          B3(I) = Q(I,1)
  23849.   169 CONTINUE
  23850.       JR = 1
  23851.       I2R = 0
  23852.       J = 2
  23853.       GO TO 177
  23854.   170 CONTINUE
  23855.       DO 171 I=1,MR
  23856.          B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J)
  23857.   171 CONTINUE
  23858.       IF (NROD .NE. 0) GO TO 173
  23859.       DO 172 I=1,MR
  23860.          II = IP+I
  23861.          B(I) = B(I)+P(II)
  23862.   172 CONTINUE
  23863.       GO TO 175
  23864.   173 DO 174 I=1,MR
  23865.          B(I) = B(I)+Q(I,NLAST)-Q(I,JM2)
  23866.   174 CONTINUE
  23867.   175 CONTINUE
  23868.       DO 176 I=1,MR
  23869.          T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  23870.          Q(I,J) = T
  23871.          B2(I) = Q(I,NLAST)+T
  23872.          B3(I) = Q(I,1)+2.*T
  23873.   176 CONTINUE
  23874.   177 CONTINUE
  23875.       K1 = KR+2*JR-1
  23876.       K2 = KR+JR
  23877.       TCOS(K1+1) = (-2.,0.)
  23878.       K4 = K1+3-ISTAG
  23879.       CALL CMPCSG (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4))
  23880.       K4 = K1+K2+1
  23881.       CALL CMPCSG (JR-1,1,0.0,1.0,TCOS(K4))
  23882.       CALL C1MERG (TCOS,K1,K2,K1+K2,JR-1,0)
  23883.       K3 = K1+K2+LR
  23884.       CALL CMPCSG (JR,1,0.5,0.0,TCOS(K3+1))
  23885.       K4 = K3+JR+1
  23886.       CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K4))
  23887.       CALL C1MERG (TCOS,K3,JR,K3+JR,KR,K1)
  23888.       IF (LR .EQ. 0) GO TO 178
  23889.       CALL CMPCSG (LR,1,0.5,FDEN,TCOS(K4))
  23890.       CALL C1MERG (TCOS,K3,JR,K3+JR,LR,K3-LR)
  23891.       CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K4))
  23892.   178 K3 = KR
  23893.       K4 = KR
  23894.       CALL CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
  23895.       DO 179 I=1,MR
  23896.          B(I) = B(I)+B2(I)+B3(I)
  23897.   179 CONTINUE
  23898.       TCOS(1) = (2.,0.)
  23899.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23900.       DO 180 I=1,MR
  23901.          Q(I,J) = Q(I,J)+B(I)
  23902.          B(I) = Q(I,1)+2.*Q(I,J)
  23903.   180 CONTINUE
  23904.       CALL CMPCSG (JR,1,0.5,0.0,TCOS)
  23905.       CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W)
  23906.       IF (JR .NE. 1) GO TO 182
  23907.       DO 181 I=1,MR
  23908.          Q(I,1) = B(I)
  23909.   181 CONTINUE
  23910.       GO TO 194
  23911.   182 CONTINUE
  23912.       DO 183 I=1,MR
  23913.          Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I)
  23914.   183 CONTINUE
  23915.       GO TO 194
  23916.   184 CONTINUE
  23917.       IF (N .NE. 2) GO TO 188
  23918. C
  23919. C     CASE  N = 2
  23920. C
  23921.       DO 185 I=1,MR
  23922.          B(I) = Q(I,1)
  23923.   185 CONTINUE
  23924.       TCOS(1) = (0.,0.)
  23925.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23926.       DO 186 I=1,MR
  23927.          Q(I,1) = B(I)
  23928.          B(I) = 2.*(Q(I,2)+B(I))*FISTAG
  23929.   186 CONTINUE
  23930.       TCOS(1) = CMPLX(-FISTAG,0.)
  23931.       TCOS(2) = CMPLX(2.,0.)
  23932.       CALL CMPTRX (2,0,MR,A,BB,C,B,TCOS,D,W)
  23933.       DO 187 I=1,MR
  23934.          Q(I,1) = Q(I,1)+B(I)
  23935.   187 CONTINUE
  23936.       JR = 1
  23937.       I2R = 0
  23938.       GO TO 194
  23939.   188 CONTINUE
  23940. C
  23941. C     CASE OF GENERAL N AND NR = 2 .
  23942. C
  23943.       DO 189 I=1,MR
  23944.          II = IP+I
  23945.          B3(I) = (0.,0.)
  23946.          B(I) = Q(I,1)+2.*P(II)
  23947.          Q(I,1) = .5*Q(I,1)-Q(I,JM1)
  23948.          B2(I) = 2.*(Q(I,1)+Q(I,NLAST))
  23949.   189 CONTINUE
  23950.       K1 = KR+JR-1
  23951.       TCOS(K1+1) = (-2.,0.)
  23952.       K4 = K1+3-ISTAG
  23953.       CALL CMPCSG (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4))
  23954.       K4 = K1+KR+1
  23955.       CALL CMPCSG (JR-1,1,0.0,1.0,TCOS(K4))
  23956.       CALL C1MERG (TCOS,K1,KR,K1+KR,JR-1,0)
  23957.       CALL CMPCSG (KR,1,0.5,FDEN,TCOS(K1+1))
  23958.       K2 = KR
  23959.       K4 = K1+K2+1
  23960.       CALL CMPCSG (LR,1,0.5,FDEN,TCOS(K4))
  23961.       K3 = LR
  23962.       K4 = 0
  23963.       CALL CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
  23964.       DO 190 I=1,MR
  23965.          B(I) = B(I)+B2(I)
  23966.   190 CONTINUE
  23967.       TCOS(1) = (2.,0.)
  23968.       CALL CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W)
  23969.       DO 191 I=1,MR
  23970.          Q(I,1) = Q(I,1)+B(I)
  23971.   191 CONTINUE
  23972.       GO TO 194
  23973.   192 DO 193 I=1,MR
  23974.          B(I) = Q(I,NLAST)
  23975.   193 CONTINUE
  23976.       GO TO 196
  23977.   194 CONTINUE
  23978. C
  23979. C     START BACK SUBSTITUTION.
  23980. C
  23981.       J = NLAST-JR
  23982.       DO 195 I=1,MR
  23983.          B(I) = Q(I,NLAST)+Q(I,J)
  23984.   195 CONTINUE
  23985.   196 JM2 = NLAST-I2R
  23986.       IF (JR .NE. 1) GO TO 198
  23987.       DO 197 I=1,MR
  23988.          Q(I,NLAST) = (0.,0.)
  23989.   197 CONTINUE
  23990.       GO TO 202
  23991.   198 CONTINUE
  23992.       IF (NROD .NE. 0) GO TO 200
  23993.       DO 199 I=1,MR
  23994.          II = IP+I
  23995.          Q(I,NLAST) = P(II)
  23996.   199 CONTINUE
  23997.       IP = IP-MR
  23998.       GO TO 202
  23999.   200 DO 201 I=1,MR
  24000.          Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2)
  24001.   201 CONTINUE
  24002.   202 CONTINUE
  24003.       CALL CMPCSG (KR,1,0.5,FDEN,TCOS)
  24004.       CALL CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1))
  24005.       IF (LR .NE. 0) GO TO 204
  24006.       DO 203 I=1,MR
  24007.          B(I) = FISTAG*B(I)
  24008.   203 CONTINUE
  24009.   204 CONTINUE
  24010.       CALL CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
  24011.       DO 205 I=1,MR
  24012.          Q(I,NLAST) = Q(I,NLAST)+B(I)
  24013.   205 CONTINUE
  24014.       NLASTP = NLAST
  24015.   206 CONTINUE
  24016.       JSTEP = JR
  24017.       JR = I2R
  24018.       I2R = I2R/2
  24019.       IF (JR .EQ. 0) GO TO 222
  24020.       GO TO (207,208),MIXBND
  24021.   207 JSTART = 1+JR
  24022.       GO TO 209
  24023.   208 JSTART = JR
  24024.   209 CONTINUE
  24025.       KR = KR-JR
  24026.       IF (NLAST+JR .GT. N) GO TO 210
  24027.       KR = KR-JR
  24028.       NLAST = NLAST+JR
  24029.       JSTOP = NLAST-JSTEP
  24030.       GO TO 211
  24031.   210 CONTINUE
  24032.       JSTOP = NLAST-JR
  24033.   211 CONTINUE
  24034.       LR = KR-JR
  24035.       CALL CMPCSG (JR,1,0.5,0.0,TCOS)
  24036.       DO 221 J=JSTART,JSTOP,JSTEP
  24037.          JM2 = J-JR
  24038.          JP2 = J+JR
  24039.          IF (J .NE. JR) GO TO 213
  24040.          DO 212 I=1,MR
  24041.             B(I) = Q(I,J)+Q(I,JP2)
  24042.   212    CONTINUE
  24043.          GO TO 215
  24044.   213    CONTINUE
  24045.          DO 214 I=1,MR
  24046.             B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2)
  24047.   214    CONTINUE
  24048.   215    CONTINUE
  24049.          IF (JR .NE. 1) GO TO 217
  24050.          DO 216 I=1,MR
  24051.             Q(I,J) = (0.,0.)
  24052.   216    CONTINUE
  24053.          GO TO 219
  24054.   217    CONTINUE
  24055.          JM1 = J-I2R
  24056.          JP1 = J+I2R
  24057.          DO 218 I=1,MR
  24058.             Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  24059.   218    CONTINUE
  24060.   219    CONTINUE
  24061.          CALL CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W)
  24062.          DO 220 I=1,MR
  24063.             Q(I,J) = Q(I,J)+B(I)
  24064.   220    CONTINUE
  24065.   221 CONTINUE
  24066.       NROD = 1
  24067.       IF (NLAST+I2R .LE. N) NROD = 0
  24068.       IF (NLASTP .NE. NLAST) GO TO 194
  24069.       GO TO 206
  24070.   222 CONTINUE
  24071. C
  24072. C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
  24073. C
  24074.       W(1) = CMPLX(REAL(IPSTOR),0.)
  24075.       RETURN
  24076.       END
  24077. *DECK CMPOSP
  24078.       SUBROUTINE CMPOSP (M, N, A, BB, C, Q, IDIMQ, B, B2, B3, W, W2, W3,
  24079.      +   D, TCOS, P)
  24080. C***BEGIN PROLOGUE  CMPOSP
  24081. C***SUBSIDIARY
  24082. C***PURPOSE  Subsidiary to CMGNBN
  24083. C***LIBRARY   SLATEC
  24084. C***TYPE      COMPLEX (POISP2-S, CMPOSP-C)
  24085. C***AUTHOR  (UNKNOWN)
  24086. C***DESCRIPTION
  24087. C
  24088. C     Subroutine to solve Poisson's equation with periodic boundary
  24089. C     conditions.
  24090. C
  24091. C***SEE ALSO  CMGNBN
  24092. C***ROUTINES CALLED  CMPOSD, CMPOSN
  24093. C***REVISION HISTORY  (YYMMDD)
  24094. C   801001  DATE WRITTEN
  24095. C   890531  Changed all specific intrinsics to generic.  (WRB)
  24096. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24097. C   900402  Added TYPE section.  (WRB)
  24098. C***END PROLOGUE  CMPOSP
  24099. C
  24100.       COMPLEX         A          ,BB         ,C          ,Q          ,
  24101.      1                B          ,B2         ,B3         ,W          ,
  24102.      2                W2         ,W3         ,D          ,TCOS       ,
  24103.      3                P          ,S          ,T
  24104.       DIMENSION       A(*)       ,BB(*)      ,C(*)       ,Q(IDIMQ,*) ,
  24105.      1                B(*)       ,B2(*)      ,B3(*)      ,W(*)       ,
  24106.      2                W2(*)      ,W3(*)      ,D(*)       ,TCOS(*)    ,
  24107.      3                P(*)
  24108. C***FIRST EXECUTABLE STATEMENT  CMPOSP
  24109.       MR = M
  24110.       NR = (N+1)/2
  24111.       NRM1 = NR-1
  24112.       IF (2*NR .NE. N) GO TO 107
  24113. C
  24114. C     EVEN NUMBER OF UNKNOWNS
  24115. C
  24116.       DO 102 J=1,NRM1
  24117.          NRMJ = NR-J
  24118.          NRPJ = NR+J
  24119.          DO 101 I=1,MR
  24120.             S = Q(I,NRMJ)-Q(I,NRPJ)
  24121.             T = Q(I,NRMJ)+Q(I,NRPJ)
  24122.             Q(I,NRMJ) = S
  24123.             Q(I,NRPJ) = T
  24124.   101    CONTINUE
  24125.   102 CONTINUE
  24126.       DO 103 I=1,MR
  24127.          Q(I,NR) = 2.*Q(I,NR)
  24128.          Q(I,N) = 2.*Q(I,N)
  24129.   103 CONTINUE
  24130.       CALL CMPOSD (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P)
  24131.       IPSTOR = REAL(W(1))
  24132.       CALL CMPOSN (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D,
  24133.      1             TCOS,P)
  24134.       IPSTOR = MAX(IPSTOR,INT(REAL(W(1))))
  24135.       DO 105 J=1,NRM1
  24136.          NRMJ = NR-J
  24137.          NRPJ = NR+J
  24138.          DO 104 I=1,MR
  24139.             S = .5*(Q(I,NRPJ)+Q(I,NRMJ))
  24140.             T = .5*(Q(I,NRPJ)-Q(I,NRMJ))
  24141.             Q(I,NRMJ) = S
  24142.             Q(I,NRPJ) = T
  24143.   104    CONTINUE
  24144.   105 CONTINUE
  24145.       DO 106 I=1,MR
  24146.          Q(I,NR) = .5*Q(I,NR)
  24147.          Q(I,N) = .5*Q(I,N)
  24148.   106 CONTINUE
  24149.       GO TO 118
  24150.   107 CONTINUE
  24151. C
  24152. C     ODD  NUMBER OF UNKNOWNS
  24153. C
  24154.       DO 109 J=1,NRM1
  24155.          NRPJ = N+1-J
  24156.          DO 108 I=1,MR
  24157.             S = Q(I,J)-Q(I,NRPJ)
  24158.             T = Q(I,J)+Q(I,NRPJ)
  24159.             Q(I,J) = S
  24160.             Q(I,NRPJ) = T
  24161.   108    CONTINUE
  24162.   109 CONTINUE
  24163.       DO 110 I=1,MR
  24164.          Q(I,NR) = 2.*Q(I,NR)
  24165.   110 CONTINUE
  24166.       LH = NRM1/2
  24167.       DO 112 J=1,LH
  24168.          NRMJ = NR-J
  24169.          DO 111 I=1,MR
  24170.             S = Q(I,J)
  24171.             Q(I,J) = Q(I,NRMJ)
  24172.             Q(I,NRMJ) = S
  24173.   111    CONTINUE
  24174.   112 CONTINUE
  24175.       CALL CMPOSD (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P)
  24176.       IPSTOR = REAL(W(1))
  24177.       CALL CMPOSN (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D,
  24178.      1             TCOS,P)
  24179.       IPSTOR = MAX(IPSTOR,INT(REAL(W(1))))
  24180.       DO 114 J=1,NRM1
  24181.          NRPJ = NR+J
  24182.          DO 113 I=1,MR
  24183.             S = .5*(Q(I,NRPJ)+Q(I,J))
  24184.             T = .5*(Q(I,NRPJ)-Q(I,J))
  24185.             Q(I,NRPJ) = T
  24186.             Q(I,J) = S
  24187.   113    CONTINUE
  24188.   114 CONTINUE
  24189.       DO 115 I=1,MR
  24190.          Q(I,NR) = .5*Q(I,NR)
  24191.   115 CONTINUE
  24192.       DO 117 J=1,LH
  24193.          NRMJ = NR-J
  24194.          DO 116 I=1,MR
  24195.             S = Q(I,J)
  24196.             Q(I,J) = Q(I,NRMJ)
  24197.             Q(I,NRMJ) = S
  24198.   116    CONTINUE
  24199.   117 CONTINUE
  24200.   118 CONTINUE
  24201. C
  24202. C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
  24203. C
  24204.       W(1) = CMPLX(REAL(IPSTOR),0.)
  24205.       RETURN
  24206.       END
  24207. *DECK CMPTR3
  24208.       SUBROUTINE CMPTR3 (M, A, B, C, K, Y1, Y2, Y3, TCOS, D, W1, W2, W3)
  24209. C***BEGIN PROLOGUE  CMPTR3
  24210. C***SUBSIDIARY
  24211. C***PURPOSE  Subsidiary to CMGNBN
  24212. C***LIBRARY   SLATEC
  24213. C***TYPE      COMPLEX (TRI3-S, CMPTR3-C)
  24214. C***AUTHOR  (UNKNOWN)
  24215. C***DESCRIPTION
  24216. C
  24217. C     Subroutine to solve tridiagonal systems.
  24218. C
  24219. C***SEE ALSO  CMGNBN
  24220. C***ROUTINES CALLED  (NONE)
  24221. C***REVISION HISTORY  (YYMMDD)
  24222. C   801001  DATE WRITTEN
  24223. C   890206  REVISION DATE from Version 3.2
  24224. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24225. C   900402  Added TYPE section.  (WRB)
  24226. C***END PROLOGUE  CMPTR3
  24227.       COMPLEX         A          ,B          ,C          ,Y1         ,
  24228.      1                Y2         ,Y3         ,TCOS       ,D          ,
  24229.      2                W1         ,W2         ,W3         ,X          ,
  24230.      3                XX         ,Z
  24231.       DIMENSION       A(*)       ,B(*)       ,C(*)       ,K(4)       ,
  24232.      1                TCOS(*)    ,Y1(*)      ,Y2(*)      ,Y3(*)      ,
  24233.      2                D(*)       ,W1(*)      ,W2(*)      ,W3(*)
  24234.       INTEGER K1P1, K2P1, K3P1, K4P1
  24235. C
  24236. C***FIRST EXECUTABLE STATEMENT  CMPTR3
  24237.       MM1 = M-1
  24238.       K1 = K(1)
  24239.       K2 = K(2)
  24240.       K3 = K(3)
  24241.       K4 = K(4)
  24242.       K1P1 = K1+1
  24243.       K2P1 = K2+1
  24244.       K3P1 = K3+1
  24245.       K4P1 = K4+1
  24246.       K2K3K4 = K2+K3+K4
  24247.       IF (K2K3K4 .EQ. 0) GO TO 101
  24248.       L1 = K1P1/K2P1
  24249.       L2 = K1P1/K3P1
  24250.       L3 = K1P1/K4P1
  24251.       LINT1 = 1
  24252.       LINT2 = 1
  24253.       LINT3 = 1
  24254.       KINT1 = K1
  24255.       KINT2 = KINT1+K2
  24256.       KINT3 = KINT2+K3
  24257.   101 CONTINUE
  24258.       DO 115 N=1,K1
  24259.          X = TCOS(N)
  24260.          IF (K2K3K4 .EQ. 0) GO TO 107
  24261.          IF (N .NE. L1) GO TO 103
  24262.          DO 102 I=1,M
  24263.             W1(I) = Y1(I)
  24264.   102    CONTINUE
  24265.   103    IF (N .NE. L2) GO TO 105
  24266.          DO 104 I=1,M
  24267.             W2(I) = Y2(I)
  24268.   104    CONTINUE
  24269.   105    IF (N .NE. L3) GO TO 107
  24270.          DO 106 I=1,M
  24271.             W3(I) = Y3(I)
  24272.   106    CONTINUE
  24273.   107    CONTINUE
  24274.          Z = 1./(B(1)-X)
  24275.          D(1) = C(1)*Z
  24276.          Y1(1) = Y1(1)*Z
  24277.          Y2(1) = Y2(1)*Z
  24278.          Y3(1) = Y3(1)*Z
  24279.          DO 108 I=2,M
  24280.             Z = 1./(B(I)-X-A(I)*D(I-1))
  24281.             D(I) = C(I)*Z
  24282.             Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z
  24283.             Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z
  24284.             Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z
  24285.   108    CONTINUE
  24286.          DO 109 IP=1,MM1
  24287.             I = M-IP
  24288.             Y1(I) = Y1(I)-D(I)*Y1(I+1)
  24289.             Y2(I) = Y2(I)-D(I)*Y2(I+1)
  24290.             Y3(I) = Y3(I)-D(I)*Y3(I+1)
  24291.   109    CONTINUE
  24292.          IF (K2K3K4 .EQ. 0) GO TO 115
  24293.          IF (N .NE. L1) GO TO 111
  24294.          I = LINT1+KINT1
  24295.          XX = X-TCOS(I)
  24296.          DO 110 I=1,M
  24297.             Y1(I) = XX*Y1(I)+W1(I)
  24298.   110    CONTINUE
  24299.          LINT1 = LINT1+1
  24300.          L1 = (LINT1*K1P1)/K2P1
  24301.   111    IF (N .NE. L2) GO TO 113
  24302.          I = LINT2+KINT2
  24303.          XX = X-TCOS(I)
  24304.          DO 112 I=1,M
  24305.             Y2(I) = XX*Y2(I)+W2(I)
  24306.   112    CONTINUE
  24307.          LINT2 = LINT2+1
  24308.          L2 = (LINT2*K1P1)/K3P1
  24309.   113    IF (N .NE. L3) GO TO 115
  24310.          I = LINT3+KINT3
  24311.          XX = X-TCOS(I)
  24312.          DO 114 I=1,M
  24313.             Y3(I) = XX*Y3(I)+W3(I)
  24314.   114    CONTINUE
  24315.          LINT3 = LINT3+1
  24316.          L3 = (LINT3*K1P1)/K4P1
  24317.   115 CONTINUE
  24318.       RETURN
  24319.       END
  24320. *DECK CMPTRX
  24321.       SUBROUTINE CMPTRX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W)
  24322. C***BEGIN PROLOGUE  CMPTRX
  24323. C***SUBSIDIARY
  24324. C***PURPOSE  Subsidiary to CMGNBN
  24325. C***LIBRARY   SLATEC
  24326. C***TYPE      COMPLEX (TRIX-S, CMPTRX-C)
  24327. C***AUTHOR  (UNKNOWN)
  24328. C***DESCRIPTION
  24329. C
  24330. C     Subroutine to solve a system of linear equations where the
  24331. C     coefficient matrix is a rational function in the matrix given by
  24332. C     tridiagonal  ( . . . , A(I), B(I), C(I), . . . ).
  24333. C
  24334. C***SEE ALSO  CMGNBN
  24335. C***ROUTINES CALLED  (NONE)
  24336. C***REVISION HISTORY  (YYMMDD)
  24337. C   801001  DATE WRITTEN
  24338. C   890531  Changed all specific intrinsics to generic.  (WRB)
  24339. C   890531  REVISION DATE from Version 3.2
  24340. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24341. C   900402  Added TYPE section.  (WRB)
  24342. C***END PROLOGUE  CMPTRX
  24343. C
  24344.       COMPLEX         A          ,B          ,C          ,Y          ,
  24345.      1                TCOS       ,D          ,W          ,X          ,
  24346.      2                XX         ,Z
  24347.       DIMENSION       A(*)       ,B(*)       ,C(*)       ,Y(*)       ,
  24348.      1                TCOS(*)    ,D(*)       ,W(*)
  24349.       INTEGER KB, KC
  24350. C***FIRST EXECUTABLE STATEMENT  CMPTRX
  24351.       MM1 = M-1
  24352.       KB = IDEGBR+1
  24353.       KC = IDEGCR+1
  24354.       L = KB/KC
  24355.       LINT = 1
  24356.       DO 108 K=1,IDEGBR
  24357.          X = TCOS(K)
  24358.          IF (K .NE. L) GO TO 102
  24359.          I = IDEGBR+LINT
  24360.          XX = X-TCOS(I)
  24361.          DO 101 I=1,M
  24362.             W(I) = Y(I)
  24363.             Y(I) = XX*Y(I)
  24364.   101    CONTINUE
  24365.   102    CONTINUE
  24366.          Z = 1./(B(1)-X)
  24367.          D(1) = C(1)*Z
  24368.          Y(1) = Y(1)*Z
  24369.          DO 103 I=2,MM1
  24370.             Z = 1./(B(I)-X-A(I)*D(I-1))
  24371.             D(I) = C(I)*Z
  24372.             Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  24373.   103    CONTINUE
  24374.          Z = B(M)-X-A(M)*D(MM1)
  24375.          IF (ABS(Z) .NE. 0.) GO TO 104
  24376.          Y(M) = (0.,0.)
  24377.          GO TO 105
  24378.   104    Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  24379.   105    CONTINUE
  24380.          DO 106 IP=1,MM1
  24381.             I = M-IP
  24382.             Y(I) = Y(I)-D(I)*Y(I+1)
  24383.   106    CONTINUE
  24384.          IF (K .NE. L) GO TO 108
  24385.          DO 107 I=1,M
  24386.             Y(I) = Y(I)+W(I)
  24387.   107    CONTINUE
  24388.          LINT = LINT+1
  24389.          L = (LINT*KB)/KC
  24390.   108 CONTINUE
  24391.       RETURN
  24392.       END
  24393. *DECK CNBCO
  24394.       SUBROUTINE CNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z)
  24395. C***BEGIN PROLOGUE  CNBCO
  24396. C***PURPOSE  Factor a band matrix using Gaussian elimination and
  24397. C            estimate the condition number.
  24398. C***LIBRARY   SLATEC
  24399. C***CATEGORY  D2C2
  24400. C***TYPE      COMPLEX (SNBCO-S, DNBCO-D, CNBCO-C)
  24401. C***KEYWORDS  BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION,
  24402. C             NONSYMMETRIC
  24403. C***AUTHOR  Voorhees, E. A., (LANL)
  24404. C***DESCRIPTION
  24405. C
  24406. C     CNBCO factors a complex band matrix by Gaussian
  24407. C     elimination and estimates the condition of the matrix.
  24408. C
  24409. C     If RCOND is not needed, CNBFA is slightly faster.
  24410. C     To solve  A*X = B , follow CNBCO by CNBSL.
  24411. C     To compute  INVERSE(A)*C , follow CNBCO by CNBSL.
  24412. C     To compute  DETERMINANT(A) , follow CNBCO by CNBDI.
  24413. C
  24414. C     On Entry
  24415. C
  24416. C        ABE     COMPLEX(LDA, NC)
  24417. C                contains the matrix in band storage.  The rows
  24418. C                of the original matrix are stored in the rows
  24419. C                of ABE and the diagonals of the original matrix
  24420. C                are stored in columns 1 through ML+MU+1 of ABE.
  24421. C                NC must be .GE. 2*ML+MU+1 .
  24422. C                See the comments below for details.
  24423. C
  24424. C        LDA     INTEGER
  24425. C                the leading dimension of the array ABE.
  24426. C                LDA must be .GE. N .
  24427. C
  24428. C        N       INTEGER
  24429. C                the order of the original matrix.
  24430. C
  24431. C        ML      INTEGER
  24432. C                number of diagonals below the main diagonal.
  24433. C                0 .LE. ML .LT. N .
  24434. C
  24435. C        MU      INTEGER
  24436. C                number of diagonals above the main diagonal.
  24437. C                0 .LE. MU .LT. N .
  24438. C                More efficient if ML .LE. MU .
  24439. C
  24440. C     On Return
  24441. C
  24442. C        ABE     an upper triangular matrix in band storage
  24443. C                and the multipliers which were used to obtain it.
  24444. C                The factorization can be written  A = L*U  where
  24445. C                L is a product of permutation and unit lower
  24446. C                triangular matrices and  U  is upper triangular.
  24447. C
  24448. C        IPVT    INTEGER(N)
  24449. C                an integer vector of pivot indices.
  24450. C
  24451. C        RCOND   REAL
  24452. C                an estimate of the reciprocal condition of  A .
  24453. C                For the system  A*X = B , relative perturbations
  24454. C                in  A  and  B  of size  EPSILON  may cause
  24455. C                relative perturbations in  X  of size  EPSILON/RCOND .
  24456. C                If  RCOND  is so small that the logical expression
  24457. C                         1.0 + RCOND .EQ. 1.0
  24458. C                is true, then  A  may be singular to working
  24459. C                precision.  In particular,  RCOND  is zero  if
  24460. C                exact singularity is detected or the estimate
  24461. C                underflows.
  24462. C
  24463. C        Z       COMPLEX(N)
  24464. C                a work vector whose contents are usually unimportant.
  24465. C                If  A  is close to a singular matrix, then  Z  is
  24466. C                an approximate null vector in the sense that
  24467. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  24468. C
  24469. C     Band Storage
  24470. C
  24471. C           If  A  is a band matrix, the following program segment
  24472. C           will set up the input.
  24473. C
  24474. C                   ML = (band width below the diagonal)
  24475. C                   MU = (band width above the diagonal)
  24476. C                   DO 20 I = 1, N
  24477. C                      J1 = MAX(1, I-ML)
  24478. C                      J2 = MIN(N, I+MU)
  24479. C                      DO 10 J = J1, J2
  24480. C                         K = J - I + ML + 1
  24481. C                         ABE(I,K) = A(I,J)
  24482. C                10    CONTINUE
  24483. C                20 CONTINUE
  24484. C
  24485. C           This uses columns  1  through  ML+MU+1  of ABE .
  24486. C           Furthermore,  ML  additional columns are needed in
  24487. C           ABE  starting with column  ML+MU+2  for elements
  24488. C           generated during the triangularization.  The total
  24489. C           number of columns needed in  ABE  is  2*ML+MU+1 .
  24490. C
  24491. C     Example:  If the original matrix is
  24492. C
  24493. C           11 12 13  0  0  0
  24494. C           21 22 23 24  0  0
  24495. C            0 32 33 34 35  0
  24496. C            0  0 43 44 45 46
  24497. C            0  0  0 54 55 56
  24498. C            0  0  0  0 65 66
  24499. C
  24500. C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
  24501. C
  24502. C            * 11 12 13  +     , * = not used
  24503. C           21 22 23 24  +     , + = used for pivoting
  24504. C           32 33 34 35  +
  24505. C           43 44 45 46  +
  24506. C           54 55 56  *  +
  24507. C           65 66  *  *  +
  24508. C
  24509. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  24510. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  24511. C***ROUTINES CALLED  CAXPY, CDOTC, CNBFA, CSSCAL, SCASUM
  24512. C***REVISION HISTORY  (YYMMDD)
  24513. C   800730  DATE WRITTEN
  24514. C   890531  Changed all specific intrinsics to generic.  (WRB)
  24515. C   890831  Modified array declarations.  (WRB)
  24516. C   890831  REVISION DATE from Version 3.2
  24517. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24518. C   920501  Reformatted the REFERENCES section.  (WRB)
  24519. C***END PROLOGUE  CNBCO
  24520.       INTEGER LDA,N,ML,MU,IPVT(*)
  24521.       COMPLEX ABE(LDA,*),Z(*)
  24522.       REAL RCOND
  24523. C
  24524.       COMPLEX CDOTC,EK,T,WK,WKM
  24525.       REAL ANORM,S,SCASUM,SM,YNORM
  24526.       INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU
  24527.       COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
  24528.       REAL CABS1
  24529.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  24530.       CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
  24531. C
  24532. C     COMPUTE 1-NORM OF A
  24533. C
  24534. C***FIRST EXECUTABLE STATEMENT  CNBCO
  24535.       ML1=ML+1
  24536.       LDB = LDA - 1
  24537.       ANORM = 0.0E0
  24538.       DO 10 J = 1, N
  24539.         NU = MIN(MU,J-1)
  24540.         NL = MIN(ML,N-J)
  24541.         L = 1 + NU + NL
  24542.         ANORM = MAX(ANORM,SCASUM(L,ABE(J+NL,ML1-NL),LDB))
  24543.    10 CONTINUE
  24544. C
  24545. C     FACTOR
  24546. C
  24547.       CALL CNBFA(ABE,LDA,N,ML,MU,IPVT,INFO)
  24548. C
  24549. C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  24550. C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND CTRANS(A)*Y = E .
  24551. C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
  24552. C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  24553. C     GROWTH IN THE ELEMENTS OF  W  WHERE CTRANS(U)*W = E .
  24554. C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  24555. C
  24556. C     SOLVE CTRANS(U)*W = E
  24557. C
  24558.       EK = (1.0E0,0.0E0)
  24559.       DO 20 J = 1, N
  24560.         Z(J) = (0.0E0,0.0E0)
  24561.    20 CONTINUE
  24562.       M = ML + MU + 1
  24563.       JU = 0
  24564.       DO 100 K = 1, N
  24565.         IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  24566.         IF (CABS1(EK-Z(K)) .LE. CABS1(ABE(K,ML1))) GO TO 30
  24567.           S = CABS1(ABE(K,ML1))/CABS1(EK-Z(K))
  24568.           CALL CSSCAL(N,S,Z,1)
  24569.           EK = CMPLX(S,0.0E0)*EK
  24570.    30   CONTINUE
  24571.         WK = EK - Z(K)
  24572.         WKM = -EK - Z(K)
  24573.         S = CABS1(WK)
  24574.         SM = CABS1(WKM)
  24575.         IF (CABS1(ABE(K,ML1)) .EQ. 0.0E0) GO TO 40
  24576.           WK = WK/CONJG(ABE(K,ML1))
  24577.           WKM = WKM/CONJG(ABE(K,ML1))
  24578.         GO TO 50
  24579.    40   CONTINUE
  24580.           WK = (1.0E0,0.0E0)
  24581.           WKM = (1.0E0,0.0E0)
  24582.    50   CONTINUE
  24583.         KP1 = K + 1
  24584.         JU = MIN(MAX(JU,MU+IPVT(K)),N)
  24585.         MM = ML1
  24586.         IF (KP1 .GT. JU) GO TO 90
  24587.           DO 60 I = KP1, JU
  24588.             MM = MM + 1
  24589.             SM = SM + CABS1(Z(I)+WKM*CONJG(ABE(K,MM)))
  24590.             Z(I) = Z(I) + WK*CONJG(ABE(K,MM))
  24591.             S = S + CABS1(Z(I))
  24592.    60     CONTINUE
  24593.           IF (S .GE. SM) GO TO 80
  24594.             T = WKM -WK
  24595.             WK = WKM
  24596.             MM = ML1
  24597.             DO 70 I = KP1, JU
  24598.               MM = MM + 1
  24599.               Z(I) = Z(I) + T*CONJG(ABE(K,MM))
  24600.    70       CONTINUE
  24601.    80     CONTINUE
  24602.    90   CONTINUE
  24603.       Z(K) = WK
  24604.   100 CONTINUE
  24605.       S = 1.0E0/SCASUM(N,Z,1)
  24606.       CALL CSSCAL(N,S,Z,1)
  24607. C
  24608. C     SOLVE CTRANS(L)*Y = W
  24609. C
  24610.       DO 120 KB = 1, N
  24611.         K = N + 1 - KB
  24612.         NL = MIN(ML,N-K)
  24613.         IF (K .LT. N) Z(K) = Z(K) + CDOTC(NL,ABE(K+NL,ML1-NL),-LDB,
  24614.      1  Z(K+1),1)
  24615.         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
  24616.           S = 1.0E0/CABS1(Z(K))
  24617.           CALL CSSCAL(N,S,Z,1)
  24618.   110   CONTINUE
  24619.         L = IPVT(K)
  24620.         T = Z(L)
  24621.         Z(L) = Z(K)
  24622.         Z(K) = T
  24623.   120 CONTINUE
  24624.       S = 1.0E0/SCASUM(N,Z,1)
  24625.       CALL CSSCAL(N,S,Z,1)
  24626. C
  24627.       YNORM = 1.0E0
  24628. C
  24629. C     SOLVE L*V = Y
  24630. C
  24631.       DO 140 K = 1, N
  24632.         L = IPVT(K)
  24633.         T = Z(L)
  24634.         Z(L) = Z(K)
  24635.         Z(K) = T
  24636.         NL = MIN(ML,N-K)
  24637.         IF (K .LT. N) CALL CAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1)
  24638.         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
  24639.           S = 1.0E0/CABS1(Z(K))
  24640.           CALL CSSCAL(N,S,Z,1)
  24641.           YNORM = S*YNORM
  24642.   130   CONTINUE
  24643.   140 CONTINUE
  24644.       S = 1.0E0/SCASUM(N,Z,1)
  24645.       CALL CSSCAL(N,S,Z,1)
  24646.       YNORM = S*YNORM
  24647. C
  24648. C     SOLVE  U*Z = V
  24649. C
  24650.       DO 160 KB = 1, N
  24651.         K = N + 1 - KB
  24652.         IF (CABS1(Z(K)) .LE. CABS1(ABE(K,ML1))) GO TO 150
  24653.           S = CABS1(ABE(K,ML1))/CABS1(Z(K))
  24654.           CALL CSSCAL(N,S,Z,1)
  24655.           YNORM = S*YNORM
  24656.   150   CONTINUE
  24657.         IF (CABS1(ABE(K,ML1)) .NE. 0.0E0) Z(K) = Z(K)/ABE(K,ML1)
  24658.         IF (CABS1(ABE(K,ML1)) .EQ. 0.0E0) Z(K) = 1.0E0
  24659.         LM = MIN(K,M) - 1
  24660.         LZ = K - LM
  24661.         T = -Z(K)
  24662.         CALL CAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1)
  24663.   160 CONTINUE
  24664. C     MAKE ZNORM = 1.0E0
  24665.       S = 1.0E0/SCASUM(N,Z,1)
  24666.       CALL CSSCAL(N,S,Z,1)
  24667.       YNORM = S*YNORM
  24668. C
  24669.       IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  24670.       IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  24671.       RETURN
  24672.       END
  24673. *DECK CNBDI
  24674.       SUBROUTINE CNBDI (ABE, LDA, N, ML, MU, IPVT, DET)
  24675. C***BEGIN PROLOGUE  CNBDI
  24676. C***PURPOSE  Compute the determinant of a band matrix using the factors
  24677. C            computed by CNBCO or CNBFA.
  24678. C***LIBRARY   SLATEC
  24679. C***CATEGORY  D3C2
  24680. C***TYPE      COMPLEX (SNBDI-S, DNBDI-D, CNBDI-C)
  24681. C***KEYWORDS  BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC
  24682. C***AUTHOR  Voorhees, E. A., (LANL)
  24683. C***DESCRIPTION
  24684. C
  24685. C     CNBDI computes the determinant of a band matrix
  24686. C     using the factors computed by CNBCO or CNBFA.
  24687. C     If the inverse is needed, use CNBSL  N  times.
  24688. C
  24689. C     On Entry
  24690. C
  24691. C        ABE     COMPLEX(LDA, NC)
  24692. C                the output from CNBCO or CNBFA.
  24693. C                NC must be .GE. 2*ML+MU+1 .
  24694. C
  24695. C        LDA     INTEGER
  24696. C                the leading dimension of the array  ABE .
  24697. C
  24698. C        N       INTEGER
  24699. C                the order of the original matrix.
  24700. C
  24701. C        ML      INTEGER
  24702. C                number of diagonals below the main diagonal.
  24703. C
  24704. C        MU      INTEGER
  24705. C                number of diagonals above the main diagonal.
  24706. C
  24707. C        IPVT    INTEGER(N)
  24708. C                the pivot vector from CNBCO or CNBFA.
  24709. C
  24710. C     On Return
  24711. C
  24712. C        DET     COMPLEX(2)
  24713. C                determinant of original matrix.
  24714. C                Determinant = DET(1) * 10.0**DET(2)
  24715. C                with  1.0 .LE. CABS1(DET(1)) .LT. 10.0
  24716. C                or  DET(1) = 0.0 .
  24717. C
  24718. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  24719. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  24720. C***ROUTINES CALLED  (NONE)
  24721. C***REVISION HISTORY  (YYMMDD)
  24722. C   800730  DATE WRITTEN
  24723. C   890831  Modified array declarations.  (WRB)
  24724. C   890831  REVISION DATE from Version 3.2
  24725. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24726. C   920501  Reformatted the REFERENCES section.  (WRB)
  24727. C***END PROLOGUE  CNBDI
  24728.       INTEGER LDA,N,ML,MU,IPVT(*)
  24729.       COMPLEX ABE(LDA,*),DET(2)
  24730. C
  24731.       REAL TEN
  24732.       INTEGER I
  24733.       COMPLEX ZDUM
  24734.       REAL CABS1
  24735.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  24736. C
  24737. C***FIRST EXECUTABLE STATEMENT  CNBDI
  24738.       DET(1) = (1.0E0,0.0E0)
  24739.       DET(2) = (0.0E0,0.0E0)
  24740.       TEN = 10.0E0
  24741.       DO 50 I = 1, N
  24742.          IF (IPVT(I) .NE. I) DET(1) = -DET(1)
  24743.          DET(1) = ABE(I,ML+1)*DET(1)
  24744.          IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60
  24745.    10    IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20
  24746.             DET(1) = CMPLX(TEN,0.0E0)*DET(1)
  24747.             DET(2) = DET(2) - (1.0E0,0.0E0)
  24748.          GO TO 10
  24749.    20    CONTINUE
  24750.    30    IF (CABS1(DET(1)) .LT. TEN) GO TO 40
  24751.             DET(1) = DET(1)/CMPLX(TEN,0.0E0)
  24752.             DET(2) = DET(2) + (1.0E0,0.0E0)
  24753.          GO TO 30
  24754.    40    CONTINUE
  24755.    50 CONTINUE
  24756.    60 CONTINUE
  24757.       RETURN
  24758.       END
  24759. *DECK CNBFA
  24760.       SUBROUTINE CNBFA (ABE, LDA, N, ML, MU, IPVT, INFO)
  24761. C***BEGIN PROLOGUE  CNBFA
  24762. C***PURPOSE  Factor a band matrix by elimination.
  24763. C***LIBRARY   SLATEC
  24764. C***CATEGORY  D2C2
  24765. C***TYPE      COMPLEX (SNBFA-S, DNBFA-D, CNBFA-C)
  24766. C***KEYWORDS  BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION,
  24767. C             NONSYMMETRIC
  24768. C***AUTHOR  Voorhees, E. A., (LANL)
  24769. C***DESCRIPTION
  24770. C
  24771. C    CNBFA factors a complex band matrix by elimination.
  24772. C
  24773. C     CNBFA is usually called by CNBCO, but it can be called
  24774. C     directly with a saving in time if RCOND is not needed.
  24775. C
  24776. C     On Entry
  24777. C
  24778. C        ABE     COMPLEX(LDA, NC)
  24779. C                contains the matrix in band storage.  The rows
  24780. C                of the original matrix are stored in the rows
  24781. C                of ABE and the diagonals of the original matrix
  24782. C                are stored in columns 1 through ML+MU+1 of ABE.
  24783. C                NC must be .GE. 2*ML+MU+1 .
  24784. C                See the comments below for details.
  24785. C
  24786. C        LDA     INTEGER
  24787. C                the leading dimension of the array ABE.
  24788. C                LDA must be .GE. N .
  24789. C
  24790. C        N       INTEGER
  24791. C                the order of the original matrix.
  24792. C
  24793. C        ML      INTEGER
  24794. C                number of diagonals below the main diagonal.
  24795. C                0 .LE. ML .LT. N .
  24796. C
  24797. C        MU      INTEGER
  24798. C                number of diagonals above the main diagonal.
  24799. C                0 .LE. MU .LT. N .
  24800. C                More efficient if ML .LE. MU .
  24801. C
  24802. C     On Return
  24803. C
  24804. C        ABE     an upper triangular matrix in band storage
  24805. C                and the multipliers which were used to obtain it.
  24806. C                the factorization can be written  A = L*U  where
  24807. C                L is a product of permutation and unit lower
  24808. C                triangular matrices and  U  is upper triangular.
  24809. C
  24810. C        IPVT    INTEGER(N)
  24811. C                an integer vector of pivot indices.
  24812. C
  24813. C        INFO    INTEGER
  24814. C                =0  normal value
  24815. C                =K  if  U(K,K) .EQ. 0.0 .  This is not an error
  24816. C                condition for this subroutine, but it does
  24817. C                indicate that CNBSL will divide by zero if
  24818. C                called.  Use RCOND in CNBCO for a reliable
  24819. C                indication of singularity.
  24820. C
  24821. C     Band Storage
  24822. C
  24823. C           If  A  is a band matrix, the following program segment
  24824. C           will set up the input.
  24825. C
  24826. C                   ML = (band width below the diagonal)
  24827. C                   MU = (band width above the diagonal)
  24828. C                   DO 20 I = 1, N
  24829. C                      J1 = MAX(1, I-ML)
  24830. C                      J2 = MIN(N, I+MU)
  24831. C                      DO 10 J = J1, J2
  24832. C                         K = J - I + ML + 1
  24833. C                         ABE(I,K) = A(I,J)
  24834. C                10    CONTINUE
  24835. C                20 CONTINUE
  24836. C
  24837. C           This uses columns  1  through  ML+MU+1  of ABE .
  24838. C           Furthermore,  ML  additional columns are needed in
  24839. C           ABE  starting with column  ML+MU+2  for elements
  24840. C           generated during the triangularization.  The total
  24841. C           number of columns needed in  ABE  is  2*ML+MU+1 .
  24842. C
  24843. C     Example:  If the original matrix is
  24844. C
  24845. C           11 12 13  0  0  0
  24846. C           21 22 23 24  0  0
  24847. C            0 32 33 34 35  0
  24848. C            0  0 43 44 45 46
  24849. C            0  0  0 54 55 56
  24850. C            0  0  0  0 65 66
  24851. C
  24852. C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
  24853. C
  24854. C            * 11 12 13  +     , * = not used
  24855. C           21 22 23 24  +     , + = used for pivoting
  24856. C           32 33 34 35  +
  24857. C           43 44 45 46  +
  24858. C           54 55 56  *  +
  24859. C           65 66  *  *  +
  24860. C
  24861. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  24862. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  24863. C***ROUTINES CALLED  CAXPY, CSCAL, CSWAP, ICAMAX
  24864. C***REVISION HISTORY  (YYMMDD)
  24865. C   800730  DATE WRITTEN
  24866. C   890531  Changed all specific intrinsics to generic.  (WRB)
  24867. C   890831  Modified array declarations.  (WRB)
  24868. C   890831  REVISION DATE from Version 3.2
  24869. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  24870. C   920501  Reformatted the REFERENCES section.  (WRB)
  24871. C***END PROLOGUE  CNBFA
  24872.       INTEGER LDA,N,ML,MU,IPVT(*),INFO
  24873.       COMPLEX ABE(LDA,*)
  24874. C
  24875.       INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ICAMAX
  24876.       COMPLEX T
  24877.       COMPLEX ZDUM
  24878.       REAL CABS1
  24879.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  24880. C
  24881. C***FIRST EXECUTABLE STATEMENT  CNBFA
  24882.       ML1=ML+1
  24883.       MB=ML+MU
  24884.       M=ML+MU+1
  24885.       N1=N-1
  24886.       LDB=LDA-1
  24887.       INFO=0
  24888. C
  24889. C     SET FILL-IN COLUMNS TO ZERO
  24890. C
  24891.       IF(N.LE.1)GO TO 50
  24892.       IF(ML.LE.0)GO TO 7
  24893.       DO 6 J=1,ML
  24894.         DO 5 I=1,N
  24895.           ABE(I,M+J)=(0.0E0,0.0E0)
  24896.     5   CONTINUE
  24897.     6 CONTINUE
  24898.     7 CONTINUE
  24899. C
  24900. C     GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION
  24901. C
  24902.       DO 40 K=1,N1
  24903.         LM=MIN(N-K,ML)
  24904.         LM1=LM+1
  24905.         LM2=ML1-LM
  24906. C
  24907. C     SEARCH FOR PIVOT INDEX
  24908. C
  24909.         L=-ICAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K
  24910.         IPVT(K)=L
  24911.         MP=MIN(MB,N-K)
  24912. C
  24913. C     SWAP ROWS IF NECESSARY
  24914. C
  24915.         IF(L.NE.K)CALL CSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA)
  24916. C
  24917. C     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
  24918. C
  24919.         IF(CABS1(ABE(K,ML1)).EQ.0.0E0) GO TO 20
  24920. C
  24921. C     COMPUTE MULTIPLIERS
  24922. C
  24923.         T=-(1.0E0,0.0E0)/ABE(K,ML1)
  24924.         CALL CSCAL(LM,T,ABE(LM+K,LM2),LDB)
  24925. C
  24926. C     ROW ELIMINATION WITH COLUMN INDEXING
  24927. C
  24928.         DO 10 J=1,MP
  24929.           CALL CAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J),
  24930.      1                LDB)
  24931.    10   CONTINUE
  24932.         GO TO 30
  24933.    20   CONTINUE
  24934.         INFO=K
  24935.    30   CONTINUE
  24936.    40 CONTINUE
  24937.    50 CONTINUE
  24938.       IPVT(N)=N
  24939.       IF(CABS1(ABE(N,ML1)).EQ.0.0E0) INFO=N
  24940.       RETURN
  24941.       END
  24942. *DECK CNBFS
  24943.       SUBROUTINE CNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK)
  24944. C***BEGIN PROLOGUE  CNBFS
  24945. C***PURPOSE  Solve a general nonsymmetric banded system of linear
  24946. C            equations.
  24947. C***LIBRARY   SLATEC
  24948. C***CATEGORY  D2C2
  24949. C***TYPE      COMPLEX (SNBFS-S, DNBFS-D, CNBFS-C)
  24950. C***KEYWORDS  BANDED, LINEAR EQUATIONS, NONSYMMETRIC
  24951. C***AUTHOR  Voorhees, E. A., (LANL)
  24952. C***DESCRIPTION
  24953. C
  24954. C    Subroutine CNBFS solves a general nonsymmetric banded NxN
  24955. C    system of single precision complex linear equations using
  24956. C    SLATEC subroutines CNBCO and CNBSL.  These are adaptations
  24957. C    of the LINPACK subroutines CGBCO and CGBSL which require
  24958. C    a different format for storing the matrix elements.  If
  24959. C    A  is an NxN complex matrix and if  X  and  B  are complex
  24960. C    N-vectors, then CNBFS solves the equation
  24961. C
  24962. C                          A*X=B.
  24963. C
  24964. C    A band matrix is a matrix whose nonzero elements are all
  24965. C    fairly near the main diagonal, specifically  A(I,J) = 0
  24966. C    if  I-J is greater than  ML  or  J-I  is greater than
  24967. C    MU .  The integers ML and MU are called the lower and upper
  24968. C    band widths and  M = ML+MU+1  is the total band width.
  24969. C    CNBFS uses less time and storage than the corresponding
  24970. C    program for general matrices (CGEFS) if 2*ML+MU .LT. N .
  24971. C
  24972. C    The matrix A is first factored into upper and lower tri-
  24973. C    angular matrices U and L using partial pivoting.  These
  24974. C    factors and the pivoting information are used to find the
  24975. C    solution vector X.  An approximate condition number is
  24976. C    calculated to provide a rough estimate of the number of
  24977. C    digits of accuracy in the computed solution.
  24978. C
  24979. C    If the equation A*X=B is to be solved for more than one vector
  24980. C    B, the factoring of A does not need to be performed again and
  24981. C    the option to only solve (ITASK .GT. 1) will be faster for
  24982. C    the succeeding solutions.  In this case, the contents of A,
  24983. C    LDA, N and IWORK must not have been altered by the user follow-
  24984. C    ing factorization (ITASK=1).  IND will not be changed by CNBFS
  24985. C    in this case.
  24986. C
  24987. C
  24988. C    Band Storage
  24989. C
  24990. C          If  A  is a band matrix, the following program segment
  24991. C          will set up the input.
  24992. C
  24993. C                  ML = (band width below the diagonal)
  24994. C                  MU = (band width above the diagonal)
  24995. C                  DO 20 I = 1, N
  24996. C                     J1 = MAX(1, I-ML)
  24997. C                     J2 = MIN(N, I+MU)
  24998. C                     DO 10 J = J1, J2
  24999. C                        K = J - I + ML + 1
  25000. C                        ABE(I,K) = A(I,J)
  25001. C               10    CONTINUE
  25002. C               20 CONTINUE
  25003. C
  25004. C          This uses columns  1  through  ML+MU+1  of ABE .
  25005. C          Furthermore,  ML  additional columns are needed in
  25006. C          ABE  starting with column  ML+MU+2  for elements
  25007. C          generated during the triangularization.  The total
  25008. C          number of columns needed in  ABE  is  2*ML+MU+1 .
  25009. C
  25010. C    Example:  If the original matrix is
  25011. C
  25012. C          11 12 13  0  0  0
  25013. C          21 22 23 24  0  0
  25014. C           0 32 33 34 35  0
  25015. C           0  0 43 44 45 46
  25016. C           0  0  0 54 55 56
  25017. C           0  0  0  0 65 66
  25018. C
  25019. C     then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
  25020. C
  25021. C           * 11 12 13  +     , * = not used
  25022. C          21 22 23 24  +     , + = used for pivoting
  25023. C          32 33 34 35  +
  25024. C          43 44 45 46  +
  25025. C          54 55 56  *  +
  25026. C          65 66  *  *  +
  25027. C
  25028. C
  25029. C  Argument Description ***
  25030. C
  25031. C    ABE    COMPLEX(LDA,NC)
  25032. C             on entry, contains the matrix in band storage as
  25033. C               described above.  NC  must not be less than
  25034. C               2*ML+MU+1 .  The user is cautioned to specify  NC
  25035. C               with care since it is not an argument and cannot
  25036. C               be checked by CNBFS.  The rows of the original
  25037. C               matrix are stored in the rows of  ABE  and the
  25038. C               diagonals of the original matrix are stored in
  25039. C               columns  1  through  ML+MU+1  of  ABE .
  25040. C             on return, contains an upper triangular matrix U and
  25041. C               the multipliers necessary to construct a matrix L
  25042. C               so that A=L*U.
  25043. C    LDA    INTEGER
  25044. C             the leading dimension of array ABE.  LDA must be great-
  25045. C             er than or equal to N.  (terminal error message IND=-1)
  25046. C    N      INTEGER
  25047. C             the order of the matrix A.  N must be greater
  25048. C             than or equal to 1 .  (terminal error message IND=-2)
  25049. C    ML     INTEGER
  25050. C             the number of diagonals below the main diagonal.
  25051. C             ML  must not be less than zero nor greater than or
  25052. C             equal to  N .  (terminal error message IND=-5)
  25053. C    MU     INTEGER
  25054. C             the number of diagonals above the main diagonal.
  25055. C             MU  must not be less than zero nor greater than or
  25056. C             equal to  N .  (terminal error message IND=-6)
  25057. C    V      COMPLEX(N)
  25058. C             on entry, the singly subscripted array(vector) of di-
  25059. C               mension N which contains the right hand side B of a
  25060. C               system of simultaneous linear equations A*X=B.
  25061. C             on return, V contains the solution vector, X .
  25062. C    ITASK  INTEGER
  25063. C             if ITASK = 1, the matrix A is factored and then the
  25064. C               linear equation is solved.
  25065. C             if ITASK .GT. 1, the equation is solved using the existing
  25066. C               factored matrix A and IWORK.
  25067. C             if ITASK .LT. 1, then terminal error message IND=-3 is
  25068. C               printed.
  25069. C    IND    INTEGER
  25070. C             GT. 0  IND is a rough estimate of the number of digits
  25071. C                     of accuracy in the solution, X.
  25072. C             LT. 0  see error message corresponding to IND below.
  25073. C    WORK   COMPLEX(N)
  25074. C             a singly subscripted array of dimension at least N.
  25075. C    IWORK  INTEGER(N)
  25076. C             a singly subscripted array of dimension at least N.
  25077. C
  25078. C  Error Messages Printed ***
  25079. C
  25080. C    IND=-1  terminal   N is greater than LDA.
  25081. C    IND=-2  terminal   N is less than 1.
  25082. C    IND=-3  terminal   ITASK is less than 1.
  25083. C    IND=-4  terminal   The matrix A is computationally singular.
  25084. C                         A solution has not been computed.
  25085. C    IND=-5  terminal   ML is less than zero or is greater than
  25086. C                         or equal to N .
  25087. C    IND=-6  terminal   MU is less than zero or is greater than
  25088. C                         or equal to N .
  25089. C    IND=-10 warning    The solution has no apparent significance.
  25090. C                         The solution may be inaccurate or the matrix
  25091. C                         A may be poorly scaled.
  25092. C
  25093. C               NOTE-  The above terminal(*fatal*) error messages are
  25094. C                      designed to be handled by XERMSG in which
  25095. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  25096. C                      for warning error messages from XERMSG.  Unless
  25097. C                      the user provides otherwise, an error message
  25098. C                      will be printed followed by an abort.
  25099. C
  25100. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  25101. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  25102. C***ROUTINES CALLED  CNBCO, CNBSL, R1MACH, XERMSG
  25103. C***REVISION HISTORY  (YYMMDD)
  25104. C   800813  DATE WRITTEN
  25105. C   890531  Changed all specific intrinsics to generic.  (WRB)
  25106. C   890831  Modified array declarations.  (WRB)
  25107. C   890831  REVISION DATE from Version 3.2
  25108. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25109. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  25110. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  25111. C           IF-THEN-ELSE.  (RWC)
  25112. C   920501  Reformatted the REFERENCES section.  (WRB)
  25113. C***END PROLOGUE  CNBFS
  25114. C
  25115.       INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU
  25116.       COMPLEX ABE(LDA,*),V(*),WORK(*)
  25117.       REAL RCOND
  25118.       REAL R1MACH
  25119.       CHARACTER*8 XERN1, XERN2
  25120. C***FIRST EXECUTABLE STATEMENT  CNBFS
  25121.       IF (LDA.LT.N) THEN
  25122.          IND = -1
  25123.          WRITE (XERN1, '(I8)') LDA
  25124.          WRITE (XERN2, '(I8)') N
  25125.          CALL XERMSG ('SLATEC', 'CNBFS', 'LDA = ' // XERN1 //
  25126.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  25127.          RETURN
  25128.       ENDIF
  25129. C
  25130.       IF (N.LE.0) THEN
  25131.          IND = -2
  25132.          WRITE (XERN1, '(I8)') N
  25133.          CALL XERMSG ('SLATEC', 'CNBFS', 'N = ' // XERN1 //
  25134.      *      ' IS LESS THAN 1', -2, 1)
  25135.          RETURN
  25136.       ENDIF
  25137. C
  25138.       IF (ITASK.LT.1) THEN
  25139.          IND = -3
  25140.          WRITE (XERN1, '(I8)') ITASK
  25141.          CALL XERMSG ('SLATEC', 'CNBFS', 'ITASK = ' // XERN1 //
  25142.      *      ' IS LESS THAN 1', -3, 1)
  25143.          RETURN
  25144.       ENDIF
  25145. C
  25146.       IF (ML.LT.0 .OR. ML.GE.N) THEN
  25147.          IND = -5
  25148.          WRITE (XERN1, '(I8)') ML
  25149.          CALL XERMSG ('SLATEC', 'CNBFS',
  25150.      *      'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1)
  25151.          RETURN
  25152.       ENDIF
  25153. C
  25154.       IF (MU.LT.0 .OR. MU.GE.N) THEN
  25155.          IND = -6
  25156.          WRITE (XERN1, '(I8)') MU
  25157.          CALL XERMSG ('SLATEC', 'CNBFS',
  25158.      *      'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1)
  25159.          RETURN
  25160.       ENDIF
  25161. C
  25162.       IF (ITASK.EQ.1) THEN
  25163. C
  25164. C        FACTOR MATRIX A INTO LU
  25165. C
  25166.          CALL CNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK)
  25167. C
  25168. C        CHECK FOR COMPUTATIONALLY SINGULAR MATRIX
  25169. C
  25170.          IF (RCOND.EQ.0.0) THEN
  25171.             IND = -4
  25172.             CALL XERMSG ('SLATEC', 'CNBFS',
  25173.      *         'SINGULAR MATRIX A - NO SOLUTION', -4, 1)
  25174.             RETURN
  25175.          ENDIF
  25176. C
  25177. C        COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  25178. C        AND CHECK FOR IND GREATER THAN ZERO
  25179. C
  25180.          IND = -LOG10(R1MACH(4)/RCOND)
  25181.          IF (IND.LE.0) THEN
  25182.             IND = -10
  25183.             CALL XERMSG ('SLATEC', 'CNBFS',
  25184.      *         'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  25185.          ENDIF
  25186.       ENDIF
  25187. C
  25188. C     SOLVE AFTER FACTORING
  25189. C
  25190.       CALL CNBSL(ABE,LDA,N,ML,MU,IWORK,V,0)
  25191.       RETURN
  25192.       END
  25193. *DECK CNBIR
  25194.       SUBROUTINE CNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK)
  25195. C***BEGIN PROLOGUE  CNBIR
  25196. C***PURPOSE  Solve a general nonsymmetric banded system of linear
  25197. C            equations.  Iterative refinement is used to obtain an error
  25198. C            estimate.
  25199. C***LIBRARY   SLATEC
  25200. C***CATEGORY  D2C2
  25201. C***TYPE      COMPLEX (SNBIR-S, CNBIR-C)
  25202. C***KEYWORDS  BANDED, LINEAR EQUATIONS, NONSYMMETRIC
  25203. C***AUTHOR  Voorhees, E. A., (LANL)
  25204. C***DESCRIPTION
  25205. C
  25206. C    Subroutine CNBIR solves a general nonsymmetric banded NxN
  25207. C    system of single precision complex linear equations using
  25208. C    SLATEC subroutines CNBFA and CNBSL.  These are adaptations
  25209. C    of the LINPACK subroutines CGBFA and CGBSL which require
  25210. C    a different format for storing the matrix elements.
  25211. C    One pass of iterative refinement is used only to obtain an
  25212. C    estimate of the accuracy.  If  A  is an NxN complex banded
  25213. C    matrix and if  X  and  B  are complex N-vectors, then CNBIR
  25214. C    solves the equation
  25215. C
  25216. C                          A*X=B.
  25217. C
  25218. C    A band matrix is a matrix whose nonzero elements are all
  25219. C    fairly near the main diagonal, specifically  A(I,J) = 0
  25220. C    if  I-J is greater than  ML  or  J-I  is greater than
  25221. C    MU .  The integers ML and MU are called the lower and upper
  25222. C    band widths and  M = ML+MU+1  is the total band width.
  25223. C    CNBIR uses less time and storage than the corresponding
  25224. C    program for general matrices (CGEIR) if 2*ML+MU .LT. N .
  25225. C
  25226. C    The matrix A is first factored into upper and lower tri-
  25227. C    angular matrices U and L using partial pivoting.  These
  25228. C    factors and the pivoting information are used to find the
  25229. C    solution vector X .  Then the residual vector is found and used
  25230. C    to calculate an estimate of the relative error, IND .  IND esti-
  25231. C    mates the accuracy of the solution only when the input matrix
  25232. C    and the right hand side are represented exactly in the computer
  25233. C    and does not take into account any errors in the input data.
  25234. C
  25235. C    If the equation A*X=B is to be solved for more than one vector
  25236. C    B, the factoring of A does not need to be performed again and
  25237. C    the option to only solve (ITASK .GT. 1) will be faster for
  25238. C    the succeeding solutions.  In this case, the contents of A, LDA,
  25239. C    N, WORK and IWORK must not have been altered by the user follow-
  25240. C    ing factorization (ITASK=1).  IND will not be changed by CNBIR
  25241. C    in this case.
  25242. C
  25243. C
  25244. C    Band Storage
  25245. C
  25246. C          If  A  is a band matrix, the following program segment
  25247. C          will set up the input.
  25248. C
  25249. C                  ML = (band width below the diagonal)
  25250. C                  MU = (band width above the diagonal)
  25251. C                  DO 20 I = 1, N
  25252. C                     J1 = MAX(1, I-ML)
  25253. C                     J2 = MIN(N, I+MU)
  25254. C                     DO 10 J = J1, J2
  25255. C                        K = J - I + ML + 1
  25256. C                        ABE(I,K) = A(I,J)
  25257. C               10    CONTINUE
  25258. C               20 CONTINUE
  25259. C
  25260. C          This uses columns  1  through  ML+MU+1  of ABE .
  25261. C
  25262. C    Example:  If the original matrix is
  25263. C
  25264. C          11 12 13  0  0  0
  25265. C          21 22 23 24  0  0
  25266. C           0 32 33 34 35  0
  25267. C           0  0 43 44 45 46
  25268. C           0  0  0 54 55 56
  25269. C           0  0  0  0 65 66
  25270. C
  25271. C     then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
  25272. C
  25273. C           * 11 12 13        , * = not used
  25274. C          21 22 23 24
  25275. C          32 33 34 35
  25276. C          43 44 45 46
  25277. C          54 55 56  *
  25278. C          65 66  *  *
  25279. C
  25280. C
  25281. C  Argument Description ***
  25282. C
  25283. C    ABE    COMPLEX(LDA,MM)
  25284. C             on entry, contains the matrix in band storage as
  25285. C               described above.  MM  must not be less than  M =
  25286. C               ML+MU+1 .  The user is cautioned to dimension  ABE
  25287. C               with care since MM is not an argument and cannot
  25288. C               be checked by CNBIR.  The rows of the original
  25289. C               matrix are stored in the rows of  ABE  and the
  25290. C               diagonals of the original matrix are stored in
  25291. C               columns  1  through  ML+MU+1  of  ABE .  ABE  is
  25292. C               not altered by the program.
  25293. C    LDA    INTEGER
  25294. C             the leading dimension of array ABE.  LDA must be great-
  25295. C             er than or equal to N.  (terminal error message IND=-1)
  25296. C    N      INTEGER
  25297. C             the order of the matrix A.  N must be greater
  25298. C             than or equal to 1 .  (terminal error message IND=-2)
  25299. C    ML     INTEGER
  25300. C             the number of diagonals below the main diagonal.
  25301. C             ML  must not be less than zero nor greater than or
  25302. C             equal to  N .  (terminal error message IND=-5)
  25303. C    MU     INTEGER
  25304. C             the number of diagonals above the main diagonal.
  25305. C             MU  must not be less than zero nor greater than or
  25306. C             equal to  N .  (terminal error message IND=-6)
  25307. C    V      COMPLEX(N)
  25308. C             on entry, the singly subscripted array(vector) of di-
  25309. C               mension N which contains the right hand side B of a
  25310. C               system of simultaneous linear equations A*X=B.
  25311. C             on return, V contains the solution vector, X .
  25312. C    ITASK  INTEGER
  25313. C             if ITASK=1, the matrix A is factored and then the
  25314. C               linear equation is solved.
  25315. C             if ITASK .GT. 1, the equation is solved using the existing
  25316. C               factored matrix A and IWORK.
  25317. C             if ITASK .LT. 1, then terminal error message IND=-3 is
  25318. C               printed.
  25319. C    IND    INTEGER
  25320. C             GT. 0  IND is a rough estimate of the number of digits
  25321. C                     of accuracy in the solution, X .  IND=75 means
  25322. C                     that the solution vector  X  is zero.
  25323. C             LT. 0  see error message corresponding to IND below.
  25324. C    WORK   COMPLEX(N*(NC+1))
  25325. C             a singly subscripted array of dimension at least
  25326. C             N*(NC+1)  where  NC = 2*ML+MU+1 .
  25327. C    IWORK  INTEGER(N)
  25328. C             a singly subscripted array of dimension at least N.
  25329. C
  25330. C  Error Messages Printed ***
  25331. C
  25332. C    IND=-1  terminal   N is greater than LDA.
  25333. C    IND=-2  terminal   N is less than 1.
  25334. C    IND=-3  terminal   ITASK is less than 1.
  25335. C    IND=-4  terminal   The matrix A is computationally singular.
  25336. C                         A solution has not been computed.
  25337. C    IND=-5  terminal   ML is less than zero or is greater than
  25338. C                         or equal to N .
  25339. C    IND=-6  terminal   MU is less than zero or is greater than
  25340. C                         or equal to N .
  25341. C    IND=-10 warning    The solution has no apparent significance.
  25342. C                         The solution may be inaccurate or the matrix
  25343. C                         A may be poorly scaled.
  25344. C
  25345. C               NOTE-  The above terminal(*fatal*) error messages are
  25346. C                      designed to be handled by XERMSG in which
  25347. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  25348. C                      for warning error messages from XERMSG.  Unless
  25349. C                      the user provides otherwise, an error message
  25350. C                      will be printed followed by an abort.
  25351. C
  25352. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  25353. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  25354. C***ROUTINES CALLED  CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG
  25355. C***REVISION HISTORY  (YYMMDD)
  25356. C   800819  DATE WRITTEN
  25357. C   890531  Changed all specific intrinsics to generic.  (WRB)
  25358. C   890831  Modified array declarations.  (WRB)
  25359. C   890831  REVISION DATE from Version 3.2
  25360. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25361. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  25362. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  25363. C           IF-THEN-ELSE.  (RWC)
  25364. C   920501  Reformatted the REFERENCES section.  (WRB)
  25365. C***END PROLOGUE  CNBIR
  25366. C
  25367.       INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC
  25368.       COMPLEX ABE(LDA,*),V(*),WORK(N,*),CDCDOT
  25369.       REAL XNORM,DNORM,SCASUM,R1MACH
  25370.       CHARACTER*8 XERN1, XERN2
  25371. C***FIRST EXECUTABLE STATEMENT  CNBIR
  25372.       IF (LDA.LT.N) THEN
  25373.          IND = -1
  25374.          WRITE (XERN1, '(I8)') LDA
  25375.          WRITE (XERN2, '(I8)') N
  25376.          CALL XERMSG ('SLATEC', 'CNBIR', 'LDA = ' // XERN1 //
  25377.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  25378.          RETURN
  25379.       ENDIF
  25380. C
  25381.       IF (N.LE.0) THEN
  25382.          IND = -2
  25383.          WRITE (XERN1, '(I8)') N
  25384.          CALL XERMSG ('SLATEC', 'CNBIR', 'N = ' // XERN1 //
  25385.      *      ' IS LESS THAN 1', -2, 1)
  25386.          RETURN
  25387.       ENDIF
  25388. C
  25389.       IF (ITASK.LT.1) THEN
  25390.          IND = -3
  25391.          WRITE (XERN1, '(I8)') ITASK
  25392.          CALL XERMSG ('SLATEC', 'CNBIR', 'ITASK = ' // XERN1 //
  25393.      *      ' IS LESS THAN 1', -3, 1)
  25394.          RETURN
  25395.       ENDIF
  25396. C
  25397.       IF (ML.LT.0 .OR. ML.GE.N) THEN
  25398.          IND = -5
  25399.          WRITE (XERN1, '(I8)') ML
  25400.          CALL XERMSG ('SLATEC', 'CNBIR',
  25401.      *      'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1)
  25402.          RETURN
  25403.       ENDIF
  25404. C
  25405.       IF (MU.LT.0 .OR. MU.GE.N) THEN
  25406.          IND = -6
  25407.          WRITE (XERN1, '(I8)') MU
  25408.          CALL XERMSG ('SLATEC', 'CNBIR',
  25409.      *      'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1)
  25410.          RETURN
  25411.       ENDIF
  25412. C
  25413.       NC = 2*ML+MU+1
  25414.       IF (ITASK.EQ.1) THEN
  25415. C
  25416. C        MOVE MATRIX ABE TO WORK
  25417. C
  25418.          M=ML+MU+1
  25419.          DO 10 J=1,M
  25420.             CALL CCOPY(N,ABE(1,J),1,WORK(1,J),1)
  25421.    10    CONTINUE
  25422. C
  25423. C        FACTOR MATRIX A INTO LU
  25424.          CALL CNBFA(WORK,N,N,ML,MU,IWORK,INFO)
  25425. C
  25426. C        CHECK FOR COMPUTATIONALLY SINGULAR MATRIX
  25427.          IF (INFO.NE.0) THEN
  25428.             IND=-4
  25429.             CALL XERMSG ('SLATEC', 'CNBIR',
  25430.      *         'SINGULAR MATRIX A - NO SOLUTION', -4, 1)
  25431.             RETURN
  25432.          ENDIF
  25433.       ENDIF
  25434. C
  25435. C     SOLVE WHEN FACTORING COMPLETE
  25436. C     MOVE VECTOR B TO WORK
  25437. C
  25438.       CALL CCOPY(N,V(1),1,WORK(1,NC+1),1)
  25439.       CALL CNBSL(WORK,N,N,ML,MU,IWORK,V,0)
  25440. C
  25441. C     FORM NORM OF X0
  25442. C
  25443.       XNORM = SCASUM(N,V(1),1)
  25444.       IF (XNORM.EQ.0.0) THEN
  25445.          IND = 75
  25446.          RETURN
  25447.       ENDIF
  25448. C
  25449. C     COMPUTE  RESIDUAL
  25450. C
  25451.       DO 40 J=1,N
  25452.          K  = MAX(1,ML+2-J)
  25453.          KK = MAX(1,J-ML)
  25454.          L  = MIN(J-1,ML)+MIN(N-J,MU)+1
  25455.          WORK(J,NC+1) = CDCDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1)
  25456.    40 CONTINUE
  25457. C
  25458. C     SOLVE A*DELTA=R
  25459. C
  25460.       CALL CNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0)
  25461. C
  25462. C     FORM NORM OF DELTA
  25463. C
  25464.       DNORM = SCASUM(N,WORK(1,NC+1),1)
  25465. C
  25466. C     COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  25467. C     AND CHECK FOR IND GREATER THAN ZERO
  25468. C
  25469.       IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM))
  25470.       IF (IND.LE.0) THEN
  25471.          IND = -10
  25472.          CALL XERMSG ('SLATEC', 'CNBIR',
  25473.      *      'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  25474.       ENDIF
  25475.       RETURN
  25476.       END
  25477. *DECK CNBSL
  25478.       SUBROUTINE CNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB)
  25479. C***BEGIN PROLOGUE  CNBSL
  25480. C***PURPOSE  Solve a complex band system using the factors computed by
  25481. C            CNBCO or CNBFA.
  25482. C***LIBRARY   SLATEC
  25483. C***CATEGORY  D2C2
  25484. C***TYPE      COMPLEX (SNBSL-S, DNBSL-D, CNBSL-C)
  25485. C***KEYWORDS  BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE
  25486. C***AUTHOR  Voorhees, E. A., (LANL)
  25487. C***DESCRIPTION
  25488. C
  25489. C     CNBSL solves the complex band system
  25490. C     A * X = B  or  CTRANS(A) * X = B
  25491. C     using the factors computed by CNBCO or CNBFA.
  25492. C
  25493. C     On Entry
  25494. C
  25495. C        ABE     COMPLEX(LDA, NC)
  25496. C                the output from CNBCO or CNBFA.
  25497. C                NC must be .GE. 2*ML+MU+1 .
  25498. C
  25499. C        LDA     INTEGER
  25500. C                the leading dimension of the array  ABE .
  25501. C
  25502. C        N       INTEGER
  25503. C                the order of the original matrix.
  25504. C
  25505. C        ML      INTEGER
  25506. C                number of diagonals below the main diagonal.
  25507. C
  25508. C        MU      INTEGER
  25509. C                number of diagonals above the main diagonal.
  25510. C
  25511. C        IPVT    INTEGER(N)
  25512. C                the pivot vector from CNBCO or CNBFA.
  25513. C
  25514. C        B       COMPLEX(N)
  25515. C                the right hand side vector.
  25516. C
  25517. C        JOB     INTEGER
  25518. C                = 0         to solve  A*X = B .
  25519. C                = nonzero   to solve  CTRANS(A)*X = B , where
  25520. C                            CTRANS(A)  is the conjugate transpose.
  25521. C
  25522. C     On Return
  25523. C
  25524. C        B       the solution vector  X .
  25525. C
  25526. C     Error Condition
  25527. C
  25528. C        A division by zero will occur if the input factor contains a
  25529. C        zero on the diagonal.  Technically this indicates singularity
  25530. C        but it is often caused by improper arguments or improper
  25531. C        setting of LDA.  It will not occur if the subroutines are
  25532. C        called correctly and if CNBCO has set RCOND .GT. 0.0
  25533. C        or CNBFA has set INFO .EQ. 0 .
  25534. C
  25535. C     To compute  INVERSE(A) * C  where  C  is a matrix
  25536. C     with  P  columns
  25537. C           CALL CNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z)
  25538. C           IF (RCOND is too small) GO TO ...
  25539. C           DO 10 J = 1, P
  25540. C             CALL CNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0)
  25541. C        10 CONTINUE
  25542. C
  25543. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  25544. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  25545. C***ROUTINES CALLED  CAXPY, CDOTC
  25546. C***REVISION HISTORY  (YYMMDD)
  25547. C   800730  DATE WRITTEN
  25548. C   890531  Changed all specific intrinsics to generic.  (WRB)
  25549. C   890831  Modified array declarations.  (WRB)
  25550. C   890831  REVISION DATE from Version 3.2
  25551. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25552. C   920501  Reformatted the REFERENCES section.  (WRB)
  25553. C***END PROLOGUE  CNBSL
  25554.       INTEGER LDA,N,ML,MU,IPVT(*),JOB
  25555.       COMPLEX ABE(LDA,*),B(*)
  25556. C
  25557.       COMPLEX CDOTC,T
  25558.       INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1
  25559. C***FIRST EXECUTABLE STATEMENT  CNBSL
  25560.       M=MU+ML+1
  25561.       NM1=N-1
  25562.       LDB=1-LDA
  25563.       IF(JOB.NE.0)GO TO 50
  25564. C
  25565. C       JOB = 0 , SOLVE  A * X = B
  25566. C       FIRST SOLVE L*Y = B
  25567. C
  25568.         IF(ML.EQ.0)GO TO 30
  25569.         IF(NM1.LT.1)GO TO 30
  25570.           DO 20 K=1,NM1
  25571.             LM=MIN(ML,N-K)
  25572.             L=IPVT(K)
  25573.             T=B(L)
  25574.             IF(L.EQ.K)GO TO 10
  25575.               B(L)=B(K)
  25576.               B(K)=T
  25577.    10       CONTINUE
  25578.             MLM=ML-(LM-1)
  25579.             CALL CAXPY(LM,T,ABE(K+LM,MLM),LDB,B(K+1),1)
  25580.    20     CONTINUE
  25581.    30   CONTINUE
  25582. C
  25583. C       NOW SOLVE  U*X = Y
  25584. C
  25585.         DO 40 KB=1,N
  25586.           K=N+1-KB
  25587.           B(K)=B(K)/ABE(K,ML+1)
  25588.           LM=MIN(K,M)-1
  25589.           LB=K-LM
  25590.           T=-B(K)
  25591.           CALL CAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1)
  25592.    40   CONTINUE
  25593.       GO TO 100
  25594.    50 CONTINUE
  25595. C
  25596. C       JOB = NONZERO, SOLVE CTRANS(A) * X = B
  25597. C       FIRST SOLVE  CTRANS(U)*Y = B
  25598. C
  25599.         DO 60 K = 1, N
  25600.           LM = MIN(K,M) - 1
  25601.           LB = K - LM
  25602.           T = CDOTC(LM,ABE(K-1,ML+2),LDB,B(LB),1)
  25603.           B(K) = (B(K) - T)/CONJG(ABE(K,ML+1))
  25604.    60   CONTINUE
  25605. C
  25606. C       NOW SOLVE CTRANS(L)*X = Y
  25607. C
  25608.         IF (ML .EQ. 0) GO TO 90
  25609.         IF (NM1 .LT. 1) GO TO 90
  25610.           DO 80 KB = 1, NM1
  25611.             K = N - KB
  25612.             LM = MIN(ML,N-K)
  25613.             MLM = ML - (LM - 1)
  25614.             B(K) = B(K) + CDOTC(LM,ABE(K+LM,MLM),LDB,B(K+1),1)
  25615.             L = IPVT(K)
  25616.             IF (L .EQ. K) GO TO 70
  25617.               T = B(L)
  25618.               B(L) = B(K)
  25619.               B(K) = T
  25620.    70       CONTINUE
  25621.    80     CONTINUE
  25622.    90   CONTINUE
  25623.   100 CONTINUE
  25624.       RETURN
  25625.       END
  25626. *DECK COMBAK
  25627.       SUBROUTINE COMBAK (NM, LOW, IGH, AR, AI, INT, M, ZR, ZI)
  25628. C***BEGIN PROLOGUE  COMBAK
  25629. C***PURPOSE  Form the eigenvectors of a complex general matrix from the
  25630. C            eigenvectors of a upper Hessenberg matrix output from
  25631. C            COMHES.
  25632. C***LIBRARY   SLATEC (EISPACK)
  25633. C***CATEGORY  D4C4
  25634. C***TYPE      COMPLEX (ELMBAK-S, COMBAK-C)
  25635. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  25636. C***AUTHOR  Smith, B. T., et al.
  25637. C***DESCRIPTION
  25638. C
  25639. C     This subroutine is a translation of the ALGOL procedure COMBAK,
  25640. C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
  25641. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  25642. C
  25643. C     This subroutine forms the eigenvectors of a COMPLEX GENERAL
  25644. C     matrix by back transforming those of the corresponding
  25645. C     upper Hessenberg matrix determined by  COMHES.
  25646. C
  25647. C     On INPUT
  25648. C
  25649. C        NM must be set to the row dimension of the two-dimensional
  25650. C          array parameters, AR, AI, ZR and ZI, as declared in the
  25651. C          calling program dimension statement.  NM is an INTEGER
  25652. C          variable.
  25653. C
  25654. C        LOW and IGH are two INTEGER variables determined by the
  25655. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  25656. C          set LOW=1 and IGH equal to the order of the matrix.
  25657. C
  25658. C        AR and AI contain the multipliers which were used in the
  25659. C           reduction by  COMHES  in their lower triangles below
  25660. C           the subdiagonal.  AR and AI are two-dimensional REAL
  25661. C           arrays, dimensioned AR(NM,IGH) and AI(NM,IGH).
  25662. C
  25663. C        INT contains information on the rows and columns
  25664. C          interchanged in the reduction by  COMHES.  Only
  25665. C          elements LOW through IGH are used.  INT is a
  25666. C          one-dimensional INTEGER array, dimensioned INT(IGH).
  25667. C
  25668. C        M is the number of eigenvectors to be back transformed.
  25669. C          M is an INTEGER variable.
  25670. C
  25671. C        ZR and ZI contain the real and imaginary parts, respectively,
  25672. C          of the eigenvectors to be back transformed in their first M
  25673. C          columns.  ZR and ZI are two-dimensional REAL arrays,
  25674. C          dimensioned ZR(NM,M) and ZI(NM,M).
  25675. C
  25676. C     On OUTPUT
  25677. C
  25678. C        ZR and ZI contain the real and imaginary parts, respectively,
  25679. C          of the transformed eigenvectors in their first M columns.
  25680. C
  25681. C     Questions and comments should be directed to B. S. Garbow,
  25682. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  25683. C     ------------------------------------------------------------------
  25684. C
  25685. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  25686. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  25687. C                 system Routines - EISPACK Guide, Springer-Verlag,
  25688. C                 1976.
  25689. C***ROUTINES CALLED  (NONE)
  25690. C***REVISION HISTORY  (YYMMDD)
  25691. C   760101  DATE WRITTEN
  25692. C   890831  Modified array declarations.  (WRB)
  25693. C   890831  REVISION DATE from Version 3.2
  25694. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25695. C   920501  Reformatted the REFERENCES section.  (WRB)
  25696. C***END PROLOGUE  COMBAK
  25697. C
  25698.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  25699.       REAL AR(NM,*),AI(NM,*),ZR(NM,*),ZI(NM,*)
  25700.       REAL XR,XI
  25701.       INTEGER INT(*)
  25702. C
  25703. C***FIRST EXECUTABLE STATEMENT  COMBAK
  25704.       IF (M .EQ. 0) GO TO 200
  25705.       LA = IGH - 1
  25706.       KP1 = LOW + 1
  25707.       IF (LA .LT. KP1) GO TO 200
  25708. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  25709.       DO 140 MM = KP1, LA
  25710.          MP = LOW + IGH - MM
  25711.          MP1 = MP + 1
  25712. C
  25713.          DO 110 I = MP1, IGH
  25714.             XR = AR(I,MP-1)
  25715.             XI = AI(I,MP-1)
  25716.             IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 110
  25717. C
  25718.             DO 100 J = 1, M
  25719.                ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J)
  25720.                ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J)
  25721.   100       CONTINUE
  25722. C
  25723.   110    CONTINUE
  25724. C
  25725.          I = INT(MP)
  25726.          IF (I .EQ. MP) GO TO 140
  25727. C
  25728.          DO 130 J = 1, M
  25729.             XR = ZR(I,J)
  25730.             ZR(I,J) = ZR(MP,J)
  25731.             ZR(MP,J) = XR
  25732.             XI = ZI(I,J)
  25733.             ZI(I,J) = ZI(MP,J)
  25734.             ZI(MP,J) = XI
  25735.   130    CONTINUE
  25736. C
  25737.   140 CONTINUE
  25738. C
  25739.   200 RETURN
  25740.       END
  25741. *DECK COMHES
  25742.       SUBROUTINE COMHES (NM, N, LOW, IGH, AR, AI, INT)
  25743. C***BEGIN PROLOGUE  COMHES
  25744. C***PURPOSE  Reduce a complex general matrix to complex upper Hessenberg
  25745. C            form using stabilized elementary similarity
  25746. C            transformations.
  25747. C***LIBRARY   SLATEC (EISPACK)
  25748. C***CATEGORY  D4C1B2
  25749. C***TYPE      COMPLEX (ELMHES-S, COMHES-C)
  25750. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  25751. C***AUTHOR  Smith, B. T., et al.
  25752. C***DESCRIPTION
  25753. C
  25754. C     This subroutine is a translation of the ALGOL procedure COMHES,
  25755. C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
  25756. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  25757. C
  25758. C     Given a COMPLEX GENERAL matrix, this subroutine
  25759. C     reduces a submatrix situated in rows and columns
  25760. C     LOW through IGH to upper Hessenberg form by
  25761. C     stabilized elementary similarity transformations.
  25762. C
  25763. C     On INPUT
  25764. C
  25765. C        NM must be set to the row dimension of the two-dimensional
  25766. C          array parameters, AR and AI, as declared in the calling
  25767. C          program dimension statement.  NM is an INTEGER variable.
  25768. C
  25769. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  25770. C          variable.  N must be less than or equal to NM.
  25771. C
  25772. C        LOW and IGH are two INTEGER variables determined by the
  25773. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  25774. C          set LOW=1 and IGH equal to the order of the matrix, N.
  25775. C
  25776. C        AR and AI contain the real and imaginary parts, respectively,
  25777. C          of the complex input matrix.  AR and AI are two-dimensional
  25778. C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
  25779. C
  25780. C     On OUTPUT
  25781. C
  25782. C        AR and AI contain the real and imaginary parts, respectively,
  25783. C          of the upper Hessenberg matrix.  The multipliers which
  25784. C          were used in the reduction are stored in the remaining
  25785. C          triangles under the Hessenberg matrix.
  25786. C
  25787. C        INT contains information on the rows and columns
  25788. C          interchanged in the reduction.  Only elements LOW through
  25789. C          IGH are used.  INT is a one-dimensional INTEGER array,
  25790. C          dimensioned INT(IGH).
  25791. C
  25792. C     Calls CDIV for complex division.
  25793. C
  25794. C     Questions and comments should be directed to B. S. Garbow,
  25795. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  25796. C     ------------------------------------------------------------------
  25797. C
  25798. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  25799. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  25800. C                 system Routines - EISPACK Guide, Springer-Verlag,
  25801. C                 1976.
  25802. C***ROUTINES CALLED  CDIV
  25803. C***REVISION HISTORY  (YYMMDD)
  25804. C   760101  DATE WRITTEN
  25805. C   890831  Modified array declarations.  (WRB)
  25806. C   890831  REVISION DATE from Version 3.2
  25807. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25808. C   920501  Reformatted the REFERENCES section.  (WRB)
  25809. C***END PROLOGUE  COMHES
  25810. C
  25811.       INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
  25812.       REAL AR(NM,*),AI(NM,*)
  25813.       REAL XR,XI,YR,YI
  25814.       INTEGER INT(*)
  25815. C
  25816. C***FIRST EXECUTABLE STATEMENT  COMHES
  25817.       LA = IGH - 1
  25818.       KP1 = LOW + 1
  25819.       IF (LA .LT. KP1) GO TO 200
  25820. C
  25821.       DO 180 M = KP1, LA
  25822.          MM1 = M - 1
  25823.          XR = 0.0E0
  25824.          XI = 0.0E0
  25825.          I = M
  25826. C
  25827.          DO 100 J = M, IGH
  25828.             IF (ABS(AR(J,MM1)) + ABS(AI(J,MM1))
  25829.      1         .LE. ABS(XR) + ABS(XI)) GO TO 100
  25830.             XR = AR(J,MM1)
  25831.             XI = AI(J,MM1)
  25832.             I = J
  25833.   100    CONTINUE
  25834. C
  25835.          INT(M) = I
  25836.          IF (I .EQ. M) GO TO 130
  25837. C     .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
  25838.          DO 110 J = MM1, N
  25839.             YR = AR(I,J)
  25840.             AR(I,J) = AR(M,J)
  25841.             AR(M,J) = YR
  25842.             YI = AI(I,J)
  25843.             AI(I,J) = AI(M,J)
  25844.             AI(M,J) = YI
  25845.   110    CONTINUE
  25846. C
  25847.          DO 120 J = 1, IGH
  25848.             YR = AR(J,I)
  25849.             AR(J,I) = AR(J,M)
  25850.             AR(J,M) = YR
  25851.             YI = AI(J,I)
  25852.             AI(J,I) = AI(J,M)
  25853.             AI(J,M) = YI
  25854.   120    CONTINUE
  25855. C     .......... END INTERCHANGE ..........
  25856.   130    IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 180
  25857.          MP1 = M + 1
  25858. C
  25859.          DO 160 I = MP1, IGH
  25860.             YR = AR(I,MM1)
  25861.             YI = AI(I,MM1)
  25862.             IF (YR .EQ. 0.0E0 .AND. YI .EQ. 0.0E0) GO TO 160
  25863.             CALL CDIV(YR,YI,XR,XI,YR,YI)
  25864.             AR(I,MM1) = YR
  25865.             AI(I,MM1) = YI
  25866. C
  25867.             DO 140 J = M, N
  25868.                AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J)
  25869.                AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J)
  25870.   140       CONTINUE
  25871. C
  25872.             DO 150 J = 1, IGH
  25873.                AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I)
  25874.                AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I)
  25875.   150       CONTINUE
  25876. C
  25877.   160    CONTINUE
  25878. C
  25879.   180 CONTINUE
  25880. C
  25881.   200 RETURN
  25882.       END
  25883. *DECK COMLR
  25884.       SUBROUTINE COMLR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR)
  25885. C***BEGIN PROLOGUE  COMLR
  25886. C***PURPOSE  Compute the eigenvalues of a complex upper Hessenberg
  25887. C            matrix using the modified LR method.
  25888. C***LIBRARY   SLATEC (EISPACK)
  25889. C***CATEGORY  D4C2B
  25890. C***TYPE      COMPLEX (COMLR-C)
  25891. C***KEYWORDS  EIGENVALUES, EISPACK, LR METHOD
  25892. C***AUTHOR  Smith, B. T., et al.
  25893. C***DESCRIPTION
  25894. C
  25895. C     This subroutine is a translation of the ALGOL procedure COMLR,
  25896. C     NUM. MATH. 12, 369-376(1968) by Martin and Wilkinson.
  25897. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
  25898. C
  25899. C     This subroutine finds the eigenvalues of a COMPLEX
  25900. C     UPPER Hessenberg matrix by the modified LR method.
  25901. C
  25902. C     On INPUT
  25903. C
  25904. C        NM must be set to the row dimension of the two-dimensional
  25905. C          array parameters, HR and HI, as declared in the calling
  25906. C          program dimension statement.  NM is an INTEGER variable.
  25907. C
  25908. C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
  25909. C          variable.  N must be less than or equal to NM.
  25910. C
  25911. C        LOW and IGH are two INTEGER variables determined by the
  25912. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  25913. C          set LOW=1 and IGH equal to the order of the matrix, N.
  25914. C
  25915. C        HR and HI contain the real and imaginary parts, respectively,
  25916. C          of the complex upper Hessenberg matrix.  Their lower
  25917. C          triangles below the subdiagonal contain the multipliers
  25918. C          which were used in the reduction by  COMHES, if performed.
  25919. C          HR and HI are two-dimensional REAL arrays, dimensioned
  25920. C          HR(NM,N) and HI(NM,N).
  25921. C
  25922. C     On OUTPUT
  25923. C
  25924. C        The upper Hessenberg portions of HR and HI have been
  25925. C          destroyed.  Therefore, they must be saved before calling
  25926. C          COMLR  if subsequent calculation of eigenvectors is to
  25927. C          be performed.
  25928. C
  25929. C        WR and WI contain the real and imaginary parts, respectively,
  25930. C          of the eigenvalues of the upper Hessenberg matrix.  If an
  25931. C          error exit is made, the eigenvalues should be correct for
  25932. C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
  25933. C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
  25934. C
  25935. C        IERR is an INTEGER flag set to
  25936. C          Zero       for normal return,
  25937. C          J          if the J-th eigenvalue has not been
  25938. C                     determined after a total of 30*N iterations.
  25939. C                     The eigenvalues should be correct for indices
  25940. C                     IERR+1, IERR+2, ..., N.
  25941. C
  25942. C     Calls CSROOT for complex square root.
  25943. C     Calls CDIV for complex division.
  25944. C
  25945. C     Questions and comments should be directed to B. S. Garbow,
  25946. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  25947. C     ------------------------------------------------------------------
  25948. C
  25949. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  25950. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  25951. C                 system Routines - EISPACK Guide, Springer-Verlag,
  25952. C                 1976.
  25953. C***ROUTINES CALLED  CDIV, CSROOT
  25954. C***REVISION HISTORY  (YYMMDD)
  25955. C   760101  DATE WRITTEN
  25956. C   890831  Modified array declarations.  (WRB)
  25957. C   890831  REVISION DATE from Version 3.2
  25958. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25959. C   920501  Reformatted the REFERENCES section.  (WRB)
  25960. C***END PROLOGUE  COMLR
  25961. C
  25962.       INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR
  25963.       REAL HR(NM,*),HI(NM,*),WR(*),WI(*)
  25964.       REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,S1,S2
  25965. C
  25966. C***FIRST EXECUTABLE STATEMENT  COMLR
  25967.       IERR = 0
  25968. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  25969.       DO 200 I = 1, N
  25970.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  25971.          WR(I) = HR(I,I)
  25972.          WI(I) = HI(I,I)
  25973.   200 CONTINUE
  25974. C
  25975.       EN = IGH
  25976.       TR = 0.0E0
  25977.       TI = 0.0E0
  25978.       ITN = 30*N
  25979. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  25980.   220 IF (EN .LT. LOW) GO TO 1001
  25981.       ITS = 0
  25982.       ENM1 = EN - 1
  25983. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  25984. C                FOR L=EN STEP -1 UNTIL LOW E0 -- ..........
  25985.   240 DO 260 LL = LOW, EN
  25986.          L = EN + LOW - LL
  25987.          IF (L .EQ. LOW) GO TO 300
  25988.          S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
  25989.      1             + ABS(HR(L,L)) + ABS(HI(L,L))
  25990.          S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1))
  25991.          IF (S2 .EQ. S1) GO TO 300
  25992.   260 CONTINUE
  25993. C     .......... FORM SHIFT ..........
  25994.   300 IF (L .EQ. EN) GO TO 660
  25995.       IF (ITN .EQ. 0) GO TO 1000
  25996.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  25997.       SR = HR(EN,EN)
  25998.       SI = HI(EN,EN)
  25999.       XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
  26000.       XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
  26001.       IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
  26002.       YR = (HR(ENM1,ENM1) - SR) / 2.0E0
  26003.       YI = (HI(ENM1,ENM1) - SI) / 2.0E0
  26004.       CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
  26005.       IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
  26006.       ZZR = -ZZR
  26007.       ZZI = -ZZI
  26008.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  26009.       SR = SR - XR
  26010.       SI = SI - XI
  26011.       GO TO 340
  26012. C     .......... FORM EXCEPTIONAL SHIFT ..........
  26013.   320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
  26014.       SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2))
  26015. C
  26016.   340 DO 360 I = LOW, EN
  26017.          HR(I,I) = HR(I,I) - SR
  26018.          HI(I,I) = HI(I,I) - SI
  26019.   360 CONTINUE
  26020. C
  26021.       TR = TR + SR
  26022.       TI = TI + SI
  26023.       ITS = ITS + 1
  26024.       ITN = ITN - 1
  26025. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  26026. C                SUB-DIAGONAL ELEMENTS ..........
  26027.       XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1))
  26028.       YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1))
  26029.       ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN))
  26030. C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
  26031.       DO 380 MM = L, ENM1
  26032.          M = ENM1 + L - MM
  26033.          IF (M .EQ. L) GO TO 420
  26034.          YI = YR
  26035.          YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1))
  26036.          XI = ZZR
  26037.          ZZR = XR
  26038.          XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1))
  26039.          S1 = ZZR / YI * (ZZR + XR + XI)
  26040.          S2 = S1 + YR
  26041.          IF (S2 .EQ. S1) GO TO 420
  26042.   380 CONTINUE
  26043. C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  26044.   420 MP1 = M + 1
  26045. C
  26046.       DO 520 I = MP1, EN
  26047.          IM1 = I - 1
  26048.          XR = HR(IM1,IM1)
  26049.          XI = HI(IM1,IM1)
  26050.          YR = HR(I,IM1)
  26051.          YI = HI(I,IM1)
  26052.          IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460
  26053. C     .......... INTERCHANGE ROWS OF HR AND HI ..........
  26054.          DO 440 J = IM1, EN
  26055.             ZZR = HR(IM1,J)
  26056.             HR(IM1,J) = HR(I,J)
  26057.             HR(I,J) = ZZR
  26058.             ZZI = HI(IM1,J)
  26059.             HI(IM1,J) = HI(I,J)
  26060.             HI(I,J) = ZZI
  26061.   440    CONTINUE
  26062. C
  26063.          CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
  26064.          WR(I) = 1.0E0
  26065.          GO TO 480
  26066.   460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
  26067.          WR(I) = -1.0E0
  26068.   480    HR(I,IM1) = ZZR
  26069.          HI(I,IM1) = ZZI
  26070. C
  26071.          DO 500 J = I, EN
  26072.             HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
  26073.             HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  26074.   500    CONTINUE
  26075. C
  26076.   520 CONTINUE
  26077. C     .......... COMPOSITION R*L=H ..........
  26078.       DO 640 J = MP1, EN
  26079.          XR = HR(J,J-1)
  26080.          XI = HI(J,J-1)
  26081.          HR(J,J-1) = 0.0E0
  26082.          HI(J,J-1) = 0.0E0
  26083. C     .......... INTERCHANGE COLUMNS OF HR AND HI,
  26084. C                IF NECESSARY ..........
  26085.          IF (WR(J) .LE. 0.0E0) GO TO 580
  26086. C
  26087.          DO 540 I = L, J
  26088.             ZZR = HR(I,J-1)
  26089.             HR(I,J-1) = HR(I,J)
  26090.             HR(I,J) = ZZR
  26091.             ZZI = HI(I,J-1)
  26092.             HI(I,J-1) = HI(I,J)
  26093.             HI(I,J) = ZZI
  26094.   540    CONTINUE
  26095. C
  26096.   580    DO 600 I = L, J
  26097.             HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
  26098.             HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  26099.   600    CONTINUE
  26100. C
  26101.   640 CONTINUE
  26102. C
  26103.       GO TO 240
  26104. C     .......... A ROOT FOUND ..........
  26105.   660 WR(EN) = HR(EN,EN) + TR
  26106.       WI(EN) = HI(EN,EN) + TI
  26107.       EN = ENM1
  26108.       GO TO 220
  26109. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  26110. C                EIGENVALUE AFTER 30*N ITERATIONS ..........
  26111.  1000 IERR = EN
  26112.  1001 RETURN
  26113.       END
  26114. *DECK COMLR2
  26115.       SUBROUTINE COMLR2 (NM, N, LOW, IGH, INT, HR, HI, WR, WI, ZR, ZI,
  26116.      +   IERR)
  26117. C***BEGIN PROLOGUE  COMLR2
  26118. C***PURPOSE  Compute the eigenvalues and eigenvectors of a complex upper
  26119. C            Hessenberg matrix using the modified LR method.
  26120. C***LIBRARY   SLATEC (EISPACK)
  26121. C***CATEGORY  D4C2B
  26122. C***TYPE      COMPLEX (COMLR2-C)
  26123. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK, LR METHOD
  26124. C***AUTHOR  Smith, B. T., et al.
  26125. C***DESCRIPTION
  26126. C
  26127. C     This subroutine is a translation of the ALGOL procedure COMLR2,
  26128. C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
  26129. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  26130. C
  26131. C     This subroutine finds the eigenvalues and eigenvectors
  26132. C     of a COMPLEX UPPER Hessenberg matrix by the modified LR
  26133. C     method.  The eigenvectors of a COMPLEX GENERAL matrix
  26134. C     can also be found if  COMHES  has been used to reduce
  26135. C     this general matrix to Hessenberg form.
  26136. C
  26137. C     On INPUT
  26138. C
  26139. C        NM must be set to the row dimension of the two-dimensional
  26140. C          array parameters, HR, HI, ZR and ZI, as declared in the
  26141. C          calling program dimension statement.  NM is an INTEGER
  26142. C          variable.
  26143. C
  26144. C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
  26145. C          variable.  N must be less than or equal to NM.
  26146. C
  26147. C        LOW and IGH are two INTEGER variables determined by the
  26148. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  26149. C          set LOW=1 and IGH equal to the order of the matrix, N.
  26150. C
  26151. C        INT contains information on the rows and columns
  26152. C          interchanged in the reduction by  COMHES, if performed.
  26153. C          Only elements LOW through IGH are used.  If you want the
  26154. C          eigenvectors of a complex general matrix, leave INT as it
  26155. C          came from  COMHES.  If the eigenvectors of the Hessenberg
  26156. C          matrix are desired, set INT(J)=J for these elements.  INT
  26157. C          is a one-dimensional INTEGER array, dimensioned INT(IGH).
  26158. C
  26159. C        HR and HI contain the real and imaginary parts, respectively,
  26160. C          of the complex upper Hessenberg matrix.  Their lower
  26161. C          triangles below the subdiagonal contain the multipliers
  26162. C          which were used in the reduction by  COMHES, if performed.
  26163. C          If the eigenvectors of a complex general matrix are
  26164. C          desired, leave these multipliers in the lower triangles.
  26165. C          If the eigenvectors of the Hessenberg matrix are desired,
  26166. C          these elements must be set to zero.  HR and HI are
  26167. C          two-dimensional REAL arrays, dimensioned HR(NM,N) and
  26168. C          HI(NM,N).
  26169. C
  26170. C     On OUTPUT
  26171. C
  26172. C        The upper Hessenberg portions of HR and HI have been
  26173. C          destroyed, but the location HR(1,1) contains the norm
  26174. C          of the triangularized matrix.
  26175. C
  26176. C        WR and WI contain the real and imaginary parts, respectively,
  26177. C          of the eigenvalues of the upper Hessenberg matrix.  If an
  26178. C          error exit is made, the eigenvalues should be correct for
  26179. C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
  26180. C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
  26181. C
  26182. C        ZR and ZI contain the real and imaginary parts, respectively,
  26183. C          of the eigenvectors.  The eigenvectors are unnormalized.
  26184. C          If an error exit is made, none of the eigenvectors has been
  26185. C          found.  ZR and ZI are two-dimensional REAL arrays,
  26186. C          dimensioned ZR(NM,N) and ZI(NM,N).
  26187. C
  26188. C        IERR is an INTEGER flag set to
  26189. C          Zero       for normal return,
  26190. C          J          if the J-th eigenvalue has not been
  26191. C                     determined after a total of 30*N iterations.
  26192. C                     The eigenvalues should be correct for indices
  26193. C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
  26194. C                     computed.
  26195. C
  26196. C     Calls CSROOT for complex square root.
  26197. C     Calls CDIV for complex division.
  26198. C
  26199. C     Questions and comments should be directed to B. S. Garbow,
  26200. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  26201. C     ------------------------------------------------------------------
  26202. C
  26203. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  26204. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  26205. C                 system Routines - EISPACK Guide, Springer-Verlag,
  26206. C                 1976.
  26207. C***ROUTINES CALLED  CDIV, CSROOT
  26208. C***REVISION HISTORY  (YYMMDD)
  26209. C   760101  DATE WRITTEN
  26210. C   890531  Changed all specific intrinsics to generic.  (WRB)
  26211. C   890831  Modified array declarations.  (WRB)
  26212. C   890831  REVISION DATE from Version 3.2
  26213. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  26214. C   920501  Reformatted the REFERENCES section.  (WRB)
  26215. C***END PROLOGUE  COMLR2
  26216. C
  26217.       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1
  26218.       INTEGER ITN,ITS,LOW,MP1,ENM1,IEND,IERR
  26219.       REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
  26220.       REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2
  26221.       INTEGER INT(*)
  26222. C
  26223. C***FIRST EXECUTABLE STATEMENT  COMLR2
  26224.       IERR = 0
  26225. C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
  26226.       DO 100 I = 1, N
  26227. C
  26228.          DO 100 J = 1, N
  26229.             ZR(I,J) = 0.0E0
  26230.             ZI(I,J) = 0.0E0
  26231.             IF (I .EQ. J) ZR(I,J) = 1.0E0
  26232.   100 CONTINUE
  26233. C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
  26234. C                FROM THE INFORMATION LEFT BY COMHES ..........
  26235.       IEND = IGH - LOW - 1
  26236.       IF (IEND .LE. 0) GO TO 180
  26237. C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  26238.       DO 160 II = 1, IEND
  26239.          I = IGH - II
  26240.          IP1 = I + 1
  26241. C
  26242.          DO 120 K = IP1, IGH
  26243.             ZR(K,I) = HR(K,I-1)
  26244.             ZI(K,I) = HI(K,I-1)
  26245.   120    CONTINUE
  26246. C
  26247.          J = INT(I)
  26248.          IF (I .EQ. J) GO TO 160
  26249. C
  26250.          DO 140 K = I, IGH
  26251.             ZR(I,K) = ZR(J,K)
  26252.             ZI(I,K) = ZI(J,K)
  26253.             ZR(J,K) = 0.0E0
  26254.             ZI(J,K) = 0.0E0
  26255.   140    CONTINUE
  26256. C
  26257.          ZR(J,I) = 1.0E0
  26258.   160 CONTINUE
  26259. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  26260.   180 DO 200 I = 1, N
  26261.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  26262.          WR(I) = HR(I,I)
  26263.          WI(I) = HI(I,I)
  26264.   200 CONTINUE
  26265. C
  26266.       EN = IGH
  26267.       TR = 0.0E0
  26268.       TI = 0.0E0
  26269.       ITN = 30*N
  26270. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  26271.   220 IF (EN .LT. LOW) GO TO 680
  26272.       ITS = 0
  26273.       ENM1 = EN - 1
  26274. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  26275. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  26276.   240 DO 260 LL = LOW, EN
  26277.          L = EN + LOW - LL
  26278.          IF (L .EQ. LOW) GO TO 300
  26279.          S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
  26280.      1             + ABS(HR(L,L)) + ABS(HI(L,L))
  26281.          S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1))
  26282.          IF (S2 .EQ. S1) GO TO 300
  26283.   260 CONTINUE
  26284. C     .......... FORM SHIFT ..........
  26285.   300 IF (L .EQ. EN) GO TO 660
  26286.       IF (ITN .EQ. 0) GO TO 1000
  26287.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  26288.       SR = HR(EN,EN)
  26289.       SI = HI(EN,EN)
  26290.       XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
  26291.       XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
  26292.       IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
  26293.       YR = (HR(ENM1,ENM1) - SR) / 2.0E0
  26294.       YI = (HI(ENM1,ENM1) - SI) / 2.0E0
  26295.       CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
  26296.       IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
  26297.       ZZR = -ZZR
  26298.       ZZI = -ZZI
  26299.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  26300.       SR = SR - XR
  26301.       SI = SI - XI
  26302.       GO TO 340
  26303. C     .......... FORM EXCEPTIONAL SHIFT ..........
  26304.   320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
  26305.       SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2))
  26306. C
  26307.   340 DO 360 I = LOW, EN
  26308.          HR(I,I) = HR(I,I) - SR
  26309.          HI(I,I) = HI(I,I) - SI
  26310.   360 CONTINUE
  26311. C
  26312.       TR = TR + SR
  26313.       TI = TI + SI
  26314.       ITS = ITS + 1
  26315.       ITN = ITN - 1
  26316. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  26317. C                SUB-DIAGONAL ELEMENTS ..........
  26318.       XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1))
  26319.       YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1))
  26320.       ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN))
  26321. C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
  26322.       DO 380 MM = L, ENM1
  26323.          M = ENM1 + L - MM
  26324.          IF (M .EQ. L) GO TO 420
  26325.          YI = YR
  26326.          YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1))
  26327.          XI = ZZR
  26328.          ZZR = XR
  26329.          XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1))
  26330.          S1 = ZZR / YI * (ZZR + XR + XI)
  26331.          S2 = S1 + YR
  26332.          IF (S2 .EQ. S1) GO TO 420
  26333.   380 CONTINUE
  26334. C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  26335.   420 MP1 = M + 1
  26336. C
  26337.       DO 520 I = MP1, EN
  26338.          IM1 = I - 1
  26339.          XR = HR(IM1,IM1)
  26340.          XI = HI(IM1,IM1)
  26341.          YR = HR(I,IM1)
  26342.          YI = HI(I,IM1)
  26343.          IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460
  26344. C     .......... INTERCHANGE ROWS OF HR AND HI ..........
  26345.          DO 440 J = IM1, N
  26346.             ZZR = HR(IM1,J)
  26347.             HR(IM1,J) = HR(I,J)
  26348.             HR(I,J) = ZZR
  26349.             ZZI = HI(IM1,J)
  26350.             HI(IM1,J) = HI(I,J)
  26351.             HI(I,J) = ZZI
  26352.   440    CONTINUE
  26353. C
  26354.          CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
  26355.          WR(I) = 1.0E0
  26356.          GO TO 480
  26357.   460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
  26358.          WR(I) = -1.0E0
  26359.   480    HR(I,IM1) = ZZR
  26360.          HI(I,IM1) = ZZI
  26361. C
  26362.          DO 500 J = I, N
  26363.             HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
  26364.             HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  26365.   500    CONTINUE
  26366. C
  26367.   520 CONTINUE
  26368. C     .......... COMPOSITION R*L=H ..........
  26369.       DO 640 J = MP1, EN
  26370.          XR = HR(J,J-1)
  26371.          XI = HI(J,J-1)
  26372.          HR(J,J-1) = 0.0E0
  26373.          HI(J,J-1) = 0.0E0
  26374. C     .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI,
  26375. C                IF NECESSARY ..........
  26376.          IF (WR(J) .LE. 0.0E0) GO TO 580
  26377. C
  26378.          DO 540 I = 1, J
  26379.             ZZR = HR(I,J-1)
  26380.             HR(I,J-1) = HR(I,J)
  26381.             HR(I,J) = ZZR
  26382.             ZZI = HI(I,J-1)
  26383.             HI(I,J-1) = HI(I,J)
  26384.             HI(I,J) = ZZI
  26385.   540    CONTINUE
  26386. C
  26387.          DO 560 I = LOW, IGH
  26388.             ZZR = ZR(I,J-1)
  26389.             ZR(I,J-1) = ZR(I,J)
  26390.             ZR(I,J) = ZZR
  26391.             ZZI = ZI(I,J-1)
  26392.             ZI(I,J-1) = ZI(I,J)
  26393.             ZI(I,J) = ZZI
  26394.   560    CONTINUE
  26395. C
  26396.   580    DO 600 I = 1, J
  26397.             HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
  26398.             HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  26399.   600    CONTINUE
  26400. C     .......... ACCUMULATE TRANSFORMATIONS ..........
  26401.          DO 620 I = LOW, IGH
  26402.             ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J)
  26403.             ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J)
  26404.   620    CONTINUE
  26405. C
  26406.   640 CONTINUE
  26407. C
  26408.       GO TO 240
  26409. C     .......... A ROOT FOUND ..........
  26410.   660 HR(EN,EN) = HR(EN,EN) + TR
  26411.       WR(EN) = HR(EN,EN)
  26412.       HI(EN,EN) = HI(EN,EN) + TI
  26413.       WI(EN) = HI(EN,EN)
  26414.       EN = ENM1
  26415.       GO TO 220
  26416. C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
  26417. C                VECTORS OF UPPER TRIANGULAR FORM ..........
  26418.   680 NORM = 0.0E0
  26419. C
  26420.       DO 720 I = 1, N
  26421. C
  26422.          DO 720 J = I, N
  26423.             NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J))
  26424.   720 CONTINUE
  26425. C
  26426.       HR(1,1) = NORM
  26427.       IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001
  26428. C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
  26429.       DO 800 NN = 2, N
  26430.          EN = N + 2 - NN
  26431.          XR = WR(EN)
  26432.          XI = WI(EN)
  26433.          ENM1 = EN - 1
  26434. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  26435.          DO 780 II = 1, ENM1
  26436.             I = EN - II
  26437.             ZZR = HR(I,EN)
  26438.             ZZI = HI(I,EN)
  26439.             IF (I .EQ. ENM1) GO TO 760
  26440.             IP1 = I + 1
  26441. C
  26442.             DO 740 J = IP1, ENM1
  26443.                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
  26444.                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  26445.   740       CONTINUE
  26446. C
  26447.   760       YR = XR - WR(I)
  26448.             YI = XI - WI(I)
  26449.             IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775
  26450.             YR = NORM
  26451.   770       YR = 0.5E0*YR
  26452.             IF (NORM + YR .GT. NORM) GO TO 770
  26453.             YR = 2.0E0*YR
  26454.   775       CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  26455.   780    CONTINUE
  26456. C
  26457.   800 CONTINUE
  26458. C     .......... END BACKSUBSTITUTION ..........
  26459.       ENM1 = N - 1
  26460. C     .......... VECTORS OF ISOLATED ROOTS ..........
  26461.       DO 840 I = 1, ENM1
  26462.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
  26463.          IP1 = I + 1
  26464. C
  26465.          DO 820 J = IP1, N
  26466.             ZR(I,J) = HR(I,J)
  26467.             ZI(I,J) = HI(I,J)
  26468.   820    CONTINUE
  26469. C
  26470.   840 CONTINUE
  26471. C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
  26472. C                VECTORS OF ORIGINAL FULL MATRIX.
  26473. C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
  26474.       DO 880 JJ = LOW, ENM1
  26475.          J = N + LOW - JJ
  26476.          M = MIN(J-1,IGH)
  26477. C
  26478.          DO 880 I = LOW, IGH
  26479.             ZZR = ZR(I,J)
  26480.             ZZI = ZI(I,J)
  26481. C
  26482.             DO 860 K = LOW, M
  26483.                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
  26484.                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  26485.   860       CONTINUE
  26486. C
  26487.             ZR(I,J) = ZZR
  26488.             ZI(I,J) = ZZI
  26489.   880 CONTINUE
  26490. C
  26491.       GO TO 1001
  26492. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  26493. C                EIGENVALUE AFTER 30*N ITERATIONS ..........
  26494.  1000 IERR = EN
  26495.  1001 RETURN
  26496.       END
  26497. *DECK COMPB
  26498.       SUBROUTINE COMPB (N, IERROR, AN, BN, CN, B, AH, BH)
  26499. C***BEGIN PROLOGUE  COMPB
  26500. C***SUBSIDIARY
  26501. C***PURPOSE  Subsidiary to BLKTRI
  26502. C***LIBRARY   SLATEC
  26503. C***TYPE      SINGLE PRECISION (COMPB-S, CCMPB-C)
  26504. C***AUTHOR  (UNKNOWN)
  26505. C***DESCRIPTION
  26506. C
  26507. C     COMPB computes the roots of the B polynomials using subroutine
  26508. C     TEVLS which is a modification the EISPACK program TQLRAT.
  26509. C     IERROR is set to 4 if either TEVLS fails or if A(J+1)*C(J) is
  26510. C     less than zero for some J.  AH,BH are temporary work arrays.
  26511. C
  26512. C***SEE ALSO  BLKTRI
  26513. C***ROUTINES CALLED  INDXB, PPADD, R1MACH, TEVLS
  26514. C***COMMON BLOCKS    CBLKT
  26515. C***REVISION HISTORY  (YYMMDD)
  26516. C   801001  DATE WRITTEN
  26517. C   890531  Changed all specific intrinsics to generic.  (WRB)
  26518. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  26519. C   900402  Added TYPE section.  (WRB)
  26520. C***END PROLOGUE  COMPB
  26521. C
  26522.       DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,B(*)       ,
  26523.      1                AH(*)      ,BH(*)
  26524.       COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
  26525.      1                NM         ,NCMPLX     ,IK
  26526. C***FIRST EXECUTABLE STATEMENT  COMPB
  26527.       EPS = R1MACH(4)
  26528.       BNORM = ABS(BN(1))
  26529.       DO 102 J=2,NM
  26530.          BNORM = MAX(BNORM,ABS(BN(J)))
  26531.          ARG = AN(J)*CN(J-1)
  26532.          IF (ARG) 119,101,101
  26533.   101    B(J) = SIGN(SQRT(ARG),AN(J))
  26534.   102 CONTINUE
  26535.       CNV = EPS*BNORM
  26536.       IF = 2**K
  26537.       KDO = K-1
  26538.       DO 108 L=1,KDO
  26539.          IR = L-1
  26540.          I2 = 2**IR
  26541.          I4 = I2+I2
  26542.          IPL = I4-1
  26543.          IFD = IF-I4
  26544.          DO 107 I=I4,IFD,I4
  26545.             CALL INDXB (I,L,IB,NB)
  26546.             IF (NB) 108,108,103
  26547.   103       JS = I-IPL
  26548.             JF = JS+NB-1
  26549.             LS = 0
  26550.             DO 104 J=JS,JF
  26551.                LS = LS+1
  26552.                BH(LS) = BN(J)
  26553.                AH(LS) = B(J)
  26554.   104       CONTINUE
  26555.             CALL TEVLS (NB,BH,AH,IERROR)
  26556.             IF (IERROR) 118,105,118
  26557.   105       LH = IB-1
  26558.             DO 106 J=1,NB
  26559.                LH = LH+1
  26560.                B(LH) = -BH(J)
  26561.   106       CONTINUE
  26562.   107    CONTINUE
  26563.   108 CONTINUE
  26564.       DO 109 J=1,NM
  26565.          B(J) = -BN(J)
  26566.   109 CONTINUE
  26567.       IF (NPP) 117,110,117
  26568.   110 NMP = NM+1
  26569.       NB = NM+NMP
  26570.       DO 112 J=1,NB
  26571.          L1 = MOD(J-1,NMP)+1
  26572.          L2 = MOD(J+NM-1,NMP)+1
  26573.          ARG = AN(L1)*CN(L2)
  26574.          IF (ARG) 119,111,111
  26575.   111    BH(J) = SIGN(SQRT(ARG),-AN(L1))
  26576.          AH(J) = -BN(L1)
  26577.   112 CONTINUE
  26578.       CALL TEVLS (NB,AH,BH,IERROR)
  26579.       IF (IERROR) 118,113,118
  26580.   113 CALL INDXB (IF,K-1,J2,LH)
  26581.       CALL INDXB (IF/2,K-1,J1,LH)
  26582.       J2 = J2+1
  26583.       LH = J2
  26584.       N2M2 = J2+NM+NM-2
  26585.   114 D1 = ABS(B(J1)-B(J2-1))
  26586.       D2 = ABS(B(J1)-B(J2))
  26587.       D3 = ABS(B(J1)-B(J2+1))
  26588.       IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 115
  26589.       B(LH) = B(J2)
  26590.       J2 = J2+1
  26591.       LH = LH+1
  26592.       IF (J2-N2M2) 114,114,116
  26593.   115 J2 = J2+1
  26594.       J1 = J1+1
  26595.       IF (J2-N2M2) 114,114,116
  26596.   116 B(LH) = B(N2M2+1)
  26597.       CALL INDXB (IF,K-1,J1,J2)
  26598.       J2 = J1+NMP+NMP
  26599.       CALL PPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2))
  26600.   117 RETURN
  26601.   118 IERROR = 4
  26602.       RETURN
  26603.   119 IERROR = 5
  26604.       RETURN
  26605.       END
  26606. *DECK COMQR
  26607.       SUBROUTINE COMQR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR)
  26608. C***BEGIN PROLOGUE  COMQR
  26609. C***PURPOSE  Compute the eigenvalues of complex upper Hessenberg matrix
  26610. C            using the QR method.
  26611. C***LIBRARY   SLATEC (EISPACK)
  26612. C***CATEGORY  D4C2B
  26613. C***TYPE      COMPLEX (HQR-S, COMQR-C)
  26614. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  26615. C***AUTHOR  Smith, B. T., et al.
  26616. C***DESCRIPTION
  26617. C
  26618. C     This subroutine is a translation of a unitary analogue of the
  26619. C     ALGOL procedure  COMLR, NUM. MATH. 12, 369-376(1968) by Martin
  26620. C     and Wilkinson.
  26621. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
  26622. C     The unitary analogue substitutes the QR algorithm of Francis
  26623. C     (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm.
  26624. C
  26625. C     This subroutine finds the eigenvalues of a COMPLEX
  26626. C     upper Hessenberg matrix by the QR method.
  26627. C
  26628. C     On INPUT
  26629. C
  26630. C        NM must be set to the row dimension of the two-dimensional
  26631. C          array parameters, HR and HI, as declared in the calling
  26632. C          program dimension statement.  NM is an INTEGER variable.
  26633. C
  26634. C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
  26635. C          variable.  N must be less than or equal to NM.
  26636. C
  26637. C        LOW and IGH are two INTEGER variables determined by the
  26638. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  26639. C          set LOW=1 and IGH equal to the order of the matrix, N.
  26640. C
  26641. C        HR and HI contain the real and imaginary parts, respectively,
  26642. C          of the complex upper Hessenberg matrix.  Their lower
  26643. C          triangles below the subdiagonal contain information about
  26644. C          the unitary transformations used in the reduction by  CORTH,
  26645. C          if performed.  HR and HI are two-dimensional REAL arrays,
  26646. C          dimensioned HR(NM,N) and HI(NM,N).
  26647. C
  26648. C     On OUTPUT
  26649. C
  26650. C        The upper Hessenberg portions of HR and HI have been
  26651. C          destroyed.  Therefore, they must be saved before calling
  26652. C          COMQR  if subsequent calculation of eigenvectors is to
  26653. C          be performed.
  26654. C
  26655. C        WR and WI contain the real and imaginary parts, respectively,
  26656. C          of the eigenvalues of the upper Hessenberg matrix.  If an
  26657. C          error exit is made, the eigenvalues should be correct for
  26658. C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
  26659. C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
  26660. C
  26661. C        IERR is an INTEGER flag set to
  26662. C          Zero       for normal return,
  26663. C          J          if the J-th eigenvalue has not been
  26664. C                     determined after a total of 30*N iterations.
  26665. C                     The eigenvalues should be correct for indices
  26666. C                     IERR+1, IERR+2, ..., N.
  26667. C
  26668. C     Calls CSROOT for complex square root.
  26669. C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
  26670. C     Calls CDIV for complex division.
  26671. C
  26672. C     Questions and comments should be directed to B. S. Garbow,
  26673. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  26674. C     ------------------------------------------------------------------
  26675. C
  26676. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  26677. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  26678. C                 system Routines - EISPACK Guide, Springer-Verlag,
  26679. C                 1976.
  26680. C***ROUTINES CALLED  CDIV, CSROOT, PYTHAG
  26681. C***REVISION HISTORY  (YYMMDD)
  26682. C   760101  DATE WRITTEN
  26683. C   890531  Changed all specific intrinsics to generic.  (WRB)
  26684. C   890831  Modified array declarations.  (WRB)
  26685. C   890831  REVISION DATE from Version 3.2
  26686. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  26687. C   920501  Reformatted the REFERENCES section.  (WRB)
  26688. C***END PROLOGUE  COMQR
  26689. C
  26690.       INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
  26691.       REAL HR(NM,*),HI(NM,*),WR(*),WI(*)
  26692.       REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2
  26693.       REAL PYTHAG
  26694. C
  26695. C***FIRST EXECUTABLE STATEMENT  COMQR
  26696.       IERR = 0
  26697.       IF (LOW .EQ. IGH) GO TO 180
  26698. C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  26699.       L = LOW + 1
  26700. C
  26701.       DO 170 I = L, IGH
  26702.          LL = MIN(I+1,IGH)
  26703.          IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170
  26704.          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
  26705.          YR = HR(I,I-1) / NORM
  26706.          YI = HI(I,I-1) / NORM
  26707.          HR(I,I-1) = NORM
  26708.          HI(I,I-1) = 0.0E0
  26709. C
  26710.          DO 155 J = I, IGH
  26711.             SI = YR * HI(I,J) - YI * HR(I,J)
  26712.             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
  26713.             HI(I,J) = SI
  26714.   155    CONTINUE
  26715. C
  26716.          DO 160 J = LOW, LL
  26717.             SI = YR * HI(J,I) + YI * HR(J,I)
  26718.             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
  26719.             HI(J,I) = SI
  26720.   160    CONTINUE
  26721. C
  26722.   170 CONTINUE
  26723. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  26724.   180 DO 200 I = 1, N
  26725.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  26726.          WR(I) = HR(I,I)
  26727.          WI(I) = HI(I,I)
  26728.   200 CONTINUE
  26729. C
  26730.       EN = IGH
  26731.       TR = 0.0E0
  26732.       TI = 0.0E0
  26733.       ITN = 30*N
  26734. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  26735.   220 IF (EN .LT. LOW) GO TO 1001
  26736.       ITS = 0
  26737.       ENM1 = EN - 1
  26738. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  26739. C                FOR L=EN STEP -1 UNTIL LOW E0 -- ..........
  26740.   240 DO 260 LL = LOW, EN
  26741.          L = EN + LOW - LL
  26742.          IF (L .EQ. LOW) GO TO 300
  26743.          S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
  26744.      1             + ABS(HR(L,L)) +ABS(HI(L,L))
  26745.          S2 = S1 + ABS(HR(L,L-1))
  26746.          IF (S2 .EQ. S1) GO TO 300
  26747.   260 CONTINUE
  26748. C     .......... FORM SHIFT ..........
  26749.   300 IF (L .EQ. EN) GO TO 660
  26750.       IF (ITN .EQ. 0) GO TO 1000
  26751.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  26752.       SR = HR(EN,EN)
  26753.       SI = HI(EN,EN)
  26754.       XR = HR(ENM1,EN) * HR(EN,ENM1)
  26755.       XI = HI(ENM1,EN) * HR(EN,ENM1)
  26756.       IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
  26757.       YR = (HR(ENM1,ENM1) - SR) / 2.0E0
  26758.       YI = (HI(ENM1,ENM1) - SI) / 2.0E0
  26759.       CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
  26760.       IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
  26761.       ZZR = -ZZR
  26762.       ZZI = -ZZI
  26763.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  26764.       SR = SR - XR
  26765.       SI = SI - XI
  26766.       GO TO 340
  26767. C     .......... FORM EXCEPTIONAL SHIFT ..........
  26768.   320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
  26769.       SI = 0.0E0
  26770. C
  26771.   340 DO 360 I = LOW, EN
  26772.          HR(I,I) = HR(I,I) - SR
  26773.          HI(I,I) = HI(I,I) - SI
  26774.   360 CONTINUE
  26775. C
  26776.       TR = TR + SR
  26777.       TI = TI + SI
  26778.       ITS = ITS + 1
  26779.       ITN = ITN - 1
  26780. C     .......... REDUCE TO TRIANGLE (ROWS) ..........
  26781.       LP1 = L + 1
  26782. C
  26783.       DO 500 I = LP1, EN
  26784.          SR = HR(I,I-1)
  26785.          HR(I,I-1) = 0.0E0
  26786.          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
  26787.          XR = HR(I-1,I-1) / NORM
  26788.          WR(I-1) = XR
  26789.          XI = HI(I-1,I-1) / NORM
  26790.          WI(I-1) = XI
  26791.          HR(I-1,I-1) = NORM
  26792.          HI(I-1,I-1) = 0.0E0
  26793.          HI(I,I-1) = SR / NORM
  26794. C
  26795.          DO 490 J = I, EN
  26796.             YR = HR(I-1,J)
  26797.             YI = HI(I-1,J)
  26798.             ZZR = HR(I,J)
  26799.             ZZI = HI(I,J)
  26800.             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
  26801.             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
  26802.             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
  26803.             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  26804.   490    CONTINUE
  26805. C
  26806.   500 CONTINUE
  26807. C
  26808.       SI = HI(EN,EN)
  26809.       IF (SI .EQ. 0.0E0) GO TO 540
  26810.       NORM = PYTHAG(HR(EN,EN),SI)
  26811.       SR = HR(EN,EN) / NORM
  26812.       SI = SI / NORM
  26813.       HR(EN,EN) = NORM
  26814.       HI(EN,EN) = 0.0E0
  26815. C     .......... INVERSE OPERATION (COLUMNS) ..........
  26816.   540 DO 600 J = LP1, EN
  26817.          XR = WR(J-1)
  26818.          XI = WI(J-1)
  26819. C
  26820.          DO 580 I = L, J
  26821.             YR = HR(I,J-1)
  26822.             YI = 0.0E0
  26823.             ZZR = HR(I,J)
  26824.             ZZI = HI(I,J)
  26825.             IF (I .EQ. J) GO TO 560
  26826.             YI = HI(I,J-1)
  26827.             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  26828.   560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  26829.             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  26830.             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  26831.   580    CONTINUE
  26832. C
  26833.   600 CONTINUE
  26834. C
  26835.       IF (SI .EQ. 0.0E0) GO TO 240
  26836. C
  26837.       DO 630 I = L, EN
  26838.          YR = HR(I,EN)
  26839.          YI = HI(I,EN)
  26840.          HR(I,EN) = SR * YR - SI * YI
  26841.          HI(I,EN) = SR * YI + SI * YR
  26842.   630 CONTINUE
  26843. C
  26844.       GO TO 240
  26845. C     .......... A ROOT FOUND ..........
  26846.   660 WR(EN) = HR(EN,EN) + TR
  26847.       WI(EN) = HI(EN,EN) + TI
  26848.       EN = ENM1
  26849.       GO TO 220
  26850. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  26851. C                EIGENVALUE AFTER 30*N ITERATIONS ..........
  26852.  1000 IERR = EN
  26853.  1001 RETURN
  26854.       END
  26855. *DECK COMQR2
  26856.       SUBROUTINE COMQR2 (NM, N, LOW, IGH, ORTR, ORTI, HR, HI, WR, WI,
  26857.      +   ZR, ZI, IERR)
  26858. C***BEGIN PROLOGUE  COMQR2
  26859. C***PURPOSE  Compute the eigenvalues and eigenvectors of a complex upper
  26860. C            Hessenberg matrix.
  26861. C***LIBRARY   SLATEC (EISPACK)
  26862. C***CATEGORY  D4C2B
  26863. C***TYPE      COMPLEX (HQR2-S, COMQR2-C)
  26864. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  26865. C***AUTHOR  Smith, B. T., et al.
  26866. C***DESCRIPTION
  26867. C
  26868. C     This subroutine is a translation of a unitary analogue of the
  26869. C     ALGOL procedure  COMLR2, NUM. MATH. 16, 181-204(1970) by Peters
  26870. C     and Wilkinson.
  26871. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  26872. C     The unitary analogue substitutes the QR algorithm of Francis
  26873. C     (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm.
  26874. C
  26875. C     This subroutine finds the eigenvalues and eigenvectors
  26876. C     of a COMPLEX UPPER Hessenberg matrix by the QR
  26877. C     method.  The eigenvectors of a COMPLEX GENERAL matrix
  26878. C     can also be found if  CORTH  has been used to reduce
  26879. C     this general matrix to Hessenberg form.
  26880. C
  26881. C     On INPUT
  26882. C
  26883. C        NM must be set to the row dimension of the two-dimensional
  26884. C          array parameters, HR, HI, ZR, and ZI, as declared in the
  26885. C          calling program dimension statement.  NM is an INTEGER
  26886. C          variable.
  26887. C
  26888. C        N is the order of the matrix H=(HR,HI).  N is an INTEGER
  26889. C          variable.  N must be less than or equal to NM.
  26890. C
  26891. C        LOW and IGH are two INTEGER variables determined by the
  26892. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  26893. C          set LOW=1 and IGH equal to the order of the matrix, N.
  26894. C
  26895. C        ORTR and ORTI contain information about the unitary trans-
  26896. C          formations used in the reduction by  CORTH, if performed.
  26897. C          Only elements LOW through IGH are used.  If the eigenvectors
  26898. C          of the Hessenberg matrix are desired, set ORTR(J) and
  26899. C          ORTI(J) to 0.0E0 for these elements.  ORTR and ORTI are
  26900. C          one-dimensional REAL arrays, dimensioned ORTR(IGH) and
  26901. C          ORTI(IGH).
  26902. C
  26903. C        HR and HI contain the real and imaginary parts, respectively,
  26904. C          of the complex upper Hessenberg matrix.  Their lower
  26905. C          triangles below the subdiagonal contain information about
  26906. C          the unitary transformations used in the reduction by  CORTH,
  26907. C          if performed.  If the eigenvectors of the Hessenberg matrix
  26908. C          are desired, these elements may be arbitrary.  HR and HI
  26909. C          are two-dimensional REAL arrays, dimensioned HR(NM,N) and
  26910. C          HI(NM,N).
  26911. C
  26912. C     On OUTPUT
  26913. C
  26914. C        ORTR, ORTI, and the upper Hessenberg portions of HR and HI
  26915. C          have been destroyed.
  26916. C
  26917. C        WR and WI contain the real and imaginary parts, respectively,
  26918. C          of the eigenvalues of the upper Hessenberg matrix.  If an
  26919. C          error exit is made, the eigenvalues should be correct for
  26920. C          indices IERR+1, IERR+2, ..., N.  WR and WI are one-
  26921. C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
  26922. C
  26923. C        ZR and ZI contain the real and imaginary parts, respectively,
  26924. C          of the eigenvectors.  The eigenvectors are unnormalized.
  26925. C          If an error exit is made, none of the eigenvectors has been
  26926. C          found.  ZR and ZI are two-dimensional REAL arrays,
  26927. C          dimensioned ZR(NM,N) and ZI(NM,N).
  26928. C
  26929. C        IERR is an INTEGER flag set to
  26930. C          Zero       for normal return,
  26931. C          J          if the J-th eigenvalue has not been
  26932. C                     determined after a total of 30*N iterations.
  26933. C                     The eigenvalues should be correct for indices
  26934. C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
  26935. C                     computed.
  26936. C
  26937. C     Calls CSROOT for complex square root.
  26938. C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
  26939. C     Calls CDIV for complex division.
  26940. C
  26941. C     Questions and comments should be directed to B. S. Garbow,
  26942. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  26943. C     ------------------------------------------------------------------
  26944. C
  26945. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  26946. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  26947. C                 system Routines - EISPACK Guide, Springer-Verlag,
  26948. C                 1976.
  26949. C***ROUTINES CALLED  CDIV, CSROOT, PYTHAG
  26950. C***REVISION HISTORY  (YYMMDD)
  26951. C   760101  DATE WRITTEN
  26952. C   890531  Changed all specific intrinsics to generic.  (WRB)
  26953. C   890831  Modified array declarations.  (WRB)
  26954. C   890831  REVISION DATE from Version 3.2
  26955. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  26956. C   920501  Reformatted the REFERENCES section.  (WRB)
  26957. C***END PROLOGUE  COMQR2
  26958. C
  26959.       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1
  26960.       INTEGER ITN,ITS,LOW,LP1,ENM1,IEND,IERR
  26961.       REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*)
  26962.       REAL ORTR(*),ORTI(*)
  26963.       REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2
  26964.       REAL PYTHAG
  26965. C
  26966. C***FIRST EXECUTABLE STATEMENT  COMQR2
  26967.       IERR = 0
  26968. C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
  26969.       DO 100 I = 1, N
  26970. C
  26971.          DO 100 J = 1, N
  26972.             ZR(I,J) = 0.0E0
  26973.             ZI(I,J) = 0.0E0
  26974.             IF (I .EQ. J) ZR(I,J) = 1.0E0
  26975.   100 CONTINUE
  26976. C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
  26977. C                FROM THE INFORMATION LEFT BY CORTH ..........
  26978.       IEND = IGH - LOW - 1
  26979.       IF (IEND) 180, 150, 105
  26980. C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  26981.   105 DO 140 II = 1, IEND
  26982.          I = IGH - II
  26983.          IF (ORTR(I) .EQ. 0.0E0 .AND. ORTI(I) .EQ. 0.0E0) GO TO 140
  26984.          IF (HR(I,I-1) .EQ. 0.0E0 .AND. HI(I,I-1) .EQ. 0.0E0) GO TO 140
  26985. C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
  26986.          NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
  26987.          IP1 = I + 1
  26988. C
  26989.          DO 110 K = IP1, IGH
  26990.             ORTR(K) = HR(K,I-1)
  26991.             ORTI(K) = HI(K,I-1)
  26992.   110    CONTINUE
  26993. C
  26994.          DO 130 J = I, IGH
  26995.             SR = 0.0E0
  26996.             SI = 0.0E0
  26997. C
  26998.             DO 115 K = I, IGH
  26999.                SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
  27000.                SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  27001.   115       CONTINUE
  27002. C
  27003.             SR = SR / NORM
  27004.             SI = SI / NORM
  27005. C
  27006.             DO 120 K = I, IGH
  27007.                ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
  27008.                ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  27009.   120       CONTINUE
  27010. C
  27011.   130    CONTINUE
  27012. C
  27013.   140 CONTINUE
  27014. C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  27015.   150 L = LOW + 1
  27016. C
  27017.       DO 170 I = L, IGH
  27018.          LL = MIN(I+1,IGH)
  27019.          IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170
  27020.          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
  27021.          YR = HR(I,I-1) / NORM
  27022.          YI = HI(I,I-1) / NORM
  27023.          HR(I,I-1) = NORM
  27024.          HI(I,I-1) = 0.0E0
  27025. C
  27026.          DO 155 J = I, N
  27027.             SI = YR * HI(I,J) - YI * HR(I,J)
  27028.             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
  27029.             HI(I,J) = SI
  27030.   155    CONTINUE
  27031. C
  27032.          DO 160 J = 1, LL
  27033.             SI = YR * HI(J,I) + YI * HR(J,I)
  27034.             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
  27035.             HI(J,I) = SI
  27036.   160    CONTINUE
  27037. C
  27038.          DO 165 J = LOW, IGH
  27039.             SI = YR * ZI(J,I) + YI * ZR(J,I)
  27040.             ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
  27041.             ZI(J,I) = SI
  27042.   165    CONTINUE
  27043. C
  27044.   170 CONTINUE
  27045. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  27046.   180 DO 200 I = 1, N
  27047.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  27048.          WR(I) = HR(I,I)
  27049.          WI(I) = HI(I,I)
  27050.   200 CONTINUE
  27051. C
  27052.       EN = IGH
  27053.       TR = 0.0E0
  27054.       TI = 0.0E0
  27055.       ITN = 30*N
  27056. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  27057.   220 IF (EN .LT. LOW) GO TO 680
  27058.       ITS = 0
  27059.       ENM1 = EN - 1
  27060. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  27061. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  27062.   240 DO 260 LL = LOW, EN
  27063.          L = EN + LOW - LL
  27064.          IF (L .EQ. LOW) GO TO 300
  27065.          S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
  27066.      1             + ABS(HR(L,L)) +ABS(HI(L,L))
  27067.          S2 = S1 + ABS(HR(L,L-1))
  27068.          IF (S2 .EQ. S1) GO TO 300
  27069.   260 CONTINUE
  27070. C     .......... FORM SHIFT ..........
  27071.   300 IF (L .EQ. EN) GO TO 660
  27072.       IF (ITN .EQ. 0) GO TO 1000
  27073.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  27074.       SR = HR(EN,EN)
  27075.       SI = HI(EN,EN)
  27076.       XR = HR(ENM1,EN) * HR(EN,ENM1)
  27077.       XI = HI(ENM1,EN) * HR(EN,ENM1)
  27078.       IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340
  27079.       YR = (HR(ENM1,ENM1) - SR) / 2.0E0
  27080.       YI = (HI(ENM1,ENM1) - SI) / 2.0E0
  27081.       CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI)
  27082.       IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310
  27083.       ZZR = -ZZR
  27084.       ZZI = -ZZI
  27085.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  27086.       SR = SR - XR
  27087.       SI = SI - XI
  27088.       GO TO 340
  27089. C     .......... FORM EXCEPTIONAL SHIFT ..........
  27090.   320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
  27091.       SI = 0.0E0
  27092. C
  27093.   340 DO 360 I = LOW, EN
  27094.          HR(I,I) = HR(I,I) - SR
  27095.          HI(I,I) = HI(I,I) - SI
  27096.   360 CONTINUE
  27097. C
  27098.       TR = TR + SR
  27099.       TI = TI + SI
  27100.       ITS = ITS + 1
  27101.       ITN = ITN - 1
  27102. C     .......... REDUCE TO TRIANGLE (ROWS) ..........
  27103.       LP1 = L + 1
  27104. C
  27105.       DO 500 I = LP1, EN
  27106.          SR = HR(I,I-1)
  27107.          HR(I,I-1) = 0.0E0
  27108.          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
  27109.          XR = HR(I-1,I-1) / NORM
  27110.          WR(I-1) = XR
  27111.          XI = HI(I-1,I-1) / NORM
  27112.          WI(I-1) = XI
  27113.          HR(I-1,I-1) = NORM
  27114.          HI(I-1,I-1) = 0.0E0
  27115.          HI(I,I-1) = SR / NORM
  27116. C
  27117.          DO 490 J = I, N
  27118.             YR = HR(I-1,J)
  27119.             YI = HI(I-1,J)
  27120.             ZZR = HR(I,J)
  27121.             ZZI = HI(I,J)
  27122.             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
  27123.             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
  27124.             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
  27125.             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  27126.   490    CONTINUE
  27127. C
  27128.   500 CONTINUE
  27129. C
  27130.       SI = HI(EN,EN)
  27131.       IF (SI .EQ. 0.0E0) GO TO 540
  27132.       NORM = PYTHAG(HR(EN,EN),SI)
  27133.       SR = HR(EN,EN) / NORM
  27134.       SI = SI / NORM
  27135.       HR(EN,EN) = NORM
  27136.       HI(EN,EN) = 0.0E0
  27137.       IF (EN .EQ. N) GO TO 540
  27138.       IP1 = EN + 1
  27139. C
  27140.       DO 520 J = IP1, N
  27141.          YR = HR(EN,J)
  27142.          YI = HI(EN,J)
  27143.          HR(EN,J) = SR * YR + SI * YI
  27144.          HI(EN,J) = SR * YI - SI * YR
  27145.   520 CONTINUE
  27146. C     .......... INVERSE OPERATION (COLUMNS) ..........
  27147.   540 DO 600 J = LP1, EN
  27148.          XR = WR(J-1)
  27149.          XI = WI(J-1)
  27150. C
  27151.          DO 580 I = 1, J
  27152.             YR = HR(I,J-1)
  27153.             YI = 0.0E0
  27154.             ZZR = HR(I,J)
  27155.             ZZI = HI(I,J)
  27156.             IF (I .EQ. J) GO TO 560
  27157.             YI = HI(I,J-1)
  27158.             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  27159.   560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  27160.             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  27161.             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  27162.   580    CONTINUE
  27163. C
  27164.          DO 590 I = LOW, IGH
  27165.             YR = ZR(I,J-1)
  27166.             YI = ZI(I,J-1)
  27167.             ZZR = ZR(I,J)
  27168.             ZZI = ZI(I,J)
  27169.             ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  27170.             ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  27171.             ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  27172.             ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  27173.   590    CONTINUE
  27174. C
  27175.   600 CONTINUE
  27176. C
  27177.       IF (SI .EQ. 0.0E0) GO TO 240
  27178. C
  27179.       DO 630 I = 1, EN
  27180.          YR = HR(I,EN)
  27181.          YI = HI(I,EN)
  27182.          HR(I,EN) = SR * YR - SI * YI
  27183.          HI(I,EN) = SR * YI + SI * YR
  27184.   630 CONTINUE
  27185. C
  27186.       DO 640 I = LOW, IGH
  27187.          YR = ZR(I,EN)
  27188.          YI = ZI(I,EN)
  27189.          ZR(I,EN) = SR * YR - SI * YI
  27190.          ZI(I,EN) = SR * YI + SI * YR
  27191.   640 CONTINUE
  27192. C
  27193.       GO TO 240
  27194. C     .......... A ROOT FOUND ..........
  27195.   660 HR(EN,EN) = HR(EN,EN) + TR
  27196.       WR(EN) = HR(EN,EN)
  27197.       HI(EN,EN) = HI(EN,EN) + TI
  27198.       WI(EN) = HI(EN,EN)
  27199.       EN = ENM1
  27200.       GO TO 220
  27201. C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
  27202. C                VECTORS OF UPPER TRIANGULAR FORM ..........
  27203.   680 NORM = 0.0E0
  27204. C
  27205.       DO 720 I = 1, N
  27206. C
  27207.          DO 720 J = I, N
  27208.             NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J))
  27209.   720 CONTINUE
  27210. C
  27211.       IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001
  27212. C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
  27213.       DO 800 NN = 2, N
  27214.          EN = N + 2 - NN
  27215.          XR = WR(EN)
  27216.          XI = WI(EN)
  27217.          ENM1 = EN - 1
  27218. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  27219.          DO 780 II = 1, ENM1
  27220.             I = EN - II
  27221.             ZZR = HR(I,EN)
  27222.             ZZI = HI(I,EN)
  27223.             IF (I .EQ. ENM1) GO TO 760
  27224.             IP1 = I + 1
  27225. C
  27226.             DO 740 J = IP1, ENM1
  27227.                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
  27228.                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  27229.   740       CONTINUE
  27230. C
  27231.   760       YR = XR - WR(I)
  27232.             YI = XI - WI(I)
  27233.             IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 775
  27234.             YR = NORM
  27235.   770       YR = 0.5E0*YR
  27236.             IF (NORM + YR .GT. NORM) GO TO 770
  27237.             YR = 2.0E0*YR
  27238.   775       CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  27239.   780    CONTINUE
  27240. C
  27241.   800 CONTINUE
  27242. C     .......... END BACKSUBSTITUTION ..........
  27243.       ENM1 = N - 1
  27244. C     .......... VECTORS OF ISOLATED ROOTS ..........
  27245.       DO  840 I = 1, ENM1
  27246.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
  27247.          IP1 = I + 1
  27248. C
  27249.          DO 820 J = IP1, N
  27250.             ZR(I,J) = HR(I,J)
  27251.             ZI(I,J) = HI(I,J)
  27252.   820    CONTINUE
  27253. C
  27254.   840 CONTINUE
  27255. C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
  27256. C                VECTORS OF ORIGINAL FULL MATRIX.
  27257. C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
  27258.       DO 880 JJ = LOW, ENM1
  27259.          J = N + LOW - JJ
  27260.          M = MIN(J-1,IGH)
  27261. C
  27262.          DO 880 I = LOW, IGH
  27263.             ZZR = ZR(I,J)
  27264.             ZZI = ZI(I,J)
  27265. C
  27266.             DO 860 K = LOW, M
  27267.                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
  27268.                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  27269.   860       CONTINUE
  27270. C
  27271.             ZR(I,J) = ZZR
  27272.             ZI(I,J) = ZZI
  27273.   880 CONTINUE
  27274. C
  27275.       GO TO 1001
  27276. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  27277. C                EIGENVALUE AFTER 30*N ITERATIONS ..........
  27278.  1000 IERR = EN
  27279.  1001 RETURN
  27280.       END
  27281. *DECK CORTB
  27282.       SUBROUTINE CORTB (NM, LOW, IGH, AR, AI, ORTR, ORTI, M, ZR, ZI)
  27283. C***BEGIN PROLOGUE  CORTB
  27284. C***PURPOSE  Form the eigenvectors of a complex general matrix from
  27285. C            eigenvectors of upper Hessenberg matrix output from
  27286. C            CORTH.
  27287. C***LIBRARY   SLATEC (EISPACK)
  27288. C***CATEGORY  D4C4
  27289. C***TYPE      COMPLEX (ORTBAK-S, CORTB-C)
  27290. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  27291. C***AUTHOR  Smith, B. T., et al.
  27292. C***DESCRIPTION
  27293. C
  27294. C     This subroutine is a translation of a complex analogue of
  27295. C     the ALGOL procedure ORTBAK, NUM. MATH. 12, 349-368(1968)
  27296. C     by Martin and Wilkinson.
  27297. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  27298. C
  27299. C     This subroutine forms the eigenvectors of a COMPLEX GENERAL
  27300. C     matrix by back transforming those of the corresponding
  27301. C     upper Hessenberg matrix determined by  CORTH.
  27302. C
  27303. C     On INPUT
  27304. C
  27305. C        NM must be set to the row dimension of the two-dimensional
  27306. C          array parameters, AR, AI, ZR, and ZI, as declared in the
  27307. C          calling program dimension statement.  NM is an INTEGER
  27308. C          variable.
  27309. C
  27310. C        LOW and IGH are two INTEGER variables determined by the
  27311. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  27312. C          set LOW=1 and IGH equal to the order of the matrix.
  27313. C
  27314. C        AR and AI contain information about the unitary trans-
  27315. C          formations used in the reduction by  CORTH  in their
  27316. C          strict lower triangles.  AR and AI are two-dimensional
  27317. C          REAL arrays, dimensioned AR(NM,IGH) and AI(NM,IGH).
  27318. C
  27319. C        ORTR and ORTI contain further information about the unitary
  27320. C          transformations used in the reduction by  CORTH.  Only
  27321. C          elements LOW through IGH are used.  ORTR and ORTI are
  27322. C          one-dimensional REAL arrays, dimensioned ORTR(IGH) and
  27323. C          ORTI(IGH).
  27324. C
  27325. C        M is the number of columns of Z=(ZR,ZI) to be back transformed.
  27326. C          M is an INTEGER variable.
  27327. C
  27328. C        ZR and ZI contain the real and imaginary parts, respectively,
  27329. C          of the eigenvectors to be back transformed in their first
  27330. C          M columns.  ZR and ZI are two-dimensional REAL arrays,
  27331. C          dimensioned ZR(NM,M) and ZI(NM,M).
  27332. C
  27333. C     On OUTPUT
  27334. C
  27335. C        ZR and ZI contain the real and imaginary parts, respectively,
  27336. C          of the transformed eigenvectors in their first M columns.
  27337. C
  27338. C        ORTR and ORTI have been altered.
  27339. C
  27340. C     Note that CORTB preserves vector Euclidean norms.
  27341. C
  27342. C     Questions and comments should be directed to B. S. Garbow,
  27343. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  27344. C     ------------------------------------------------------------------
  27345. C
  27346. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  27347. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  27348. C                 system Routines - EISPACK Guide, Springer-Verlag,
  27349. C                 1976.
  27350. C***ROUTINES CALLED  (NONE)
  27351. C***REVISION HISTORY  (YYMMDD)
  27352. C   760101  DATE WRITTEN
  27353. C   890831  Modified array declarations.  (WRB)
  27354. C   890831  REVISION DATE from Version 3.2
  27355. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27356. C   920501  Reformatted the REFERENCES section.  (WRB)
  27357. C***END PROLOGUE  CORTB
  27358. C
  27359.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  27360.       REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*)
  27361.       REAL ZR(NM,*),ZI(NM,*)
  27362.       REAL H,GI,GR
  27363. C
  27364. C***FIRST EXECUTABLE STATEMENT  CORTB
  27365.       IF (M .EQ. 0) GO TO 200
  27366.       LA = IGH - 1
  27367.       KP1 = LOW + 1
  27368.       IF (LA .LT. KP1) GO TO 200
  27369. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  27370.       DO 140 MM = KP1, LA
  27371.          MP = LOW + IGH - MM
  27372.          IF (AR(MP,MP-1) .EQ. 0.0E0 .AND. AI(MP,MP-1) .EQ. 0.0E0)
  27373.      1      GO TO 140
  27374. C     .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
  27375.          H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP)
  27376.          MP1 = MP + 1
  27377. C
  27378.          DO 100 I = MP1, IGH
  27379.             ORTR(I) = AR(I,MP-1)
  27380.             ORTI(I) = AI(I,MP-1)
  27381.   100    CONTINUE
  27382. C
  27383.          DO 130 J = 1, M
  27384.             GR = 0.0E0
  27385.             GI = 0.0E0
  27386. C
  27387.             DO 110 I = MP, IGH
  27388.                GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J)
  27389.                GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J)
  27390.   110       CONTINUE
  27391. C
  27392.             GR = GR / H
  27393.             GI = GI / H
  27394. C
  27395.             DO 120 I = MP, IGH
  27396.                ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I)
  27397.                ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I)
  27398.   120       CONTINUE
  27399. C
  27400.   130    CONTINUE
  27401. C
  27402.   140 CONTINUE
  27403. C
  27404.   200 RETURN
  27405.       END
  27406. *DECK CORTH
  27407.       SUBROUTINE CORTH (NM, N, LOW, IGH, AR, AI, ORTR, ORTI)
  27408. C***BEGIN PROLOGUE  CORTH
  27409. C***PURPOSE  Reduce a complex general matrix to complex upper Hessenberg
  27410. C            form using unitary similarity transformations.
  27411. C***LIBRARY   SLATEC (EISPACK)
  27412. C***CATEGORY  D4C1B2
  27413. C***TYPE      COMPLEX (ORTHES-S, CORTH-C)
  27414. C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
  27415. C***AUTHOR  Smith, B. T., et al.
  27416. C***DESCRIPTION
  27417. C
  27418. C     This subroutine is a translation of a complex analogue of
  27419. C     the ALGOL procedure ORTHES, NUM. MATH. 12, 349-368(1968)
  27420. C     by Martin and Wilkinson.
  27421. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  27422. C
  27423. C     Given a COMPLEX GENERAL matrix, this subroutine
  27424. C     reduces a submatrix situated in rows and columns
  27425. C     LOW through IGH to upper Hessenberg form by
  27426. C     unitary similarity transformations.
  27427. C
  27428. C     On INPUT
  27429. C
  27430. C        NM must be set to the row dimension of the two-dimensional
  27431. C          array parameters, AR and AI, as declared in the calling
  27432. C          program dimension statement.  NM is an INTEGER variable.
  27433. C
  27434. C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
  27435. C          variable.  N must be less than or equal to NM.
  27436. C
  27437. C        LOW and IGH are two INTEGER variables determined by the
  27438. C          balancing subroutine  CBAL.  If  CBAL  has not been used,
  27439. C          set LOW=1 and IGH equal to the order of the matrix, N.
  27440. C
  27441. C        AR and AI contain the real and imaginary parts, respectively,
  27442. C          of the complex input matrix.  AR and AI are two-dimensional
  27443. C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
  27444. C
  27445. C     On OUTPUT
  27446. C
  27447. C        AR and AI contain the real and imaginary parts, respectively,
  27448. C          of the Hessenberg matrix.  Information about the unitary
  27449. C          transformations used in the reduction is stored in the
  27450. C          remaining triangles under the Hessenberg matrix.
  27451. C
  27452. C        ORTR and ORTI contain further information about the unitary
  27453. C          transformations.  Only elements LOW through IGH are used.
  27454. C          ORTR and ORTI are one-dimensional REAL arrays, dimensioned
  27455. C          ORTR(IGH) and ORTI(IGH).
  27456. C
  27457. C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
  27458. C
  27459. C     Questions and comments should be directed to B. S. Garbow,
  27460. C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
  27461. C     ------------------------------------------------------------------
  27462. C
  27463. C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
  27464. C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
  27465. C                 system Routines - EISPACK Guide, Springer-Verlag,
  27466. C                 1976.
  27467. C***ROUTINES CALLED  PYTHAG
  27468. C***REVISION HISTORY  (YYMMDD)
  27469. C   760101  DATE WRITTEN
  27470. C   890831  Modified array declarations.  (WRB)
  27471. C   890831  REVISION DATE from Version 3.2
  27472. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27473. C   920501  Reformatted the REFERENCES section.  (WRB)
  27474. C***END PROLOGUE  CORTH
  27475. C
  27476.       INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
  27477.       REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*)
  27478.       REAL F,G,H,FI,FR,SCALE
  27479.       REAL PYTHAG
  27480. C
  27481. C***FIRST EXECUTABLE STATEMENT  CORTH
  27482.       LA = IGH - 1
  27483.       KP1 = LOW + 1
  27484.       IF (LA .LT. KP1) GO TO 200
  27485. C
  27486.       DO 180 M = KP1, LA
  27487.          H = 0.0E0
  27488.          ORTR(M) = 0.0E0
  27489.          ORTI(M) = 0.0E0
  27490.          SCALE = 0.0E0
  27491. C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
  27492.          DO 90 I = M, IGH
  27493.    90    SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1))
  27494. C
  27495.          IF (SCALE .EQ. 0.0E0) GO TO 180
  27496.          MP = M + IGH
  27497. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  27498.          DO 100 II = M, IGH
  27499.             I = MP - II
  27500.             ORTR(I) = AR(I,M-1) / SCALE
  27501.             ORTI(I) = AI(I,M-1) / SCALE
  27502.             H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  27503.   100    CONTINUE
  27504. C
  27505.          G = SQRT(H)
  27506.          F = PYTHAG(ORTR(M),ORTI(M))
  27507.          IF (F .EQ. 0.0E0) GO TO 103
  27508.          H = H + F * G
  27509.          G = G / F
  27510.          ORTR(M) = (1.0E0 + G) * ORTR(M)
  27511.          ORTI(M) = (1.0E0 + G) * ORTI(M)
  27512.          GO TO 105
  27513. C
  27514.   103    ORTR(M) = G
  27515.          AR(M,M-1) = SCALE
  27516. C     .......... FORM (I-(U*UT)/H) * A ..........
  27517.   105    DO 130 J = M, N
  27518.             FR = 0.0E0
  27519.             FI = 0.0E0
  27520. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  27521.             DO 110 II = M, IGH
  27522.                I = MP - II
  27523.                FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
  27524.                FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  27525.   110       CONTINUE
  27526. C
  27527.             FR = FR / H
  27528.             FI = FI / H
  27529. C
  27530.             DO 120 I = M, IGH
  27531.                AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
  27532.                AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  27533.   120       CONTINUE
  27534. C
  27535.   130    CONTINUE
  27536. C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
  27537.          DO 160 I = 1, IGH
  27538.             FR = 0.0E0
  27539.             FI = 0.0E0
  27540. C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
  27541.             DO 140 JJ = M, IGH
  27542.                J = MP - JJ
  27543.                FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
  27544.                FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  27545.   140       CONTINUE
  27546. C
  27547.             FR = FR / H
  27548.             FI = FI / H
  27549. C
  27550.             DO 150 J = M, IGH
  27551.                AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
  27552.                AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  27553.   150       CONTINUE
  27554. C
  27555.   160    CONTINUE
  27556. C
  27557.          ORTR(M) = SCALE * ORTR(M)
  27558.          ORTI(M) = SCALE * ORTI(M)
  27559.          AR(M,M-1) = -G * AR(M,M-1)
  27560.          AI(M,M-1) = -G * AI(M,M-1)
  27561.   180 CONTINUE
  27562. C
  27563.   200 RETURN
  27564.       END
  27565. *DECK COSDG
  27566.       FUNCTION COSDG (X)
  27567. C***BEGIN PROLOGUE  COSDG
  27568. C***PURPOSE  Compute the cosine of an argument in degrees.
  27569. C***LIBRARY   SLATEC (FNLIB)
  27570. C***CATEGORY  C4A
  27571. C***TYPE      SINGLE PRECISION (COSDG-S, DCOSDG-D)
  27572. C***KEYWORDS  COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB,
  27573. C             TRIGONOMETRIC
  27574. C***AUTHOR  Fullerton, W., (LANL)
  27575. C***DESCRIPTION
  27576. C
  27577. C COSDG(X) evaluates the cosine for real X in degrees.
  27578. C
  27579. C***REFERENCES  (NONE)
  27580. C***ROUTINES CALLED  (NONE)
  27581. C***REVISION HISTORY  (YYMMDD)
  27582. C   770601  DATE WRITTEN
  27583. C   890531  Changed all specific intrinsics to generic.  (WRB)
  27584. C   890531  REVISION DATE from Version 3.2
  27585. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27586. C***END PROLOGUE  COSDG
  27587. C JUNE 1977 EDITION.   W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
  27588.       SAVE RADDEG
  27589.       DATA RADDEG / .017453292519943296E0 /
  27590. C
  27591. C***FIRST EXECUTABLE STATEMENT  COSDG
  27592.       COSDG = COS (RADDEG*X)
  27593. C
  27594.       IF (MOD(X,90.).NE.0.) RETURN
  27595.       N = ABS(X)/90.0 + 0.5
  27596.       N = MOD (N, 2)
  27597.       IF (N.EQ.0) COSDG = SIGN (1.0, COSDG)
  27598.       IF (N.EQ.1) COSDG = 0.0
  27599. C
  27600.       RETURN
  27601.       END
  27602. *DECK COSGEN
  27603.       SUBROUTINE COSGEN (N, IJUMP, FNUM, FDEN, A)
  27604. C***BEGIN PROLOGUE  COSGEN
  27605. C***SUBSIDIARY
  27606. C***PURPOSE  Subsidiary to GENBUN
  27607. C***LIBRARY   SLATEC
  27608. C***TYPE      SINGLE PRECISION (COSGEN-S, CMPCSG-C)
  27609. C***AUTHOR  (UNKNOWN)
  27610. C***DESCRIPTION
  27611. C
  27612. C     This subroutine computes required cosine values in ascending
  27613. C     order.  When IJUMP .GT. 1 the routine computes values
  27614. C
  27615. C        2*COS(J*PI/L) , J=1,2,...,L and J .NE. 0(MOD N/IJUMP+1)
  27616. C
  27617. C     where L = IJUMP*(N/IJUMP+1).
  27618. C
  27619. C
  27620. C     when IJUMP = 1 it computes
  27621. C
  27622. C            2*COS((J-FNUM)*PI/(N+FDEN)) ,  J=1, 2, ... ,N
  27623. C
  27624. C     where
  27625. C        FNUM = 0.5, FDEN = 0.0, for regular reduction values.
  27626. C        FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1
  27627. C        FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2
  27628. C        FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2
  27629. C                                in POISN2 only.
  27630. C
  27631. C***SEE ALSO  GENBUN
  27632. C***ROUTINES CALLED  PIMACH
  27633. C***REVISION HISTORY  (YYMMDD)
  27634. C   801001  DATE WRITTEN
  27635. C   890531  Changed all specific intrinsics to generic.  (WRB)
  27636. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27637. C   900402  Added TYPE section.  (WRB)
  27638. C***END PROLOGUE  COSGEN
  27639.       DIMENSION       A(*)
  27640. C
  27641. C
  27642. C***FIRST EXECUTABLE STATEMENT  COSGEN
  27643.       PI = PIMACH(DUM)
  27644.       IF (N .EQ. 0) GO TO 105
  27645.       IF (IJUMP .EQ. 1) GO TO 103
  27646.       K3 = N/IJUMP+1
  27647.       K4 = K3-1
  27648.       PIBYN = PI/(N+IJUMP)
  27649.       DO 102 K=1,IJUMP
  27650.          K1 = (K-1)*K3
  27651.          K5 = (K-1)*K4
  27652.          DO 101 I=1,K4
  27653.             X = K1+I
  27654.             K2 = K5+I
  27655.             A(K2) = -2.*COS(X*PIBYN)
  27656.   101    CONTINUE
  27657.   102 CONTINUE
  27658.       GO TO 105
  27659.   103 CONTINUE
  27660.       NP1 = N+1
  27661.       Y = PI/(N+FDEN)
  27662.       DO 104 I=1,N
  27663.          X = NP1-I-FNUM
  27664.          A(I) = 2.*COS(X*Y)
  27665.   104 CONTINUE
  27666.   105 CONTINUE
  27667.       RETURN
  27668.       END
  27669. *DECK COSQB
  27670.       SUBROUTINE COSQB (N, X, WSAVE)
  27671. C***BEGIN PROLOGUE  COSQB
  27672. C***PURPOSE  Compute the unnormalized inverse cosine transform.
  27673. C***LIBRARY   SLATEC (FFTPACK)
  27674. C***CATEGORY  J1A3
  27675. C***TYPE      SINGLE PRECISION (COSQB-S)
  27676. C***KEYWORDS  FFTPACK, INVERSE COSINE FOURIER TRANSFORM
  27677. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  27678. C***DESCRIPTION
  27679. C
  27680. C  Subroutine COSQB computes the fast Fourier transform of quarter
  27681. C  wave data. That is, COSQB computes a sequence from its
  27682. C  representation in terms of a cosine series with odd wave numbers.
  27683. C  The transform is defined below at output parameter X.
  27684. C
  27685. C  COSQB is the unnormalized inverse of COSQF since a call of COSQB
  27686. C  followed by a call of COSQF will multiply the input sequence X
  27687. C  by 4*N.
  27688. C
  27689. C  The array WSAVE which is used by subroutine COSQB must be
  27690. C  initialized by calling subroutine COSQI(N,WSAVE).
  27691. C
  27692. C
  27693. C  Input Parameters
  27694. C
  27695. C  N       the length of the array X to be transformed.  The method
  27696. C          is most efficient when N is a product of small primes.
  27697. C
  27698. C  X       an array which contains the sequence to be transformed
  27699. C
  27700. C  WSAVE   a work array which must be dimensioned at least 3*N+15
  27701. C          in the program that calls COSQB.  The WSAVE array must be
  27702. C          initialized by calling subroutine COSQI(N,WSAVE), and a
  27703. C          different WSAVE array must be used for each different
  27704. C          value of N.  This initialization does not have to be
  27705. C          repeated so long as N remains unchanged.  Thus subsequent
  27706. C          transforms can be obtained faster than the first.
  27707. C
  27708. C  Output Parameters
  27709. C
  27710. C  X       For I=1,...,N
  27711. C
  27712. C               X(I)= the sum from K=1 to K=N of
  27713. C
  27714. C                  2*X(K)*COS((2*K-1)*(I-1)*PI/(2*N))
  27715. C
  27716. C               A call of COSQB followed by a call of
  27717. C               COSQF will multiply the sequence X by 4*N.
  27718. C               Therefore COSQF is the unnormalized inverse
  27719. C               of COSQB.
  27720. C
  27721. C  WSAVE   contains initialization calculations which must not
  27722. C          be destroyed between calls of COSQB or COSQF.
  27723. C
  27724. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  27725. C                 Computations (G. Rodrigue, ed.), Academic Press,
  27726. C                 1982, pp. 51-83.
  27727. C***ROUTINES CALLED  COSQB1
  27728. C***REVISION HISTORY  (YYMMDD)
  27729. C   790601  DATE WRITTEN
  27730. C   830401  Modified to use SLATEC library source file format.
  27731. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  27732. C           (a) changing dummy array size declarations (1) to (*),
  27733. C           (b) changing definition of variable TSQRT2 by using
  27734. C               FORTRAN intrinsic function SQRT instead of a DATA
  27735. C               statement.
  27736. C   861211  REVISION DATE from Version 3.2
  27737. C   881128  Modified by Dick Valent to meet prologue standards.
  27738. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27739. C   920501  Reformatted the REFERENCES section.  (WRB)
  27740. C***END PROLOGUE  COSQB
  27741.       DIMENSION X(*), WSAVE(*)
  27742. C***FIRST EXECUTABLE STATEMENT  COSQB
  27743.       TSQRT2 = 2.*SQRT(2.)
  27744.       IF (N-2) 101,102,103
  27745.   101 X(1) = 4.*X(1)
  27746.       RETURN
  27747.   102 X1 = 4.*(X(1)+X(2))
  27748.       X(2) = TSQRT2*(X(1)-X(2))
  27749.       X(1) = X1
  27750.       RETURN
  27751.   103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1))
  27752.       RETURN
  27753.       END
  27754. *DECK COSQB1
  27755.       SUBROUTINE COSQB1 (N, X, W, XH)
  27756. C***BEGIN PROLOGUE  COSQB1
  27757. C***SUBSIDIARY
  27758. C***PURPOSE  Compute the unnormalized inverse of COSQF1.
  27759. C***LIBRARY   SLATEC (FFTPACK)
  27760. C***CATEGORY  J1A3
  27761. C***TYPE      SINGLE PRECISION (COSQB1-S)
  27762. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  27763. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  27764. C***DESCRIPTION
  27765. C
  27766. C  Subroutine COSQB1 computes the fast Fourier transform of quarter
  27767. C  wave data. That is, COSQB1 computes a sequence from its
  27768. C  representation in terms of a cosine series with odd wave numbers.
  27769. C  The transform is defined below at output parameter X.
  27770. C
  27771. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  27772. C                 Computations (G. Rodrigue, ed.), Academic Press,
  27773. C                 1982, pp. 51-83.
  27774. C***ROUTINES CALLED  RFFTB
  27775. C***REVISION HISTORY  (YYMMDD)
  27776. C   790601  DATE WRITTEN
  27777. C   830401  Modified to use SLATEC library source file format.
  27778. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  27779. C           changing dummy array size declarations (1) to (*).
  27780. C   881128  Modified by Dick Valent to meet prologue standards.
  27781. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27782. C   920501  Reformatted the REFERENCES section.  (WRB)
  27783. C***END PROLOGUE  COSQB1
  27784.       DIMENSION X(*), W(*), XH(*)
  27785. C***FIRST EXECUTABLE STATEMENT  COSQB1
  27786.       NS2 = (N+1)/2
  27787.       NP2 = N+2
  27788.       DO 101 I=3,N,2
  27789.          XIM1 = X(I-1)+X(I)
  27790.          X(I) = X(I)-X(I-1)
  27791.          X(I-1) = XIM1
  27792.   101 CONTINUE
  27793.       X(1) = X(1)+X(1)
  27794.       MODN = MOD(N,2)
  27795.       IF (MODN .EQ. 0) X(N) = X(N)+X(N)
  27796.       CALL RFFTB (N,X,XH)
  27797.       DO 102 K=2,NS2
  27798.          KC = NP2-K
  27799.          XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K)
  27800.          XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC)
  27801.   102 CONTINUE
  27802.       IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1))
  27803.       DO 103 K=2,NS2
  27804.          KC = NP2-K
  27805.          X(K) = XH(K)+XH(KC)
  27806.          X(KC) = XH(K)-XH(KC)
  27807.   103 CONTINUE
  27808.       X(1) = X(1)+X(1)
  27809.       RETURN
  27810.       END
  27811. *DECK COSQF
  27812.       SUBROUTINE COSQF (N, X, WSAVE)
  27813. C***BEGIN PROLOGUE  COSQF
  27814. C***PURPOSE  Compute the forward cosine transform with odd wave numbers.
  27815. C***LIBRARY   SLATEC (FFTPACK)
  27816. C***CATEGORY  J1A3
  27817. C***TYPE      SINGLE PRECISION (COSQF-S)
  27818. C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
  27819. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  27820. C***DESCRIPTION
  27821. C
  27822. C  Subroutine COSQF computes the fast Fourier transform of quarter
  27823. C  wave data. That is, COSQF computes the coefficients in a cosine
  27824. C  series representation with only odd wave numbers.  The transform
  27825. C  is defined below at Output Parameter X
  27826. C
  27827. C  COSQF is the unnormalized inverse of COSQB since a call of COSQF
  27828. C  followed by a call of COSQB will multiply the input sequence X
  27829. C  by 4*N.
  27830. C
  27831. C  The array WSAVE which is used by subroutine COSQF must be
  27832. C  initialized by calling subroutine COSQI(N,WSAVE).
  27833. C
  27834. C
  27835. C  Input Parameters
  27836. C
  27837. C  N       the length of the array X to be transformed.  The method
  27838. C          is most efficient when N is a product of small primes.
  27839. C
  27840. C  X       an array which contains the sequence to be transformed
  27841. C
  27842. C  WSAVE   a work array which must be dimensioned at least 3*N+15
  27843. C          in the program that calls COSQF.  The WSAVE array must be
  27844. C          initialized by calling subroutine COSQI(N,WSAVE), and a
  27845. C          different WSAVE array must be used for each different
  27846. C          value of N.  This initialization does not have to be
  27847. C          repeated so long as N remains unchanged.  Thus subsequent
  27848. C          transforms can be obtained faster than the first.
  27849. C
  27850. C  Output Parameters
  27851. C
  27852. C  X       For I=1,...,N
  27853. C
  27854. C               X(I) = X(1) plus the sum from K=2 to K=N of
  27855. C
  27856. C                  2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N))
  27857. C
  27858. C               A call of COSQF followed by a call of
  27859. C               COSQB will multiply the sequence X by 4*N.
  27860. C               Therefore COSQB is the unnormalized inverse
  27861. C               of COSQF.
  27862. C
  27863. C  WSAVE   contains initialization calculations which must not
  27864. C          be destroyed between calls of COSQF or COSQB.
  27865. C
  27866. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  27867. C                 Computations (G. Rodrigue, ed.), Academic Press,
  27868. C                 1982, pp. 51-83.
  27869. C***ROUTINES CALLED  COSQF1
  27870. C***REVISION HISTORY  (YYMMDD)
  27871. C   790601  DATE WRITTEN
  27872. C   830401  Modified to use SLATEC library source file format.
  27873. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  27874. C           (a) changing dummy array size declarations (1) to (*),
  27875. C           (b) changing definition of variable SQRT2 by using
  27876. C               FORTRAN intrinsic function SQRT instead of a DATA
  27877. C               statement.
  27878. C   861211  REVISION DATE from Version 3.2
  27879. C   881128  Modified by Dick Valent to meet prologue standards.
  27880. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27881. C   920501  Reformatted the REFERENCES section.  (WRB)
  27882. C***END PROLOGUE  COSQF
  27883.       DIMENSION X(*), WSAVE(*)
  27884. C***FIRST EXECUTABLE STATEMENT  COSQF
  27885.       SQRT2 = SQRT(2.)
  27886.       IF (N-2) 102,101,103
  27887.   101 TSQX = SQRT2*X(2)
  27888.       X(2) = X(1)-TSQX
  27889.       X(1) = X(1)+TSQX
  27890.   102 RETURN
  27891.   103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
  27892.       RETURN
  27893.       END
  27894. *DECK COSQF1
  27895.       SUBROUTINE COSQF1 (N, X, W, XH)
  27896. C***BEGIN PROLOGUE  COSQF1
  27897. C***SUBSIDIARY
  27898. C***PURPOSE  Compute the forward cosine transform with odd wave numbers.
  27899. C***LIBRARY   SLATEC (FFTPACK)
  27900. C***CATEGORY  J1A3
  27901. C***TYPE      SINGLE PRECISION (COSQF1-S)
  27902. C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
  27903. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  27904. C***DESCRIPTION
  27905. C
  27906. C  Subroutine COSQF1 computes the fast Fourier transform of quarter
  27907. C  wave data. That is, COSQF1 computes the coefficients in a cosine
  27908. C  series representation with only odd wave numbers.  The transform
  27909. C  is defined below at Output Parameter X
  27910. C
  27911. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  27912. C                 Computations (G. Rodrigue, ed.), Academic Press,
  27913. C                 1982, pp. 51-83.
  27914. C***ROUTINES CALLED  RFFTF
  27915. C***REVISION HISTORY  (YYMMDD)
  27916. C   790601  DATE WRITTEN
  27917. C   830401  Modified to use SLATEC library source file format.
  27918. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  27919. C           changing dummy array size declarations (1) to (*).
  27920. C   881128  Modified by Dick Valent to meet prologue standards.
  27921. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27922. C   920501  Reformatted the REFERENCES section.  (WRB)
  27923. C***END PROLOGUE  COSQF1
  27924.       DIMENSION X(*), W(*), XH(*)
  27925. C***FIRST EXECUTABLE STATEMENT  COSQF1
  27926.       NS2 = (N+1)/2
  27927.       NP2 = N+2
  27928.       DO 101 K=2,NS2
  27929.          KC = NP2-K
  27930.          XH(K) = X(K)+X(KC)
  27931.          XH(KC) = X(K)-X(KC)
  27932.   101 CONTINUE
  27933.       MODN = MOD(N,2)
  27934.       IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
  27935.       DO 102 K=2,NS2
  27936.          KC = NP2-K
  27937.          X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
  27938.          X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
  27939.   102 CONTINUE
  27940.       IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
  27941.       CALL RFFTF (N,X,XH)
  27942.       DO 103 I=3,N,2
  27943.          XIM1 = X(I-1)-X(I)
  27944.          X(I) = X(I-1)+X(I)
  27945.          X(I-1) = XIM1
  27946.   103 CONTINUE
  27947.       RETURN
  27948.       END
  27949. *DECK COSQI
  27950.       SUBROUTINE COSQI (N, WSAVE)
  27951. C***BEGIN PROLOGUE  COSQI
  27952. C***PURPOSE  Initialize a work array for COSQF and COSQB.
  27953. C***LIBRARY   SLATEC (FFTPACK)
  27954. C***CATEGORY  J1A3
  27955. C***TYPE      SINGLE PRECISION (COSQI-S)
  27956. C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
  27957. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  27958. C***DESCRIPTION
  27959. C
  27960. C  Subroutine COSQI initializes the work array WSAVE which is used in
  27961. C  both COSQF1 and COSQB1.  The prime factorization of N together with
  27962. C  a tabulation of the trigonometric functions are computed and
  27963. C  stored in WSAVE.
  27964. C
  27965. C  Input Parameter
  27966. C
  27967. C  N       the length of the array to be transformed.  The method
  27968. C          is most efficient when N is a product of small primes.
  27969. C
  27970. C  Output Parameter
  27971. C
  27972. C  WSAVE   a work array which must be dimensioned at least 3*N+15.
  27973. C          The same work array can be used for both COSQF1 and COSQB1
  27974. C          as long as N remains unchanged.  Different WSAVE arrays
  27975. C          are required for different values of N.  The contents of
  27976. C          WSAVE must not be changed between calls of COSQF1 or COSQB1.
  27977. C
  27978. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  27979. C                 Computations (G. Rodrigue, ed.), Academic Press,
  27980. C                 1982, pp. 51-83.
  27981. C***ROUTINES CALLED  RFFTI
  27982. C***REVISION HISTORY  (YYMMDD)
  27983. C   790601  DATE WRITTEN
  27984. C   830401  Modified to use SLATEC library source file format.
  27985. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  27986. C           (a) changing dummy array size declarations (1) to (*),
  27987. C           (b) changing references to intrinsic function FLOAT
  27988. C               to REAL, and
  27989. C           (c) changing definition of variable PIH by using
  27990. C               FORTRAN intrinsic function ATAN instead of a DATA
  27991. C               statement.
  27992. C   881128  Modified by Dick Valent to meet prologue standards.
  27993. C   890531  Changed all specific intrinsics to generic.  (WRB)
  27994. C   890531  REVISION DATE from Version 3.2
  27995. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  27996. C   920501  Reformatted the REFERENCES section.  (WRB)
  27997. C***END PROLOGUE  COSQI
  27998.       DIMENSION WSAVE(*)
  27999. C***FIRST EXECUTABLE STATEMENT  COSQI
  28000.       PIH = 2.*ATAN(1.)
  28001.       DT = PIH/N
  28002.       FK = 0.
  28003.       DO 101 K=1,N
  28004.          FK = FK+1.
  28005.          WSAVE(K) = COS(FK*DT)
  28006.   101 CONTINUE
  28007.       CALL RFFTI (N,WSAVE(N+1))
  28008.       RETURN
  28009.       END
  28010. *DECK COST
  28011.       SUBROUTINE COST (N, X, WSAVE)
  28012. C***BEGIN PROLOGUE  COST
  28013. C***PURPOSE  Compute the cosine transform of a real, even sequence.
  28014. C***LIBRARY   SLATEC (FFTPACK)
  28015. C***CATEGORY  J1A3
  28016. C***TYPE      SINGLE PRECISION (COST-S)
  28017. C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
  28018. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  28019. C***DESCRIPTION
  28020. C
  28021. C  Subroutine COST computes the discrete Fourier cosine transform
  28022. C  of an even sequence X(I).  The transform is defined below at output
  28023. C  parameter X.
  28024. C
  28025. C  COST is the unnormalized inverse of itself since a call of COST
  28026. C  followed by another call of COST will multiply the input sequence
  28027. C  X by 2*(N-1).  The transform is defined below at output parameter X.
  28028. C
  28029. C  The array WSAVE which is used by subroutine COST must be
  28030. C  initialized by calling subroutine COSTI(N,WSAVE).
  28031. C
  28032. C  Input Parameters
  28033. C
  28034. C  N       the length of the sequence X.  N must be greater than 1.
  28035. C          The method is most efficient when N-1 is a product of
  28036. C          small primes.
  28037. C
  28038. C  X       an array which contains the sequence to be transformed
  28039. C
  28040. C  WSAVE   a work array which must be dimensioned at least 3*N+15
  28041. C          in the program that calls COST.  The WSAVE array must be
  28042. C          initialized by calling subroutine COSTI(N,WSAVE), and a
  28043. C          different WSAVE array must be used for each different
  28044. C          value of N.  This initialization does not have to be
  28045. C          repeated so long as N remains unchanged.  Thus subsequent
  28046. C          transforms can be obtained faster than the first.
  28047. C
  28048. C  Output Parameters
  28049. C
  28050. C  X       For I=1,...,N
  28051. C
  28052. C             X(I) = X(1)+(-1)**(I-1)*X(N)
  28053. C
  28054. C               + the sum from K=2 to K=N-1
  28055. C
  28056. C                 2*X(K)*COS((K-1)*(I-1)*PI/(N-1))
  28057. C
  28058. C               A call of COST followed by another call of
  28059. C               COST will multiply the sequence X by 2*(N-1).
  28060. C               Hence COST is the unnormalized inverse
  28061. C               of itself.
  28062. C
  28063. C  WSAVE   contains initialization calculations which must not be
  28064. C          destroyed between calls of COST.
  28065. C
  28066. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  28067. C                 Computations (G. Rodrigue, ed.), Academic Press,
  28068. C                 1982, pp. 51-83.
  28069. C***ROUTINES CALLED  RFFTF
  28070. C***REVISION HISTORY  (YYMMDD)
  28071. C   790601  DATE WRITTEN
  28072. C   830401  Modified to use SLATEC library source file format.
  28073. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  28074. C           changing dummy array size declarations (1) to (*)
  28075. C   861211  REVISION DATE from Version 3.2
  28076. C   881128  Modified by Dick Valent to meet prologue standards.
  28077. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28078. C   920501  Reformatted the REFERENCES section.  (WRB)
  28079. C***END PROLOGUE  COST
  28080.       DIMENSION X(*), WSAVE(*)
  28081. C***FIRST EXECUTABLE STATEMENT  COST
  28082.       NM1 = N-1
  28083.       NP1 = N+1
  28084.       NS2 = N/2
  28085.       IF (N-2) 106,101,102
  28086.   101 X1H = X(1)+X(2)
  28087.       X(2) = X(1)-X(2)
  28088.       X(1) = X1H
  28089.       RETURN
  28090.   102 IF (N .GT. 3) GO TO 103
  28091.       X1P3 = X(1)+X(3)
  28092.       TX2 = X(2)+X(2)
  28093.       X(2) = X(1)-X(3)
  28094.       X(1) = X1P3+TX2
  28095.       X(3) = X1P3-TX2
  28096.       RETURN
  28097.   103 C1 = X(1)-X(N)
  28098.       X(1) = X(1)+X(N)
  28099.       DO 104 K=2,NS2
  28100.          KC = NP1-K
  28101.          T1 = X(K)+X(KC)
  28102.          T2 = X(K)-X(KC)
  28103.          C1 = C1+WSAVE(KC)*T2
  28104.          T2 = WSAVE(K)*T2
  28105.          X(K) = T1-T2
  28106.          X(KC) = T1+T2
  28107.   104 CONTINUE
  28108.       MODN = MOD(N,2)
  28109.       IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
  28110.       CALL RFFTF (NM1,X,WSAVE(N+1))
  28111.       XIM2 = X(2)
  28112.       X(2) = C1
  28113.       DO 105 I=4,N,2
  28114.          XI = X(I)
  28115.          X(I) = X(I-2)-X(I-1)
  28116.          X(I-1) = XIM2
  28117.          XIM2 = XI
  28118.   105 CONTINUE
  28119.       IF (MODN .NE. 0) X(N) = XIM2
  28120.   106 RETURN
  28121.       END
  28122. *DECK COSTI
  28123.       SUBROUTINE COSTI (N, WSAVE)
  28124. C***BEGIN PROLOGUE  COSTI
  28125. C***PURPOSE  Initialize a work array for COST.
  28126. C***LIBRARY   SLATEC (FFTPACK)
  28127. C***CATEGORY  J1A3
  28128. C***TYPE      SINGLE PRECISION (COSTI-S)
  28129. C***KEYWORDS  COSINE FOURIER TRANSFORM, FFTPACK
  28130. C***AUTHOR  Swarztrauber, P. N., (NCAR)
  28131. C***DESCRIPTION
  28132. C
  28133. C  Subroutine COSTI initializes the array WSAVE which is used in
  28134. C  subroutine COST.  The prime factorization of N together with
  28135. C  a tabulation of the trigonometric functions are computed and
  28136. C  stored in WSAVE.
  28137. C
  28138. C  Input Parameter
  28139. C
  28140. C  N       the length of the sequence to be transformed.  The method
  28141. C          is most efficient when N-1 is a product of small primes.
  28142. C
  28143. C  Output Parameter
  28144. C
  28145. C  WSAVE   a work array which must be dimensioned at least 3*N+15.
  28146. C          Different WSAVE arrays are required for different values
  28147. C          of N.  The contents of WSAVE must not be changed between
  28148. C          calls of COST.
  28149. C
  28150. C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
  28151. C                 Computations (G. Rodrigue, ed.), Academic Press,
  28152. C                 1982, pp. 51-83.
  28153. C***ROUTINES CALLED  RFFTI
  28154. C***REVISION HISTORY  (YYMMDD)
  28155. C   790601  DATE WRITTEN
  28156. C   830401  Modified to use SLATEC library source file format.
  28157. C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  28158. C           (a) changing dummy array size declarations (1) to (*),
  28159. C           (b) changing references to intrinsic function FLOAT
  28160. C               to REAL, and
  28161. C           (c) changing definition of variable PI by using
  28162. C               FORTRAN intrinsic function ATAN instead of a DATA
  28163. C               statement.
  28164. C   881128  Modified by Dick Valent to meet prologue standards.
  28165. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28166. C   890531  REVISION DATE from Version 3.2
  28167. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28168. C   920501  Reformatted the REFERENCES section.  (WRB)
  28169. C***END PROLOGUE  COSTI
  28170.       DIMENSION WSAVE(*)
  28171. C***FIRST EXECUTABLE STATEMENT  COSTI
  28172.       IF (N .LE. 3) RETURN
  28173.       PI = 4.*ATAN(1.)
  28174.       NM1 = N-1
  28175.       NP1 = N+1
  28176.       NS2 = N/2
  28177.       DT = PI/NM1
  28178.       FK = 0.
  28179.       DO 101 K=2,NS2
  28180.          KC = NP1-K
  28181.          FK = FK+1.
  28182.          WSAVE(K) = 2.*SIN(FK*DT)
  28183.          WSAVE(KC) = 2.*COS(FK*DT)
  28184.   101 CONTINUE
  28185.       CALL RFFTI (NM1,WSAVE(N+1))
  28186.       RETURN
  28187.       END
  28188. *DECK COT
  28189.       FUNCTION COT (X)
  28190. C***BEGIN PROLOGUE  COT
  28191. C***PURPOSE  Compute the cotangent.
  28192. C***LIBRARY   SLATEC (FNLIB)
  28193. C***CATEGORY  C4A
  28194. C***TYPE      SINGLE PRECISION (COT-S, DCOT-D, CCOT-C)
  28195. C***KEYWORDS  COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
  28196. C***AUTHOR  Fullerton, W., (LANL)
  28197. C***DESCRIPTION
  28198. C
  28199. C COT(X) calculates the cotangent of the real argument X.  X is in
  28200. C units of radians.
  28201. C
  28202. C Series for COT        on the interval  0.          to  6.25000D-02
  28203. C                                        with weighted error   3.76E-17
  28204. C                                         log weighted error  16.42
  28205. C                               significant figures required  15.51
  28206. C                                    decimal places required  16.88
  28207. C
  28208. C***REFERENCES  (NONE)
  28209. C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
  28210. C***REVISION HISTORY  (YYMMDD)
  28211. C   770601  DATE WRITTEN
  28212. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28213. C   890531  REVISION DATE from Version 3.2
  28214. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28215. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  28216. C   920618  Removed space from variable names.  (RWC, WRB)
  28217. C***END PROLOGUE  COT
  28218.       DIMENSION COTCS(8)
  28219.       LOGICAL FIRST
  28220.       SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST
  28221.       DATA COTCS( 1) /    .2402591609 8295630E0 /
  28222.       DATA COTCS( 2) /   -.0165330316 01500228E0 /
  28223.       DATA COTCS( 3) /   -.0000429983 91931724E0 /
  28224.       DATA COTCS( 4) /   -.0000001592 83223327E0 /
  28225.       DATA COTCS( 5) /   -.0000000006 19109313E0 /
  28226.       DATA COTCS( 6) /   -.0000000000 02430197E0 /
  28227.       DATA COTCS( 7) /   -.0000000000 00009560E0 /
  28228.       DATA COTCS( 8) /   -.0000000000 00000037E0 /
  28229.       DATA PI2REC / .01161977236 75813430 E0 /
  28230.       DATA FIRST /.TRUE./
  28231. C***FIRST EXECUTABLE STATEMENT  COT
  28232.       IF (FIRST) THEN
  28233.          NTERMS = INITS (COTCS, 8, 0.1*R1MACH(3))
  28234.          XMAX = 1.0/R1MACH(4)
  28235.          XSML = SQRT (3.0*R1MACH(3))
  28236.          XMIN = EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.01)
  28237.          SQEPS = SQRT (R1MACH(4))
  28238.       ENDIF
  28239.       FIRST = .FALSE.
  28240. C
  28241.       Y = ABS(X)
  28242.       IF (ABS(X) .LT. XMIN) CALL XERMSG ('SLATEC', 'COT',
  28243.      +   'ABS(X) IS ZERO OR SO SMALL COT OVERFLOWS', 2, 2)
  28244.       IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'COT',
  28245.      +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2)
  28246. C
  28247. C CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC)
  28248. C = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC  =  AINT(.625*Y) + Z
  28249. C = AINT(.625*Y) + AINT(Z) + REM(Z)
  28250. C
  28251.       AINTY = AINT (Y)
  28252.       YREM = Y - AINTY
  28253.       PRODBG = 0.625*AINTY
  28254.       AINTY = AINT (PRODBG)
  28255.       Y = (PRODBG-AINTY) + 0.625*YREM + Y*PI2REC
  28256.       AINTY2 = AINT (Y)
  28257.       AINTY = AINTY + AINTY2
  28258.       Y = Y - AINTY2
  28259. C
  28260.       IFN = MOD (AINTY, 2.)
  28261.       IF (IFN.EQ.1) Y = 1.0 - Y
  28262. C
  28263.       IF (ABS(X) .GT. 0.5 .AND. Y .LT. ABS(X)*SQEPS) CALL XERMSG
  28264.      +   ('SLATEC', 'COT',
  28265.      +   'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' //
  28266.      +   '(N.NE.0)' , 1, 1)
  28267. C
  28268.       IF (Y.GT.0.25) GO TO 20
  28269.       COT = 1.0/X
  28270.       IF (Y.GT.XSML) COT = (0.5 + CSEVL (32.0*Y*Y-1., COTCS, NTERMS)) /Y
  28271.       GO TO 40
  28272. C
  28273.  20   IF (Y.GT.0.5) GO TO 30
  28274.       COT = (0.5 + CSEVL (8.0*Y*Y-1., COTCS, NTERMS)) / (0.5*Y)
  28275.       COT = (COT**2 - 1.0) * 0.5 / COT
  28276.       GO TO 40
  28277. C
  28278.  30   COT = (0.5 + CSEVL (2.0*Y*Y-1., COTCS, NTERMS)) / (0.25*Y)
  28279.       COT = (COT**2 - 1.0) * 0.5 / COT
  28280.       COT = (COT**2 - 1.0) * 0.5 / COT
  28281. C
  28282.  40   IF (X.NE.0.) COT = SIGN (COT, X)
  28283.       IF (IFN.EQ.1) COT = -COT
  28284. C
  28285.       RETURN
  28286.       END
  28287. *DECK CPADD
  28288.       SUBROUTINE CPADD (N, IERROR, A, C, CBP, BP, BH)
  28289. C***BEGIN PROLOGUE  CPADD
  28290. C***SUBSIDIARY
  28291. C***PURPOSE  Subsidiary to CBLKTR
  28292. C***LIBRARY   SLATEC
  28293. C***TYPE      SINGLE PRECISION (CPADD-S)
  28294. C***AUTHOR  (UNKNOWN)
  28295. C***DESCRIPTION
  28296. C
  28297. C   CPADD computes the eigenvalues of the periodic tridiagonal matrix
  28298. C   with coefficients AN,BN,CN.
  28299. C
  28300. C   N    is the order of the BH and BP polynomials.
  28301. C   BP   contains the eigenvalues on output.
  28302. C   CBP  is the same as BP except type complex.
  28303. C   BH   is used to temporarily store the roots of the B HAT polynomial
  28304. C        which enters through BP.
  28305. C
  28306. C***SEE ALSO  CBLKTR
  28307. C***ROUTINES CALLED  BCRH, PGSF, PPGSF, PPPSF
  28308. C***COMMON BLOCKS    CCBLK
  28309. C***REVISION HISTORY  (YYMMDD)
  28310. C   801001  DATE WRITTEN
  28311. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28312. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28313. C   900402  Added TYPE section.  (WRB)
  28314. C***END PROLOGUE  CPADD
  28315. C
  28316.       COMPLEX         CX         ,FSG        ,HSG        ,
  28317.      1                DD         ,F          ,FP         ,FPP        ,
  28318.      2                CDIS       ,R1         ,R2         ,R3         ,
  28319.      3                CBP
  28320.       DIMENSION       A(*)       ,C(*)       ,BP(*)      ,BH(*)      ,
  28321.      1                CBP(*)
  28322.       COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
  28323.      1                NM         ,NCMPLX     ,IK
  28324.       EXTERNAL        PGSF       ,PPPSF      ,PPGSF
  28325. C***FIRST EXECUTABLE STATEMENT  CPADD
  28326.       SCNV = SQRT(CNV)
  28327.       IZ = N
  28328.       IF (BP(N)-BP(1)) 101,142,103
  28329.   101 DO 102 J=1,N
  28330.          NT = N-J
  28331.          BH(J) = BP(NT+1)
  28332.   102 CONTINUE
  28333.       GO TO 105
  28334.   103 DO 104 J=1,N
  28335.          BH(J) = BP(J)
  28336.   104 CONTINUE
  28337.   105 NCMPLX = 0
  28338.       MODIZ = MOD(IZ,2)
  28339.       IS = 1
  28340.       IF (MODIZ) 106,107,106
  28341.   106 IF (A(1)) 110,142,107
  28342.   107 XL = BH(1)
  28343.       DB = BH(3)-BH(1)
  28344.   108 XL = XL-DB
  28345.       IF (PGSF(XL,IZ,C,A,BH)) 108,108,109
  28346.   109 SGN = -1.
  28347.       CBP(1) = CMPLX(BCRH(XL,BH(1),IZ,C,A,BH,PGSF,SGN),0.)
  28348.       IS = 2
  28349.   110 IF = IZ-1
  28350.       IF (MODIZ) 111,112,111
  28351.   111 IF (A(1)) 112,142,115
  28352.   112 XR = BH(IZ)
  28353.       DB = BH(IZ)-BH(IZ-2)
  28354.   113 XR = XR+DB
  28355.       IF (PGSF(XR,IZ,C,A,BH)) 113,114,114
  28356.   114 SGN = 1.
  28357.       CBP(IZ) = CMPLX(BCRH(BH(IZ),XR,IZ,C,A,BH,PGSF,SGN),0.)
  28358.       IF = IZ-2
  28359.   115 DO 136 IG=IS,IF,2
  28360.          XL = BH(IG)
  28361.          XR = BH(IG+1)
  28362.          SGN = -1.
  28363.          XM = BCRH(XL,XR,IZ,C,A,BH,PPPSF,SGN)
  28364.          PSG = PGSF(XM,IZ,C,A,BH)
  28365.          IF (ABS(PSG)-EPS) 118,118,116
  28366.   116    IF (PSG*PPGSF(XM,IZ,C,A,BH)) 117,118,119
  28367. C
  28368. C     CASE OF A REAL ZERO
  28369. C
  28370.   117    SGN = 1.
  28371.          CBP(IG) = CMPLX(BCRH(BH(IG),XM,IZ,C,A,BH,PGSF,SGN),0.)
  28372.          SGN = -1.
  28373.          CBP(IG+1) = CMPLX(BCRH(XM,BH(IG+1),IZ,C,A,BH,PGSF,SGN),0.)
  28374.          GO TO 136
  28375. C
  28376. C     CASE OF A MULTIPLE ZERO
  28377. C
  28378.   118    CBP(IG) = CMPLX(XM,0.)
  28379.          CBP(IG+1) = CMPLX(XM,0.)
  28380.          GO TO 136
  28381. C
  28382. C     CASE OF A COMPLEX ZERO
  28383. C
  28384.   119    IT = 0
  28385.          ICV = 0
  28386.          CX = CMPLX(XM,0.)
  28387.   120    FSG = (1.,0.)
  28388.          HSG = (1.,0.)
  28389.          FP = (0.,0.)
  28390.          FPP = (0.,0.)
  28391.          DO 121 J=1,IZ
  28392.             DD = 1./(CX-BH(J))
  28393.             FSG = FSG*A(J)*DD
  28394.             HSG = HSG*C(J)*DD
  28395.             FP = FP+DD
  28396.             FPP = FPP-DD*DD
  28397.   121    CONTINUE
  28398.          IF (MODIZ) 123,122,123
  28399.   122    F = (1.,0.)-FSG-HSG
  28400.          GO TO 124
  28401.   123    F = (1.,0.)+FSG+HSG
  28402.   124    I3 = 0
  28403.          IF (ABS(FP)) 126,126,125
  28404.   125    I3 = 1
  28405.          R3 = -F/FP
  28406.   126    IF (ABS(FPP)) 132,132,127
  28407.   127    CDIS = SQRT(FP**2-2.*F*FPP)
  28408.          R1 = CDIS-FP
  28409.          R2 = -FP-CDIS
  28410.          IF (ABS(R1)-ABS(R2)) 129,129,128
  28411.   128    R1 = R1/FPP
  28412.          GO TO 130
  28413.   129    R1 = R2/FPP
  28414.   130    R2 = 2.*F/FPP/R1
  28415.          IF (ABS(R2) .LT. ABS(R1)) R1 = R2
  28416.          IF (I3) 133,133,131
  28417.   131    IF (ABS(R3) .LT. ABS(R1)) R1 = R3
  28418.          GO TO 133
  28419.   132    R1 = R3
  28420.   133    CX = CX+R1
  28421.          IT = IT+1
  28422.          IF (IT .GT. 50) GO TO 142
  28423.          IF (ABS(R1) .GT. SCNV) GO TO 120
  28424.          IF (ICV) 134,134,135
  28425.   134    ICV = 1
  28426.          GO TO 120
  28427.   135    CBP(IG) = CX
  28428.          CBP(IG+1) = CONJG(CX)
  28429.   136 CONTINUE
  28430.       IF (ABS(CBP(N))-ABS(CBP(1))) 137,142,139
  28431.   137 NHALF = N/2
  28432.       DO 138 J=1,NHALF
  28433.          NT = N-J
  28434.          CX = CBP(J)
  28435.          CBP(J) = CBP(NT+1)
  28436.          CBP(NT+1) = CX
  28437.   138 CONTINUE
  28438.   139 NCMPLX = 1
  28439.       DO 140 J=2,IZ
  28440.          IF (AIMAG(CBP(J))) 143,140,143
  28441.   140 CONTINUE
  28442.       NCMPLX = 0
  28443.       DO 141 J=2,IZ
  28444.          BP(J) = REAL(CBP(J))
  28445.   141 CONTINUE
  28446.       GO TO 143
  28447.   142 IERROR = 4
  28448.   143 CONTINUE
  28449.       RETURN
  28450.       END
  28451. *DECK CPBCO
  28452.       SUBROUTINE CPBCO (ABD, LDA, N, M, RCOND, Z, INFO)
  28453. C***BEGIN PROLOGUE  CPBCO
  28454. C***PURPOSE  Factor a complex Hermitian positive definite matrix stored
  28455. C            in band form and estimate the condition number of the
  28456. C            matrix.
  28457. C***LIBRARY   SLATEC (LINPACK)
  28458. C***CATEGORY  D2D2
  28459. C***TYPE      COMPLEX (SPBCO-S, DPBCO-D, CPBCO-C)
  28460. C***KEYWORDS  BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
  28461. C             MATRIX FACTORIZATION, POSITIVE DEFINITE
  28462. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  28463. C***DESCRIPTION
  28464. C
  28465. C     CPBCO factors a complex Hermitian positive definite matrix
  28466. C     stored in band form and estimates the condition of the matrix.
  28467. C
  28468. C     If  RCOND  is not needed, CPBFA is slightly faster.
  28469. C     To solve  A*X = B , follow CPBCO by CPBSL.
  28470. C     To compute  INVERSE(A)*C , follow CPBCO by CPBSL.
  28471. C     To compute  DETERMINANT(A) , follow CPBCO by CPBDI.
  28472. C
  28473. C     On Entry
  28474. C
  28475. C        ABD     COMPLEX(LDA, N)
  28476. C                the matrix to be factored.  The columns of the upper
  28477. C                triangle are stored in the columns of ABD and the
  28478. C                diagonals of the upper triangle are stored in the
  28479. C                rows of ABD .  See the comments below for details.
  28480. C
  28481. C        LDA     INTEGER
  28482. C                the leading dimension of the array  ABD .
  28483. C                LDA must be .GE. M + 1 .
  28484. C
  28485. C        N       INTEGER
  28486. C                the order of the matrix  A .
  28487. C
  28488. C        M       INTEGER
  28489. C                the number of diagonals above the main diagonal.
  28490. C                0 .LE. M .LT. N .
  28491. C
  28492. C     On Return
  28493. C
  28494. C        ABD     an upper triangular matrix  R , stored in band
  28495. C                form, so that  A = CTRANS(R)*R .
  28496. C                If  INFO .NE. 0 , the factorization is not complete.
  28497. C
  28498. C        RCOND   REAL
  28499. C                an estimate of the reciprocal condition of  A .
  28500. C                For the system  A*X = B , relative perturbations
  28501. C                in  A  and  B  of size  EPSILON  may cause
  28502. C                relative perturbations in  X  of size  EPSILON/RCOND .
  28503. C                If  RCOND  is so small that the logical expression
  28504. C                           1.0 + RCOND .EQ. 1.0
  28505. C                is true, then  A  may be singular to working
  28506. C                precision.  In particular,  RCOND  is zero  if
  28507. C                exact singularity is detected or the estimate
  28508. C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
  28509. C
  28510. C        Z       COMPLEX(N)
  28511. C                a work vector whose contents are usually unimportant.
  28512. C                If  A  is singular to working precision, then  Z  is
  28513. C                an approximate null vector in the sense that
  28514. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  28515. C                If  INFO .NE. 0 , Z  is unchanged.
  28516. C
  28517. C        INFO    INTEGER
  28518. C                = 0  for normal return.
  28519. C                = K  signals an error condition.  The leading minor
  28520. C                     of order  K  is not positive definite.
  28521. C
  28522. C     Band Storage
  28523. C
  28524. C           If  A  is a Hermitian positive definite band matrix,
  28525. C           the following program segment will set up the input.
  28526. C
  28527. C                   M = (band width above diagonal)
  28528. C                   DO 20 J = 1, N
  28529. C                      I1 = MAX(1, J-M)
  28530. C                      DO 10 I = I1, J
  28531. C                         K = I-J+M+1
  28532. C                         ABD(K,J) = A(I,J)
  28533. C                10    CONTINUE
  28534. C                20 CONTINUE
  28535. C
  28536. C           This uses  M + 1  rows of  A , except for the  M by M
  28537. C           upper left triangle, which is ignored.
  28538. C
  28539. C     Example:  If the original matrix is
  28540. C
  28541. C           11 12 13  0  0  0
  28542. C           12 22 23 24  0  0
  28543. C           13 23 33 34 35  0
  28544. C            0 24 34 44 45 46
  28545. C            0  0 35 45 55 56
  28546. C            0  0  0 46 56 66
  28547. C
  28548. C     then  N = 6 , M = 2  and  ABD  should contain
  28549. C
  28550. C            *  * 13 24 35 46
  28551. C            * 12 23 34 45 56
  28552. C           11 22 33 44 55 66
  28553. C
  28554. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  28555. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  28556. C***ROUTINES CALLED  CAXPY, CDOTC, CPBFA, CSSCAL, SCASUM
  28557. C***REVISION HISTORY  (YYMMDD)
  28558. C   780814  DATE WRITTEN
  28559. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28560. C   890831  Modified array declarations.  (WRB)
  28561. C   890831  REVISION DATE from Version 3.2
  28562. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28563. C   900326  Removed duplicate information from DESCRIPTION section.
  28564. C           (WRB)
  28565. C   920501  Reformatted the REFERENCES section.  (WRB)
  28566. C***END PROLOGUE  CPBCO
  28567.       INTEGER LDA,N,M,INFO
  28568.       COMPLEX ABD(LDA,*),Z(*)
  28569.       REAL RCOND
  28570. C
  28571.       COMPLEX CDOTC,EK,T,WK,WKM
  28572.       REAL ANORM,S,SCASUM,SM,YNORM
  28573.       INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU
  28574.       COMPLEX ZDUM,ZDUM2,CSIGN1
  28575.       REAL CABS1
  28576.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  28577.       CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2))
  28578. C
  28579. C     FIND NORM OF A
  28580. C
  28581. C***FIRST EXECUTABLE STATEMENT  CPBCO
  28582.       DO 30 J = 1, N
  28583.          L = MIN(J,M+1)
  28584.          MU = MAX(M+2-J,1)
  28585.          Z(J) = CMPLX(SCASUM(L,ABD(MU,J),1),0.0E0)
  28586.          K = J - L
  28587.          IF (M .LT. MU) GO TO 20
  28588.          DO 10 I = MU, M
  28589.             K = K + 1
  28590.             Z(K) = CMPLX(REAL(Z(K))+CABS1(ABD(I,J)),0.0E0)
  28591.    10    CONTINUE
  28592.    20    CONTINUE
  28593.    30 CONTINUE
  28594.       ANORM = 0.0E0
  28595.       DO 40 J = 1, N
  28596.          ANORM = MAX(ANORM,REAL(Z(J)))
  28597.    40 CONTINUE
  28598. C
  28599. C     FACTOR
  28600. C
  28601.       CALL CPBFA(ABD,LDA,N,M,INFO)
  28602.       IF (INFO .NE. 0) GO TO 180
  28603. C
  28604. C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  28605. C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
  28606. C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  28607. C        GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(R)*W = E .
  28608. C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  28609. C
  28610. C        SOLVE CTRANS(R)*W = E
  28611. C
  28612.          EK = (1.0E0,0.0E0)
  28613.          DO 50 J = 1, N
  28614.             Z(J) = (0.0E0,0.0E0)
  28615.    50    CONTINUE
  28616.          DO 110 K = 1, N
  28617.             IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  28618.             IF (CABS1(EK-Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 60
  28619.                S = REAL(ABD(M+1,K))/CABS1(EK-Z(K))
  28620.                CALL CSSCAL(N,S,Z,1)
  28621.                EK = CMPLX(S,0.0E0)*EK
  28622.    60       CONTINUE
  28623.             WK = EK - Z(K)
  28624.             WKM = -EK - Z(K)
  28625.             S = CABS1(WK)
  28626.             SM = CABS1(WKM)
  28627.             WK = WK/ABD(M+1,K)
  28628.             WKM = WKM/ABD(M+1,K)
  28629.             KP1 = K + 1
  28630.             J2 = MIN(K+M,N)
  28631.             I = M + 1
  28632.             IF (KP1 .GT. J2) GO TO 100
  28633.                DO 70 J = KP1, J2
  28634.                   I = I - 1
  28635.                   SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(I,J)))
  28636.                   Z(J) = Z(J) + WK*CONJG(ABD(I,J))
  28637.                   S = S + CABS1(Z(J))
  28638.    70          CONTINUE
  28639.                IF (S .GE. SM) GO TO 90
  28640.                   T = WKM - WK
  28641.                   WK = WKM
  28642.                   I = M + 1
  28643.                   DO 80 J = KP1, J2
  28644.                      I = I - 1
  28645.                      Z(J) = Z(J) + T*CONJG(ABD(I,J))
  28646.    80             CONTINUE
  28647.    90          CONTINUE
  28648.   100       CONTINUE
  28649.             Z(K) = WK
  28650.   110    CONTINUE
  28651.          S = 1.0E0/SCASUM(N,Z,1)
  28652.          CALL CSSCAL(N,S,Z,1)
  28653. C
  28654. C        SOLVE  R*Y = W
  28655. C
  28656.          DO 130 KB = 1, N
  28657.             K = N + 1 - KB
  28658.             IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 120
  28659.                S = REAL(ABD(M+1,K))/CABS1(Z(K))
  28660.                CALL CSSCAL(N,S,Z,1)
  28661.   120       CONTINUE
  28662.             Z(K) = Z(K)/ABD(M+1,K)
  28663.             LM = MIN(K-1,M)
  28664.             LA = M + 1 - LM
  28665.             LB = K - LM
  28666.             T = -Z(K)
  28667.             CALL CAXPY(LM,T,ABD(LA,K),1,Z(LB),1)
  28668.   130    CONTINUE
  28669.          S = 1.0E0/SCASUM(N,Z,1)
  28670.          CALL CSSCAL(N,S,Z,1)
  28671. C
  28672.          YNORM = 1.0E0
  28673. C
  28674. C        SOLVE CTRANS(R)*V = Y
  28675. C
  28676.          DO 150 K = 1, N
  28677.             LM = MIN(K-1,M)
  28678.             LA = M + 1 - LM
  28679.             LB = K - LM
  28680.             Z(K) = Z(K) - CDOTC(LM,ABD(LA,K),1,Z(LB),1)
  28681.             IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 140
  28682.                S = REAL(ABD(M+1,K))/CABS1(Z(K))
  28683.                CALL CSSCAL(N,S,Z,1)
  28684.                YNORM = S*YNORM
  28685.   140       CONTINUE
  28686.             Z(K) = Z(K)/ABD(M+1,K)
  28687.   150    CONTINUE
  28688.          S = 1.0E0/SCASUM(N,Z,1)
  28689.          CALL CSSCAL(N,S,Z,1)
  28690.          YNORM = S*YNORM
  28691. C
  28692. C        SOLVE  R*Z = W
  28693. C
  28694.          DO 170 KB = 1, N
  28695.             K = N + 1 - KB
  28696.             IF (CABS1(Z(K)) .LE. REAL(ABD(M+1,K))) GO TO 160
  28697.                S = REAL(ABD(M+1,K))/CABS1(Z(K))
  28698.                CALL CSSCAL(N,S,Z,1)
  28699.                YNORM = S*YNORM
  28700.   160       CONTINUE
  28701.             Z(K) = Z(K)/ABD(M+1,K)
  28702.             LM = MIN(K-1,M)
  28703.             LA = M + 1 - LM
  28704.             LB = K - LM
  28705.             T = -Z(K)
  28706.             CALL CAXPY(LM,T,ABD(LA,K),1,Z(LB),1)
  28707.   170    CONTINUE
  28708. C        MAKE ZNORM = 1.0
  28709.          S = 1.0E0/SCASUM(N,Z,1)
  28710.          CALL CSSCAL(N,S,Z,1)
  28711.          YNORM = S*YNORM
  28712. C
  28713.          IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  28714.          IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  28715.   180 CONTINUE
  28716.       RETURN
  28717.       END
  28718. *DECK CPBDI
  28719.       SUBROUTINE CPBDI (ABD, LDA, N, M, DET)
  28720. C***BEGIN PROLOGUE  CPBDI
  28721. C***PURPOSE  Compute the determinant of a complex Hermitian positive
  28722. C            definite band matrix using the factors computed by CPBCO or
  28723. C            CPBFA.
  28724. C***LIBRARY   SLATEC (LINPACK)
  28725. C***CATEGORY  D3D2
  28726. C***TYPE      COMPLEX (SPBDI-S, DPBDI-D, CPBDI-C)
  28727. C***KEYWORDS  BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK,
  28728. C             MATRIX, POSITIVE DEFINITE
  28729. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  28730. C***DESCRIPTION
  28731. C
  28732. C     CPBDI computes the determinant
  28733. C     of a complex Hermitian positive definite band matrix
  28734. C     using the factors computed by CPBCO or CPBFA.
  28735. C     If the inverse is needed, use CPBSL  N  times.
  28736. C
  28737. C     On Entry
  28738. C
  28739. C        ABD     COMPLEX(LDA, N)
  28740. C                the output from CPBCO or CPBFA.
  28741. C
  28742. C        LDA     INTEGER
  28743. C                the leading dimension of the array  ABD .
  28744. C
  28745. C        N       INTEGER
  28746. C                the order of the matrix  A .
  28747. C
  28748. C        M       INTEGER
  28749. C                the number of diagonals above the main diagonal.
  28750. C
  28751. C     On Return
  28752. C
  28753. C        DET     REAL(2)
  28754. C                determinant of original matrix in the form
  28755. C                determinant = DET(1) * 10.0**DET(2)
  28756. C                with  1.0 .LE. DET(1) .LT. 10.0
  28757. C                or  DET(1) .EQ. 0.0 .
  28758. C
  28759. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  28760. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  28761. C***ROUTINES CALLED  (NONE)
  28762. C***REVISION HISTORY  (YYMMDD)
  28763. C   780814  DATE WRITTEN
  28764. C   890831  Modified array declarations.  (WRB)
  28765. C   890831  REVISION DATE from Version 3.2
  28766. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28767. C   900326  Removed duplicate information from DESCRIPTION section.
  28768. C           (WRB)
  28769. C   920501  Reformatted the REFERENCES section.  (WRB)
  28770. C***END PROLOGUE  CPBDI
  28771.       INTEGER LDA,N,M
  28772.       COMPLEX ABD(LDA,*)
  28773.       REAL DET(2)
  28774. C
  28775.       REAL S
  28776.       INTEGER I
  28777. C***FIRST EXECUTABLE STATEMENT  CPBDI
  28778. C
  28779. C     COMPUTE DETERMINANT
  28780. C
  28781.       DET(1) = 1.0E0
  28782.       DET(2) = 0.0E0
  28783.       S = 10.0E0
  28784.       DO 50 I = 1, N
  28785.          DET(1) = REAL(ABD(M+1,I))**2*DET(1)
  28786.          IF (DET(1) .EQ. 0.0E0) GO TO 60
  28787.    10    IF (DET(1) .GE. 1.0E0) GO TO 20
  28788.             DET(1) = S*DET(1)
  28789.             DET(2) = DET(2) - 1.0E0
  28790.          GO TO 10
  28791.    20    CONTINUE
  28792.    30    IF (DET(1) .LT. S) GO TO 40
  28793.             DET(1) = DET(1)/S
  28794.             DET(2) = DET(2) + 1.0E0
  28795.          GO TO 30
  28796.    40    CONTINUE
  28797.    50 CONTINUE
  28798.    60 CONTINUE
  28799.       RETURN
  28800.       END
  28801. *DECK CPBFA
  28802.       SUBROUTINE CPBFA (ABD, LDA, N, M, INFO)
  28803. C***BEGIN PROLOGUE  CPBFA
  28804. C***PURPOSE  Factor a complex Hermitian positive definite matrix stored
  28805. C            in band form.
  28806. C***LIBRARY   SLATEC (LINPACK)
  28807. C***CATEGORY  D2D2
  28808. C***TYPE      COMPLEX (SPBFA-S, DPBFA-D, CPBFA-C)
  28809. C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
  28810. C             POSITIVE DEFINITE
  28811. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  28812. C***DESCRIPTION
  28813. C
  28814. C     CPBFA factors a complex Hermitian positive definite matrix
  28815. C     stored in band form.
  28816. C
  28817. C     CPBFA is usually called by CPBCO, but it can be called
  28818. C     directly with a saving in time if  RCOND  is not needed.
  28819. C
  28820. C     On Entry
  28821. C
  28822. C        ABD     COMPLEX(LDA, N)
  28823. C                the matrix to be factored.  The columns of the upper
  28824. C                triangle are stored in the columns of ABD and the
  28825. C                diagonals of the upper triangle are stored in the
  28826. C                rows of ABD .  See the comments below for details.
  28827. C
  28828. C        LDA     INTEGER
  28829. C                the leading dimension of the array  ABD .
  28830. C                LDA must be .GE. M + 1 .
  28831. C
  28832. C        N       INTEGER
  28833. C                the order of the matrix  A .
  28834. C
  28835. C        M       INTEGER
  28836. C                the number of diagonals above the main diagonal.
  28837. C                0 .LE. M .LT. N .
  28838. C
  28839. C     On Return
  28840. C
  28841. C        ABD     an upper triangular matrix  R , stored in band
  28842. C                form, so that  A = CTRANS(R)*R .
  28843. C
  28844. C        INFO    INTEGER
  28845. C                = 0  for normal return.
  28846. C                = K  if the leading minor of order  K  is not
  28847. C                     positive definite.
  28848. C
  28849. C     Band Storage
  28850. C
  28851. C           If  A  is a Hermitian positive definite band matrix,
  28852. C           the following program segment will set up the input.
  28853. C
  28854. C                   M = (band width above diagonal)
  28855. C                   DO 20 J = 1, N
  28856. C                      I1 = MAX(1, J-M)
  28857. C                      DO 10 I = I1, J
  28858. C                         K = I-J+M+1
  28859. C                         ABD(K,J) = A(I,J)
  28860. C                10    CONTINUE
  28861. C                20 CONTINUE
  28862. C
  28863. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  28864. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  28865. C***ROUTINES CALLED  CDOTC
  28866. C***REVISION HISTORY  (YYMMDD)
  28867. C   780814  DATE WRITTEN
  28868. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28869. C   890831  Modified array declarations.  (WRB)
  28870. C   890831  REVISION DATE from Version 3.2
  28871. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28872. C   900326  Removed duplicate information from DESCRIPTION section.
  28873. C           (WRB)
  28874. C   920501  Reformatted the REFERENCES section.  (WRB)
  28875. C***END PROLOGUE  CPBFA
  28876.       INTEGER LDA,N,M,INFO
  28877.       COMPLEX ABD(LDA,*)
  28878. C
  28879.       COMPLEX CDOTC,T
  28880.       REAL S
  28881.       INTEGER IK,J,JK,K,MU
  28882. C***FIRST EXECUTABLE STATEMENT  CPBFA
  28883.          DO 30 J = 1, N
  28884.             INFO = J
  28885.             S = 0.0E0
  28886.             IK = M + 1
  28887.             JK = MAX(J-M,1)
  28888.             MU = MAX(M+2-J,1)
  28889.             IF (M .LT. MU) GO TO 20
  28890.             DO 10 K = MU, M
  28891.                T = ABD(K,J) - CDOTC(K-MU,ABD(IK,JK),1,ABD(MU,J),1)
  28892.                T = T/ABD(M+1,JK)
  28893.                ABD(K,J) = T
  28894.                S = S + REAL(T*CONJG(T))
  28895.                IK = IK - 1
  28896.                JK = JK + 1
  28897.    10       CONTINUE
  28898.    20       CONTINUE
  28899.             S = REAL(ABD(M+1,J)) - S
  28900.             IF (S .LE. 0.0E0 .OR. AIMAG(ABD(M+1,J)) .NE. 0.0E0)
  28901.      1         GO TO 40
  28902.             ABD(M+1,J) = CMPLX(SQRT(S),0.0E0)
  28903.    30    CONTINUE
  28904.          INFO = 0
  28905.    40 CONTINUE
  28906.       RETURN
  28907.       END
  28908. *DECK CPBSL
  28909.       SUBROUTINE CPBSL (ABD, LDA, N, M, B)
  28910. C***BEGIN PROLOGUE  CPBSL
  28911. C***PURPOSE  Solve the complex Hermitian positive definite band system
  28912. C            using the factors computed by CPBCO or CPBFA.
  28913. C***LIBRARY   SLATEC (LINPACK)
  28914. C***CATEGORY  D2D2
  28915. C***TYPE      COMPLEX (SPBSL-S, DPBSL-D, CPBSL-C)
  28916. C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX,
  28917. C             POSITIVE DEFINITE, SOLVE
  28918. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  28919. C***DESCRIPTION
  28920. C
  28921. C     CPBSL solves the complex Hermitian positive definite band
  28922. C     system  A*X = B
  28923. C     using the factors computed by CPBCO or CPBFA.
  28924. C
  28925. C     On Entry
  28926. C
  28927. C        ABD     COMPLEX(LDA, N)
  28928. C                the output from CPBCO or CPBFA.
  28929. C
  28930. C        LDA     INTEGER
  28931. C                the leading dimension of the array  ABD .
  28932. C
  28933. C        N       INTEGER
  28934. C                the order of the matrix  A .
  28935. C
  28936. C        M       INTEGER
  28937. C                the number of diagonals above the main diagonal.
  28938. C
  28939. C        B       COMPLEX(N)
  28940. C                the right hand side vector.
  28941. C
  28942. C     On Return
  28943. C
  28944. C        B       the solution vector  X .
  28945. C
  28946. C     Error Condition
  28947. C
  28948. C        A division by zero will occur if the input factor contains
  28949. C        a zero on the diagonal.  Technically this indicates
  28950. C        singularity but it is usually caused by improper subroutine
  28951. C        arguments.  It will not occur if the subroutines are called
  28952. C        correctly and  INFO .EQ. 0 .
  28953. C
  28954. C     To compute  INVERSE(A) * C  where  C  is a matrix
  28955. C     with  P  columns
  28956. C           CALL CPBCO(ABD,LDA,N,RCOND,Z,INFO)
  28957. C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
  28958. C           DO 10 J = 1, P
  28959. C              CALL CPBSL(ABD,LDA,N,C(1,J))
  28960. C        10 CONTINUE
  28961. C
  28962. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  28963. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  28964. C***ROUTINES CALLED  CAXPY, CDOTC
  28965. C***REVISION HISTORY  (YYMMDD)
  28966. C   780814  DATE WRITTEN
  28967. C   890531  Changed all specific intrinsics to generic.  (WRB)
  28968. C   890831  Modified array declarations.  (WRB)
  28969. C   890831  REVISION DATE from Version 3.2
  28970. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  28971. C   900326  Removed duplicate information from DESCRIPTION section.
  28972. C           (WRB)
  28973. C   920501  Reformatted the REFERENCES section.  (WRB)
  28974. C***END PROLOGUE  CPBSL
  28975.       INTEGER LDA,N,M
  28976.       COMPLEX ABD(LDA,*),B(*)
  28977. C
  28978.       COMPLEX CDOTC,T
  28979.       INTEGER K,KB,LA,LB,LM
  28980. C
  28981. C     SOLVE CTRANS(R)*Y = B
  28982. C
  28983. C***FIRST EXECUTABLE STATEMENT  CPBSL
  28984.       DO 10 K = 1, N
  28985.          LM = MIN(K-1,M)
  28986.          LA = M + 1 - LM
  28987.          LB = K - LM
  28988.          T = CDOTC(LM,ABD(LA,K),1,B(LB),1)
  28989.          B(K) = (B(K) - T)/ABD(M+1,K)
  28990.    10 CONTINUE
  28991. C
  28992. C     SOLVE R*X = Y
  28993. C
  28994.       DO 20 KB = 1, N
  28995.          K = N + 1 - KB
  28996.          LM = MIN(K-1,M)
  28997.          LA = M + 1 - LM
  28998.          LB = K - LM
  28999.          B(K) = B(K)/ABD(M+1,K)
  29000.          T = -B(K)
  29001.          CALL CAXPY(LM,T,ABD(LA,K),1,B(LB),1)
  29002.    20 CONTINUE
  29003.       RETURN
  29004.       END
  29005. *DECK CPEVL
  29006.       SUBROUTINE CPEVL (N, M, A, Z, C, B, KBD)
  29007. C***BEGIN PROLOGUE  CPEVL
  29008. C***SUBSIDIARY
  29009. C***PURPOSE  Subsidiary to CPZERO
  29010. C***LIBRARY   SLATEC
  29011. C***TYPE      SINGLE PRECISION (CPEVL-S)
  29012. C***AUTHOR  (UNKNOWN)
  29013. C***DESCRIPTION
  29014. C
  29015. C        Evaluate a complex polynomial and its derivatives.
  29016. C        Optionally compute error bounds for these values.
  29017. C
  29018. C   INPUT...
  29019. C        N = Degree of the polynomial
  29020. C        M = Number of derivatives to be calculated,
  29021. C            M=0 evaluates only the function
  29022. C            M=1 evaluates the function and first derivative, etc.
  29023. C             if M .GT. N+1 function and all N derivatives will be
  29024. C                calculated.
  29025. C       A = Complex vector containing the N+1 coefficients of polynomial
  29026. C               A(I)= coefficient of Z**(N+1-I)
  29027. C        Z = Complex point at which the evaluation is to take place.
  29028. C        C = Array of 2(M+1) words into which values are placed.
  29029. C        B = Array of 2(M+1) words only needed if bounds are to be
  29030. C              calculated.  It is not used otherwise.
  29031. C        KBD = A logical variable, e.g. .TRUE. or .FALSE. which is
  29032. C              to be set .TRUE. if bounds are to be computed.
  29033. C
  29034. C  OUTPUT...
  29035. C        C =  C(I+1) contains the complex value of the I-th
  29036. C              derivative at Z, I=0,...,M
  29037. C        B =  B(I) contains the bounds on the real and imaginary parts
  29038. C              of C(I) if they were requested.
  29039. C
  29040. C***SEE ALSO  CPZERO
  29041. C***ROUTINES CALLED  I1MACH
  29042. C***REVISION HISTORY  (YYMMDD)
  29043. C   810223  DATE WRITTEN
  29044. C   890531  Changed all specific intrinsics to generic.  (WRB)
  29045. C   890831  Modified array declarations.  (WRB)
  29046. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29047. C   900402  Added TYPE section.  (WRB)
  29048. C***END PROLOGUE  CPEVL
  29049. C
  29050.       COMPLEX A(*),C(*),Z,CI,CIM1,B(*),BI,BIM1,T,ZA,Q
  29051.       LOGICAL KBD
  29052.       SAVE D1
  29053.       DATA D1 /0.0/
  29054.       ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q)))
  29055. C***FIRST EXECUTABLE STATEMENT  CPEVL
  29056.       IF (D1 .EQ. 0.0) D1 = REAL(I1MACH(10))**(1-I1MACH(11))
  29057.       NP1=N+1
  29058.       DO 1 J=1,NP1
  29059.          CI=0.0
  29060.          CIM1=A(J)
  29061.          BI=0.0
  29062.          BIM1=0.0
  29063.          MINI=MIN(M+1,N+2-J)
  29064.             DO 1 I=1,MINI
  29065.                IF(J .NE. 1) CI=C(I)
  29066.                IF(I .NE. 1) CIM1=C(I-1)
  29067.                C(I)=CIM1+Z*CI
  29068.                IF(.NOT. KBD) GO TO 1
  29069.                IF(J .NE. 1) BI=B(I)
  29070.                IF(I .NE. 1) BIM1=B(I-1)
  29071.                T=BI+(3.*D1+4.*D1*D1)*ZA(CI)
  29072.                R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T)))
  29073.                S=AIMAG(ZA(Z)*T)
  29074.                B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S))
  29075.                IF(J .EQ. 1) B(I)=0.0
  29076.     1 CONTINUE
  29077.       RETURN
  29078.       END
  29079. *DECK CPEVLR
  29080.       SUBROUTINE CPEVLR (N, M, A, X, C)
  29081. C***BEGIN PROLOGUE  CPEVLR
  29082. C***SUBSIDIARY
  29083. C***PURPOSE  Subsidiary to CPZERO
  29084. C***LIBRARY   SLATEC
  29085. C***TYPE      SINGLE PRECISION (CPEVLR-S)
  29086. C***AUTHOR  (UNKNOWN)
  29087. C***SEE ALSO  CPZERO
  29088. C***ROUTINES CALLED  (NONE)
  29089. C***REVISION HISTORY  (YYMMDD)
  29090. C   810223  DATE WRITTEN
  29091. C   890531  Changed all specific intrinsics to generic.  (WRB)
  29092. C   890831  Modified array declarations.  (WRB)
  29093. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29094. C   900402  Added TYPE section.  (WRB)
  29095. C***END PROLOGUE  CPEVLR
  29096.       REAL A(*),C(*)
  29097. C***FIRST EXECUTABLE STATEMENT  CPEVLR
  29098.       NP1=N+1
  29099.       DO 1 J=1,NP1
  29100.             CI=0.0
  29101.             CIM1=A(J)
  29102.             MINI=MIN(M+1,N+2-J)
  29103.             DO 1 I=1,MINI
  29104.                IF(J .NE. 1) CI=C(I)
  29105.                IF(I .NE. 1) CIM1=C(I-1)
  29106.                C(I)=CIM1+X*CI
  29107.     1 CONTINUE
  29108.       RETURN
  29109.       END
  29110. *DECK CPOCO
  29111.       SUBROUTINE CPOCO (A, LDA, N, RCOND, Z, INFO)
  29112. C***BEGIN PROLOGUE  CPOCO
  29113. C***PURPOSE  Factor a complex Hermitian positive definite matrix
  29114. C            and estimate the condition number of the matrix.
  29115. C***LIBRARY   SLATEC (LINPACK)
  29116. C***CATEGORY  D2D1B
  29117. C***TYPE      COMPLEX (SPOCO-S, DPOCO-D, CPOCO-C)
  29118. C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
  29119. C             MATRIX FACTORIZATION, POSITIVE DEFINITE
  29120. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  29121. C***DESCRIPTION
  29122. C
  29123. C     CPOCO factors a complex Hermitian positive definite matrix
  29124. C     and estimates the condition of the matrix.
  29125. C
  29126. C     If  RCOND  is not needed, CPOFA is slightly faster.
  29127. C     To solve  A*X = B , follow CPOCO by CPOSL.
  29128. C     To compute  INVERSE(A)*C , follow CPOCO by CPOSL.
  29129. C     To compute  DETERMINANT(A) , follow CPOCO by CPODI.
  29130. C     To compute  INVERSE(A) , follow CPOCO by CPODI.
  29131. C
  29132. C     On Entry
  29133. C
  29134. C        A       COMPLEX(LDA, N)
  29135. C                the Hermitian matrix to be factored.  Only the
  29136. C                diagonal and upper triangle are used.
  29137. C
  29138. C        LDA     INTEGER
  29139. C                the leading dimension of the array  A .
  29140. C
  29141. C        N       INTEGER
  29142. C                the order of the matrix  A .
  29143. C
  29144. C     On Return
  29145. C
  29146. C        A       an upper triangular matrix  R  so that  A =
  29147. C                CTRANS(R)*R where  CTRANS(R)  is the conjugate
  29148. C                transpose.  The strict lower triangle is unaltered.
  29149. C                If  INFO .NE. 0 , the factorization is not complete.
  29150. C
  29151. C        RCOND   REAL
  29152. C                an estimate of the reciprocal condition of  A .
  29153. C                For the system  A*X = B , relative perturbations
  29154. C                in  A  and  B  of size  EPSILON  may cause
  29155. C                relative perturbations in  X  of size  EPSILON/RCOND .
  29156. C                If  RCOND  is so small that the logical expression
  29157. C                           1.0 + RCOND .EQ. 1.0
  29158. C                is true, then  A  may be singular to working
  29159. C                precision.  In particular,  RCOND  is zero  if
  29160. C                exact singularity is detected or the estimate
  29161. C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
  29162. C
  29163. C        Z       COMPLEX(N)
  29164. C                a work vector whose contents are usually unimportant.
  29165. C                If  A  is close to a singular matrix, then  Z  is
  29166. C                an approximate null vector in the sense that
  29167. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  29168. C                If  INFO .NE. 0 , Z  is unchanged.
  29169. C
  29170. C        INFO    INTEGER
  29171. C                = 0  for normal return.
  29172. C                = K  signals an error condition.  The leading minor
  29173. C                     of order  K  is not positive definite.
  29174. C
  29175. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29176. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29177. C***ROUTINES CALLED  CAXPY, CDOTC, CPOFA, CSSCAL, SCASUM
  29178. C***REVISION HISTORY  (YYMMDD)
  29179. C   780814  DATE WRITTEN
  29180. C   890531  Changed all specific intrinsics to generic.  (WRB)
  29181. C   890831  Modified array declarations.  (WRB)
  29182. C   890831  REVISION DATE from Version 3.2
  29183. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29184. C   900326  Removed duplicate information from DESCRIPTION section.
  29185. C           (WRB)
  29186. C   920501  Reformatted the REFERENCES section.  (WRB)
  29187. C***END PROLOGUE  CPOCO
  29188.       INTEGER LDA,N,INFO
  29189.       COMPLEX A(LDA,*),Z(*)
  29190.       REAL RCOND
  29191. C
  29192.       COMPLEX CDOTC,EK,T,WK,WKM
  29193.       REAL ANORM,S,SCASUM,SM,YNORM
  29194.       INTEGER I,J,JM1,K,KB,KP1
  29195.       COMPLEX ZDUM,ZDUM2,CSIGN1
  29196.       REAL CABS1
  29197.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  29198.       CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2))
  29199. C
  29200. C     FIND NORM OF A USING ONLY UPPER HALF
  29201. C
  29202. C***FIRST EXECUTABLE STATEMENT  CPOCO
  29203.       DO 30 J = 1, N
  29204.          Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0)
  29205.          JM1 = J - 1
  29206.          IF (JM1 .LT. 1) GO TO 20
  29207.          DO 10 I = 1, JM1
  29208.             Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0)
  29209.    10    CONTINUE
  29210.    20    CONTINUE
  29211.    30 CONTINUE
  29212.       ANORM = 0.0E0
  29213.       DO 40 J = 1, N
  29214.          ANORM = MAX(ANORM,REAL(Z(J)))
  29215.    40 CONTINUE
  29216. C
  29217. C     FACTOR
  29218. C
  29219.       CALL CPOFA(A,LDA,N,INFO)
  29220.       IF (INFO .NE. 0) GO TO 180
  29221. C
  29222. C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  29223. C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
  29224. C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  29225. C        GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(R)*W = E .
  29226. C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  29227. C
  29228. C        SOLVE CTRANS(R)*W = E
  29229. C
  29230.          EK = (1.0E0,0.0E0)
  29231.          DO 50 J = 1, N
  29232.             Z(J) = (0.0E0,0.0E0)
  29233.    50    CONTINUE
  29234.          DO 110 K = 1, N
  29235.             IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  29236.             IF (CABS1(EK-Z(K)) .LE. REAL(A(K,K))) GO TO 60
  29237.                S = REAL(A(K,K))/CABS1(EK-Z(K))
  29238.                CALL CSSCAL(N,S,Z,1)
  29239.                EK = CMPLX(S,0.0E0)*EK
  29240.    60       CONTINUE
  29241.             WK = EK - Z(K)
  29242.             WKM = -EK - Z(K)
  29243.             S = CABS1(WK)
  29244.             SM = CABS1(WKM)
  29245.             WK = WK/A(K,K)
  29246.             WKM = WKM/A(K,K)
  29247.             KP1 = K + 1
  29248.             IF (KP1 .GT. N) GO TO 100
  29249.                DO 70 J = KP1, N
  29250.                   SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J)))
  29251.                   Z(J) = Z(J) + WK*CONJG(A(K,J))
  29252.                   S = S + CABS1(Z(J))
  29253.    70          CONTINUE
  29254.                IF (S .GE. SM) GO TO 90
  29255.                   T = WKM - WK
  29256.                   WK = WKM
  29257.                   DO 80 J = KP1, N
  29258.                      Z(J) = Z(J) + T*CONJG(A(K,J))
  29259.    80             CONTINUE
  29260.    90          CONTINUE
  29261.   100       CONTINUE
  29262.             Z(K) = WK
  29263.   110    CONTINUE
  29264.          S = 1.0E0/SCASUM(N,Z,1)
  29265.          CALL CSSCAL(N,S,Z,1)
  29266. C
  29267. C        SOLVE R*Y = W
  29268. C
  29269.          DO 130 KB = 1, N
  29270.             K = N + 1 - KB
  29271.             IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 120
  29272.                S = REAL(A(K,K))/CABS1(Z(K))
  29273.                CALL CSSCAL(N,S,Z,1)
  29274.   120       CONTINUE
  29275.             Z(K) = Z(K)/A(K,K)
  29276.             T = -Z(K)
  29277.             CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  29278.   130    CONTINUE
  29279.          S = 1.0E0/SCASUM(N,Z,1)
  29280.          CALL CSSCAL(N,S,Z,1)
  29281. C
  29282.          YNORM = 1.0E0
  29283. C
  29284. C        SOLVE CTRANS(R)*V = Y
  29285. C
  29286.          DO 150 K = 1, N
  29287.             Z(K) = Z(K) - CDOTC(K-1,A(1,K),1,Z(1),1)
  29288.             IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 140
  29289.                S = REAL(A(K,K))/CABS1(Z(K))
  29290.                CALL CSSCAL(N,S,Z,1)
  29291.                YNORM = S*YNORM
  29292.   140       CONTINUE
  29293.             Z(K) = Z(K)/A(K,K)
  29294.   150    CONTINUE
  29295.          S = 1.0E0/SCASUM(N,Z,1)
  29296.          CALL CSSCAL(N,S,Z,1)
  29297.          YNORM = S*YNORM
  29298. C
  29299. C        SOLVE R*Z = V
  29300. C
  29301.          DO 170 KB = 1, N
  29302.             K = N + 1 - KB
  29303.             IF (CABS1(Z(K)) .LE. REAL(A(K,K))) GO TO 160
  29304.                S = REAL(A(K,K))/CABS1(Z(K))
  29305.                CALL CSSCAL(N,S,Z,1)
  29306.                YNORM = S*YNORM
  29307.   160       CONTINUE
  29308.             Z(K) = Z(K)/A(K,K)
  29309.             T = -Z(K)
  29310.             CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  29311.   170    CONTINUE
  29312. C        MAKE ZNORM = 1.0
  29313.          S = 1.0E0/SCASUM(N,Z,1)
  29314.          CALL CSSCAL(N,S,Z,1)
  29315.          YNORM = S*YNORM
  29316. C
  29317.          IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  29318.          IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  29319.   180 CONTINUE
  29320.       RETURN
  29321.       END
  29322. *DECK CPODI
  29323.       SUBROUTINE CPODI (A, LDA, N, DET, JOB)
  29324. C***BEGIN PROLOGUE  CPODI
  29325. C***PURPOSE  Compute the determinant and inverse of a certain complex
  29326. C            Hermitian positive definite matrix using the factors
  29327. C            computed by CPOCO, CPOFA, or CQRDC.
  29328. C***LIBRARY   SLATEC (LINPACK)
  29329. C***CATEGORY  D2D1B, D3D1B
  29330. C***TYPE      COMPLEX (SPODI-S, DPODI-D, CPODI-C)
  29331. C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
  29332. C             POSITIVE DEFINITE
  29333. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  29334. C***DESCRIPTION
  29335. C
  29336. C     CPODI computes the determinant and inverse of a certain
  29337. C     complex Hermitian positive definite matrix (see below)
  29338. C     using the factors computed by CPOCO, CPOFA or CQRDC.
  29339. C
  29340. C     On Entry
  29341. C
  29342. C        A       COMPLEX(LDA, N)
  29343. C                the output  A  from CPOCO or CPOFA
  29344. C                or the output  X  from CQRDC.
  29345. C
  29346. C        LDA     INTEGER
  29347. C                the leading dimension of the array  A .
  29348. C
  29349. C        N       INTEGER
  29350. C                the order of the matrix  A .
  29351. C
  29352. C        JOB     INTEGER
  29353. C                = 11   both determinant and inverse.
  29354. C                = 01   inverse only.
  29355. C                = 10   determinant only.
  29356. C
  29357. C     On Return
  29358. C
  29359. C        A       If CPOCO or CPOFA was used to factor  A  then
  29360. C                CPODI produces the upper half of INVERSE(A) .
  29361. C                If CQRDC was used to decompose  X  then
  29362. C                CPODI produces the upper half of INVERSE(CTRANS(X)*X)
  29363. C                where CTRANS(X) is the conjugate transpose.
  29364. C                Elements of  A  below the diagonal are unchanged.
  29365. C                If the units digit of JOB is zero,  A  is unchanged.
  29366. C
  29367. C        DET     REAL(2)
  29368. C                determinant of  A  or of  CTRANS(X)*X  if requested.
  29369. C                Otherwise not referenced.
  29370. C                Determinant = DET(1) * 10.0**DET(2)
  29371. C                with  1.0 .LE. DET(1) .LT. 10.0
  29372. C                or  DET(1) .EQ. 0.0 .
  29373. C
  29374. C     Error Condition
  29375. C
  29376. C        a division by zero will occur if the input factor contains
  29377. C        a zero on the diagonal and the inverse is requested.
  29378. C        It will not occur if the subroutines are called correctly
  29379. C        and if CPOCO or CPOFA has set INFO .EQ. 0 .
  29380. C
  29381. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29382. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29383. C***ROUTINES CALLED  CAXPY, CSCAL
  29384. C***REVISION HISTORY  (YYMMDD)
  29385. C   780814  DATE WRITTEN
  29386. C   890831  Modified array declarations.  (WRB)
  29387. C   890831  REVISION DATE from Version 3.2
  29388. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29389. C   900326  Removed duplicate information from DESCRIPTION section.
  29390. C           (WRB)
  29391. C   920501  Reformatted the REFERENCES section.  (WRB)
  29392. C***END PROLOGUE  CPODI
  29393.       INTEGER LDA,N,JOB
  29394.       COMPLEX A(LDA,*)
  29395.       REAL DET(2)
  29396. C
  29397.       COMPLEX T
  29398.       REAL S
  29399.       INTEGER I,J,JM1,K,KP1
  29400. C***FIRST EXECUTABLE STATEMENT  CPODI
  29401. C
  29402. C     COMPUTE DETERMINANT
  29403. C
  29404.       IF (JOB/10 .EQ. 0) GO TO 70
  29405.          DET(1) = 1.0E0
  29406.          DET(2) = 0.0E0
  29407.          S = 10.0E0
  29408.          DO 50 I = 1, N
  29409.             DET(1) = REAL(A(I,I))**2*DET(1)
  29410.             IF (DET(1) .EQ. 0.0E0) GO TO 60
  29411.    10       IF (DET(1) .GE. 1.0E0) GO TO 20
  29412.                DET(1) = S*DET(1)
  29413.                DET(2) = DET(2) - 1.0E0
  29414.             GO TO 10
  29415.    20       CONTINUE
  29416.    30       IF (DET(1) .LT. S) GO TO 40
  29417.                DET(1) = DET(1)/S
  29418.                DET(2) = DET(2) + 1.0E0
  29419.             GO TO 30
  29420.    40       CONTINUE
  29421.    50    CONTINUE
  29422.    60    CONTINUE
  29423.    70 CONTINUE
  29424. C
  29425. C     COMPUTE INVERSE(R)
  29426. C
  29427.       IF (MOD(JOB,10) .EQ. 0) GO TO 140
  29428.          DO 100 K = 1, N
  29429.             A(K,K) = (1.0E0,0.0E0)/A(K,K)
  29430.             T = -A(K,K)
  29431.             CALL CSCAL(K-1,T,A(1,K),1)
  29432.             KP1 = K + 1
  29433.             IF (N .LT. KP1) GO TO 90
  29434.             DO 80 J = KP1, N
  29435.                T = A(K,J)
  29436.                A(K,J) = (0.0E0,0.0E0)
  29437.                CALL CAXPY(K,T,A(1,K),1,A(1,J),1)
  29438.    80       CONTINUE
  29439.    90       CONTINUE
  29440.   100    CONTINUE
  29441. C
  29442. C        FORM  INVERSE(R) * CTRANS(INVERSE(R))
  29443. C
  29444.          DO 130 J = 1, N
  29445.             JM1 = J - 1
  29446.             IF (JM1 .LT. 1) GO TO 120
  29447.             DO 110 K = 1, JM1
  29448.                T = CONJG(A(K,J))
  29449.                CALL CAXPY(K,T,A(1,J),1,A(1,K),1)
  29450.   110       CONTINUE
  29451.   120       CONTINUE
  29452.             T = CONJG(A(J,J))
  29453.             CALL CSCAL(J,T,A(1,J),1)
  29454.   130    CONTINUE
  29455.   140 CONTINUE
  29456.       RETURN
  29457.       END
  29458. *DECK CPOFA
  29459.       SUBROUTINE CPOFA (A, LDA, N, INFO)
  29460. C***BEGIN PROLOGUE  CPOFA
  29461. C***PURPOSE  Factor a complex Hermitian positive definite matrix.
  29462. C***LIBRARY   SLATEC (LINPACK)
  29463. C***CATEGORY  D2D1B
  29464. C***TYPE      COMPLEX (SPOFA-S, DPOFA-D, CPOFA-C)
  29465. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
  29466. C             POSITIVE DEFINITE
  29467. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  29468. C***DESCRIPTION
  29469. C
  29470. C     CPOFA factors a complex Hermitian positive definite matrix.
  29471. C
  29472. C     CPOFA is usually called by CPOCO, but it can be called
  29473. C     directly with a saving in time if  RCOND  is not needed.
  29474. C     (Time for CPOCO) = (1 + 18/N)*(Time for CPOFA) .
  29475. C
  29476. C     On Entry
  29477. C
  29478. C        A       COMPLEX(LDA, N)
  29479. C                the Hermitian matrix to be factored.  Only the
  29480. C                diagonal and upper triangle are used.
  29481. C
  29482. C        LDA     INTEGER
  29483. C                the leading dimension of the array  A .
  29484. C
  29485. C        N       INTEGER
  29486. C                the order of the matrix  A .
  29487. C
  29488. C     On Return
  29489. C
  29490. C        A       an upper triangular matrix  R  so that  A =
  29491. C                CTRANS(R)*R where  CTRANS(R)  is the conjugate
  29492. C                transpose.  The strict lower triangle is unaltered.
  29493. C                If  INFO .NE. 0 , the factorization is not complete.
  29494. C
  29495. C        INFO    INTEGER
  29496. C                = 0  for normal return.
  29497. C                = K  signals an error condition.  The leading minor
  29498. C                     of order  K  is not positive definite.
  29499. C
  29500. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29501. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29502. C***ROUTINES CALLED  CDOTC
  29503. C***REVISION HISTORY  (YYMMDD)
  29504. C   780814  DATE WRITTEN
  29505. C   890831  Modified array declarations.  (WRB)
  29506. C   890831  REVISION DATE from Version 3.2
  29507. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29508. C   900326  Removed duplicate information from DESCRIPTION section.
  29509. C           (WRB)
  29510. C   920501  Reformatted the REFERENCES section.  (WRB)
  29511. C***END PROLOGUE  CPOFA
  29512.       INTEGER LDA,N,INFO
  29513.       COMPLEX A(LDA,*)
  29514. C
  29515.       COMPLEX CDOTC,T
  29516.       REAL S
  29517.       INTEGER J,JM1,K
  29518. C***FIRST EXECUTABLE STATEMENT  CPOFA
  29519.          DO 30 J = 1, N
  29520.             INFO = J
  29521.             S = 0.0E0
  29522.             JM1 = J - 1
  29523.             IF (JM1 .LT. 1) GO TO 20
  29524.             DO 10 K = 1, JM1
  29525.                T = A(K,J) - CDOTC(K-1,A(1,K),1,A(1,J),1)
  29526.                T = T/A(K,K)
  29527.                A(K,J) = T
  29528.                S = S + REAL(T*CONJG(T))
  29529.    10       CONTINUE
  29530.    20       CONTINUE
  29531.             S = REAL(A(J,J)) - S
  29532.             IF (S .LE. 0.0E0 .OR. AIMAG(A(J,J)) .NE. 0.0E0) GO TO 40
  29533.             A(J,J) = CMPLX(SQRT(S),0.0E0)
  29534.    30    CONTINUE
  29535.          INFO = 0
  29536.    40 CONTINUE
  29537.       RETURN
  29538.       END
  29539. *DECK CPOFS
  29540.       SUBROUTINE CPOFS (A, LDA, N, V, ITASK, IND, WORK)
  29541. C***BEGIN PROLOGUE  CPOFS
  29542. C***PURPOSE  Solve a positive definite symmetric complex system of
  29543. C            linear equations.
  29544. C***LIBRARY   SLATEC
  29545. C***CATEGORY  D2D1B
  29546. C***TYPE      COMPLEX (SPOFS-S, DPOFS-D, CPOFS-C)
  29547. C***KEYWORDS  HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC
  29548. C***AUTHOR  Voorhees, E. A., (LANL)
  29549. C***DESCRIPTION
  29550. C
  29551. C    Subroutine CPOFS solves a  positive definite symmetric
  29552. C    NxN system of complex linear equations using LINPACK
  29553. C    subroutines CPOCO and CPOSL.  That is, if A is an NxN
  29554. C    complex positive definite symmetric matrix and if X and B
  29555. C    are complex N-vectors, then CPOFS solves the equation
  29556. C
  29557. C                          A*X=B.
  29558. C
  29559. C    Care should be taken not to use CPOFS with a non-Hermitian
  29560. C    matrix.
  29561. C
  29562. C    The matrix A is first factored into upper and lower tri-
  29563. C    angular matrices R and R-TRANSPOSE.  These factors are used to
  29564. C    find the solution vector X.  An approximate condition number is
  29565. C    calculated to provide a rough estimate of the number of
  29566. C    digits of accuracy in the computed solution.
  29567. C
  29568. C    If the equation A*X=B is to be solved for more than one vector
  29569. C    B, the factoring of a does not need to be performed again and
  29570. C    the option to only solve (ITASK .GT. 1) will be faster for
  29571. C    the succeeding solutions.  In this case, the contents of A,
  29572. C    LDA, and N must not have been altered by the user following
  29573. C    factorization (ITASK=1).  IND will not be changed by CPOFS
  29574. C    in this case.
  29575. C
  29576. C  Argument Description ***
  29577. C
  29578. C    A      COMPLEX(LDA,N)
  29579. C             on entry, the doubly subscripted array with dimension
  29580. C               (LDA,N) which contains the coefficient matrix.  Only
  29581. C               the upper triangle, including the diagonal, of the
  29582. C               coefficient matrix need be entered and will subse-
  29583. C               quently be referenced and changed by the routine.
  29584. C             on return, contains in its upper triangle an upper
  29585. C               triangular matrix R such that  A = (R-TRANSPOSE) * R .
  29586. C    LDA    INTEGER
  29587. C             the leading dimension of the array A.  LDA must be great-
  29588. C             er than or equal to N.  (terminal error message IND=-1)
  29589. C    N      INTEGER
  29590. C             the order of the matrix A.  N must be greater
  29591. C             than or equal to 1.  (terminal error message IND=-2)
  29592. C    V      COMPLEX(N)
  29593. C             on entry the singly subscripted array(vector) of di-
  29594. C               mension N which contains the right hand side B of a
  29595. C               system of simultaneous linear equations A*X=B.
  29596. C             on return, V contains the solution vector, X .
  29597. C    ITASK  INTEGER
  29598. C             if ITASK = 1, the matrix A is factored and then the
  29599. C               linear equation is solved.
  29600. C             if ITASK .GT. 1, the equation is solved using the existing
  29601. C               factored matrix A.
  29602. C             if ITASK .LT. 1, then terminal error message IND=-3 is
  29603. C               printed.
  29604. C    IND    INTEGER
  29605. C             GT. 0  IND is a rough estimate of the number of digits
  29606. C                     of accuracy in the solution, X.
  29607. C             LT. 0  see error message corresponding to IND below.
  29608. C    WORK   COMPLEX(N)
  29609. C             a singly subscripted array of dimension at least N.
  29610. C
  29611. C  Error Messages Printed ***
  29612. C
  29613. C    IND=-1  terminal   N is greater than LDA.
  29614. C    IND=-2  terminal   N is less than 1.
  29615. C    IND=-3  terminal   ITASK is less than 1.
  29616. C    IND=-4  terminal   The matrix A is computationally singular or
  29617. C                         is not positive definite.  A solution
  29618. C                         has not been computed.
  29619. C    IND=-10 warning    The solution has no apparent significance.
  29620. C                         The solution may be inaccurate or the
  29621. C                         matrix A may be poorly scaled.
  29622. C
  29623. C               NOTE-  The above terminal(*fatal*) error messages are
  29624. C                      designed to be handled by XERMSG in which
  29625. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  29626. C                      for warning error messages from XERMSG.  Unless
  29627. C                      the user provides otherwise, an error message
  29628. C                      will be printed followed by an abort.
  29629. C
  29630. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29631. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29632. C***ROUTINES CALLED  CPOCO, CPOSL, R1MACH, XERMSG
  29633. C***REVISION HISTORY  (YYMMDD)
  29634. C   800516  DATE WRITTEN
  29635. C   890531  Changed all specific intrinsics to generic.  (WRB)
  29636. C   890831  Modified array declarations.  (WRB)
  29637. C   890831  REVISION DATE from Version 3.2
  29638. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29639. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  29640. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  29641. C           IF-THEN-ELSE.  (RWC)
  29642. C   920501  Reformatted the REFERENCES section.  (WRB)
  29643. C***END PROLOGUE  CPOFS
  29644. C
  29645.       INTEGER LDA,N,ITASK,IND,INFO
  29646.       COMPLEX A(LDA,*),V(*),WORK(*)
  29647.       REAL R1MACH
  29648.       REAL RCOND
  29649.       CHARACTER*8 XERN1, XERN2
  29650. C***FIRST EXECUTABLE STATEMENT  CPOFS
  29651.       IF (LDA.LT.N) THEN
  29652.          IND = -1
  29653.          WRITE (XERN1, '(I8)') LDA
  29654.          WRITE (XERN2, '(I8)') N
  29655.          CALL XERMSG ('SLATEC', 'CPOFS', 'LDA = ' // XERN1 //
  29656.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  29657.          RETURN
  29658.       ENDIF
  29659. C
  29660.       IF (N.LE.0) THEN
  29661.          IND = -2
  29662.          WRITE (XERN1, '(I8)') N
  29663.          CALL XERMSG ('SLATEC', 'CPOFS', 'N = ' // XERN1 //
  29664.      *      ' IS LESS THAN 1', -2, 1)
  29665.          RETURN
  29666.       ENDIF
  29667. C
  29668.       IF (ITASK.LT.1) THEN
  29669.          IND = -3
  29670.          WRITE (XERN1, '(I8)') ITASK
  29671.          CALL XERMSG ('SLATEC', 'CPOFS', 'ITASK = ' // XERN1 //
  29672.      *      ' IS LESS THAN 1', -3, 1)
  29673.          RETURN
  29674.       ENDIF
  29675. C
  29676.       IF (ITASK.EQ.1) THEN
  29677. C
  29678. C        FACTOR MATRIX A INTO R
  29679. C
  29680.          CALL CPOCO(A,LDA,N,RCOND,WORK,INFO)
  29681. C
  29682. C        CHECK FOR POSITIVE DEFINITE MATRIX
  29683. C
  29684.          IF (INFO.NE.0) THEN
  29685.             IND = -4
  29686.             CALL XERMSG ('SLATEC', 'CPOFS',
  29687.      *         'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1)
  29688.             RETURN
  29689.          ENDIF
  29690. C
  29691. C        COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  29692. C        AND CHECK FOR IND GREATER THAN ZERO
  29693. C
  29694.          IND = -LOG10(R1MACH(4)/RCOND)
  29695.          IF (IND.LE.0) THEN
  29696.             IND = -10
  29697.             CALL XERMSG ('SLATEC', 'CPOFS',
  29698.      *         'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  29699.          ENDIF
  29700.       ENDIF
  29701. C
  29702. C     SOLVE AFTER FACTORING
  29703. C
  29704.       CALL CPOSL(A,LDA,N,V)
  29705.       RETURN
  29706.       END
  29707. *DECK CPOIR
  29708.       SUBROUTINE CPOIR (A, LDA, N, V, ITASK, IND, WORK)
  29709. C***BEGIN PROLOGUE  CPOIR
  29710. C***PURPOSE  Solve a positive definite Hermitian system of linear
  29711. C            equations.  Iterative refinement is used to obtain an
  29712. C            error estimate.
  29713. C***LIBRARY   SLATEC
  29714. C***CATEGORY  D2D1B
  29715. C***TYPE      COMPLEX (SPOIR-S, CPOIR-C)
  29716. C***KEYWORDS  HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC
  29717. C***AUTHOR  Voorhees, E. A., (LANL)
  29718. C***DESCRIPTION
  29719. C
  29720. C    Subroutine CPOIR solves a complex positive definite Hermitian
  29721. C    NxN system of single precision linear equations using LINPACK
  29722. C    subroutines CPOFA and CPOSL.  One pass of iterative refine-
  29723. C    ment is used only to obtain an estimate of the accuracy.  That
  29724. C    is, if A is an NxN complex positive definite Hermitian matrix
  29725. C    and if X and B are complex N-vectors, then CPOIR solves the
  29726. C    equation
  29727. C
  29728. C                          A*X=B.
  29729. C
  29730. C    Care should be taken not to use CPOIR with a non-Hermitian
  29731. C    matrix.
  29732. C
  29733. C    The matrix A is first factored into upper and lower
  29734. C    triangular matrices R and R-TRANSPOSE.  These
  29735. C    factors are used to calculate the solution, X.
  29736. C    Then the residual vector is found and used
  29737. C    to calculate an estimate of the relative error, IND.
  29738. C    IND estimates the accuracy of the solution only when the
  29739. C    input matrix and the right hand side are represented
  29740. C    exactly in the computer and does not take into account
  29741. C    any errors in the input data.
  29742. C
  29743. C    If the equation A*X=B is to be solved for more than one vector
  29744. C    B, the factoring of A does not need to be performed again and
  29745. C    the option to only solve (ITASK .GT. 1) will be faster for
  29746. C    the succeeding solutions.  In this case, the contents of A,
  29747. C    LDA, N, and WORK must not have been altered by the user
  29748. C    following factorization (ITASK=1).  IND will not be changed
  29749. C    by CPOIR in this case.
  29750. C
  29751. C  Argument Description ***
  29752. C    A       COMPLEX(LDA,N)
  29753. C             the doubly subscripted array with dimension (LDA,N)
  29754. C             which contains the coefficient matrix.  Only the
  29755. C             upper triangle, including the diagonal, of the
  29756. C             coefficient matrix need be entered.  A is not
  29757. C             altered by the routine.
  29758. C    LDA    INTEGER
  29759. C             the leading dimension of the array A.  LDA must be great-
  29760. C             er than or equal to N.  (terminal error message IND=-1)
  29761. C    N      INTEGER
  29762. C             the order of the matrix A.  N must be greater than
  29763. C             or equal to one.  (terminal error message IND=-2)
  29764. C    V      COMPLEX(N)
  29765. C             on entry, the singly subscripted array(vector) of di-
  29766. C               mension N which contains the right hand side B of a
  29767. C               system of simultaneous linear equations A*X=B.
  29768. C             on return, V contains the solution vector, X .
  29769. C    ITASK  INTEGER
  29770. C             if ITASK = 1, the matrix A is factored and then the
  29771. C               linear equation is solved.
  29772. C             if ITASK .GT. 1, the equation is solved using the existing
  29773. C               factored matrix A (stored in WORK).
  29774. C             if ITASK .LT. 1, then terminal terminal error IND=-3 is
  29775. C               printed.
  29776. C    IND    INTEGER
  29777. C             GT. 0  IND is a rough estimate of the number of digits
  29778. C                     of accuracy in the solution, X.  IND=75 means
  29779. C                     that the solution vector X is zero.
  29780. C             LT. 0  see error message corresponding to IND below.
  29781. C    WORK   COMPLEX(N*(N+1))
  29782. C             a singly subscripted array of dimension at least N*(N+1).
  29783. C
  29784. C  Error Messages Printed ***
  29785. C
  29786. C    IND=-1  terminal   N is greater than LDA.
  29787. C    IND=-2  terminal   N is less than one.
  29788. C    IND=-3  terminal   ITASK is less than one.
  29789. C    IND=-4  terminal   The matrix A is computationally singular
  29790. C                         or is not positive definite.
  29791. C                         A solution has not been computed.
  29792. C    IND=-10 warning    The solution has no apparent significance.
  29793. C                         the solution may be inaccurate or the matrix
  29794. C                         a may be poorly scaled.
  29795. C
  29796. C               NOTE-  the above terminal(*fatal*) error messages are
  29797. C                      designed to be handled by XERMSG in which
  29798. C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
  29799. C                      for warning error messages from XERMSG.  Unless
  29800. C                      the user provides otherwise, an error message
  29801. C                      will be printed followed by an abort.
  29802. C
  29803. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29804. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29805. C***ROUTINES CALLED  CCOPY, CPOFA, CPOSL, DCDOT, R1MACH, SCASUM, XERMSG
  29806. C***REVISION HISTORY  (YYMMDD)
  29807. C   800530  DATE WRITTEN
  29808. C   890531  Changed all specific intrinsics to generic.  (WRB)
  29809. C   890831  Modified array declarations.  (WRB)
  29810. C   890831  REVISION DATE from Version 3.2
  29811. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29812. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  29813. C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
  29814. C           IF-THEN-ELSE.  (RWC)
  29815. C   920501  Reformatted the REFERENCES section.  (WRB)
  29816. C***END PROLOGUE  CPOIR
  29817. C
  29818.       INTEGER LDA,N,ITASK,IND,INFO,J
  29819.       COMPLEX A(LDA,*),V(*),WORK(N,*)
  29820.       REAL SCASUM,XNORM,DNORM,R1MACH
  29821.       DOUBLE PRECISION DR1,DI1,DR2,DI2
  29822.       CHARACTER*8 XERN1, XERN2
  29823. C***FIRST EXECUTABLE STATEMENT  CPOIR
  29824.       IF (LDA.LT.N) THEN
  29825.          IND = -1
  29826.          WRITE (XERN1, '(I8)') LDA
  29827.          WRITE (XERN2, '(I8)') N
  29828.          CALL XERMSG ('SLATEC', 'CPOIR', 'LDA = ' // XERN1 //
  29829.      *      ' IS LESS THAN N = ' // XERN2, -1, 1)
  29830.          RETURN
  29831.       ENDIF
  29832. C
  29833.       IF (N.LE.0) THEN
  29834.          IND = -2
  29835.          WRITE (XERN1, '(I8)') N
  29836.          CALL XERMSG ('SLATEC', 'CPOIR', 'N = ' // XERN1 //
  29837.      *      ' IS LESS THAN 1', -2, 1)
  29838.          RETURN
  29839.       ENDIF
  29840. C
  29841.       IF (ITASK.LT.1) THEN
  29842.          IND = -3
  29843.          WRITE (XERN1, '(I8)') ITASK
  29844.          CALL XERMSG ('SLATEC', 'CPOIR', 'ITASK = ' // XERN1 //
  29845.      *      ' IS LESS THAN 1', -3, 1)
  29846.          RETURN
  29847.       ENDIF
  29848. C
  29849.       IF (ITASK.EQ.1) THEN
  29850. C
  29851. C        MOVE MATRIX A TO WORK
  29852. C
  29853.          DO 10 J=1,N
  29854.             CALL CCOPY(N,A(1,J),1,WORK(1,J),1)
  29855.    10    CONTINUE
  29856. C
  29857. C        FACTOR MATRIX A INTO R
  29858. C
  29859.          CALL CPOFA(WORK,N,N,INFO)
  29860. C
  29861. C        CHECK FOR  SINGULAR OR NOT POS.DEF. MATRIX
  29862. C
  29863.          IF (INFO.NE.0) THEN
  29864.             IND = -4
  29865.             CALL XERMSG ('SLATEC', 'CPOIR',
  29866.      *         'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1)
  29867.             RETURN
  29868.          ENDIF
  29869.       ENDIF
  29870. C
  29871. C     SOLVE AFTER FACTORING
  29872. C     MOVE VECTOR B TO WORK
  29873. C
  29874.       CALL CCOPY(N,V(1),1,WORK(1,N+1),1)
  29875.       CALL CPOSL(WORK,N,N,V)
  29876. C
  29877. C     FORM NORM OF X0
  29878. C
  29879.       XNORM = SCASUM(N,V(1),1)
  29880.       IF (XNORM.EQ.0.0) THEN
  29881.          IND = 75
  29882.          RETURN
  29883.       ENDIF
  29884. C
  29885. C     COMPUTE  RESIDUAL
  29886. C
  29887.       DO 40 J=1,N
  29888.          CALL DCDOT(J-1,-1.D0,A(1,J),1,V(1),1,DR1,DI1)
  29889.          CALL DCDOT(N-J+1,1.D0,A(J,J),LDA,V(J),1,DR2,DI2)
  29890.          DR1 = DR1+DR2-DBLE(REAL(WORK(J,N+1)))
  29891.          DI1 = DI1+DI2-DBLE(AIMAG(WORK(J,N+1)))
  29892.          WORK(J,N+1) = CMPLX(REAL(DR1),REAL(DI1))
  29893.    40 CONTINUE
  29894. C
  29895. C     SOLVE A*DELTA=R
  29896. C
  29897.       CALL CPOSL(WORK,N,N,WORK(1,N+1))
  29898. C
  29899. C     FORM NORM OF DELTA
  29900. C
  29901.       DNORM = SCASUM(N,WORK(1,N+1),1)
  29902. C
  29903. C     COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
  29904. C     AND CHECK FOR IND GREATER THAN ZERO
  29905. C
  29906.       IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM))
  29907.       IF (IND.LE.0) THEN
  29908.          IND = -10
  29909.          CALL XERMSG ('SLATEC', 'CPOIR',
  29910.      *      'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
  29911.       ENDIF
  29912.       RETURN
  29913.       END
  29914. *DECK CPOSL
  29915.       SUBROUTINE CPOSL (A, LDA, N, B)
  29916. C***BEGIN PROLOGUE  CPOSL
  29917. C***PURPOSE  Solve the complex Hermitian positive definite linear system
  29918. C            using the factors computed by CPOCO or CPOFA.
  29919. C***LIBRARY   SLATEC (LINPACK)
  29920. C***CATEGORY  D2D1B
  29921. C***TYPE      COMPLEX (SPOSL-S, DPOSL-D, CPOSL-C)
  29922. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE
  29923. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  29924. C***DESCRIPTION
  29925. C
  29926. C     CPOSL solves the COMPLEX Hermitian positive definite system
  29927. C     A * X = B
  29928. C     using the factors computed by CPOCO or CPOFA.
  29929. C
  29930. C     On Entry
  29931. C
  29932. C        A       COMPLEX(LDA, N)
  29933. C                the output from CPOCO or CPOFA.
  29934. C
  29935. C        LDA     INTEGER
  29936. C                the leading dimension of the array  A .
  29937. C
  29938. C        N       INTEGER
  29939. C                the order of the matrix  A .
  29940. C
  29941. C        B       COMPLEX(N)
  29942. C                the right hand side vector.
  29943. C
  29944. C     On Return
  29945. C
  29946. C        B       the solution vector  X .
  29947. C
  29948. C     Error Condition
  29949. C
  29950. C        A division by zero will occur if the input factor contains
  29951. C        a zero on the diagonal.  Technically this indicates
  29952. C        singularity but it is usually caused by improper subroutine
  29953. C        arguments.  It will not occur if the subroutines are called
  29954. C        correctly and  INFO .EQ. 0 .
  29955. C
  29956. C     To compute  INVERSE(A) * C  where  C  is a matrix
  29957. C     with  P  columns
  29958. C           CALL CPOCO(A,LDA,N,RCOND,Z,INFO)
  29959. C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
  29960. C           DO 10 J = 1, P
  29961. C              CALL CPOSL(A,LDA,N,C(1,J))
  29962. C        10 CONTINUE
  29963. C
  29964. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  29965. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  29966. C***ROUTINES CALLED  CAXPY, CDOTC
  29967. C***REVISION HISTORY  (YYMMDD)
  29968. C   780814  DATE WRITTEN
  29969. C   890831  Modified array declarations.  (WRB)
  29970. C   890831  REVISION DATE from Version 3.2
  29971. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  29972. C   900326  Removed duplicate information from DESCRIPTION section.
  29973. C           (WRB)
  29974. C   920501  Reformatted the REFERENCES section.  (WRB)
  29975. C***END PROLOGUE  CPOSL
  29976.       INTEGER LDA,N
  29977.       COMPLEX A(LDA,*),B(*)
  29978. C
  29979.       COMPLEX CDOTC,T
  29980.       INTEGER K,KB
  29981. C
  29982. C     SOLVE CTRANS(R)*Y = B
  29983. C
  29984. C***FIRST EXECUTABLE STATEMENT  CPOSL
  29985.       DO 10 K = 1, N
  29986.          T = CDOTC(K-1,A(1,K),1,B(1),1)
  29987.          B(K) = (B(K) - T)/A(K,K)
  29988.    10 CONTINUE
  29989. C
  29990. C     SOLVE R*X = Y
  29991. C
  29992.       DO 20 KB = 1, N
  29993.          K = N + 1 - KB
  29994.          B(K) = B(K)/A(K,K)
  29995.          T = -B(K)
  29996.          CALL CAXPY(K-1,T,A(1,K),1,B(1),1)
  29997.    20 CONTINUE
  29998.       RETURN
  29999.       END
  30000. *DECK CPPCO
  30001.       SUBROUTINE CPPCO (AP, N, RCOND, Z, INFO)
  30002. C***BEGIN PROLOGUE  CPPCO
  30003. C***PURPOSE  Factor a complex Hermitian positive definite matrix stored
  30004. C            in packed form and estimate the condition number of the
  30005. C            matrix.
  30006. C***LIBRARY   SLATEC (LINPACK)
  30007. C***CATEGORY  D2D1B
  30008. C***TYPE      COMPLEX (SPPCO-S, DPPCO-D, CPPCO-C)
  30009. C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
  30010. C             MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE
  30011. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  30012. C***DESCRIPTION
  30013. C
  30014. C     CPPCO factors a complex Hermitian positive definite matrix
  30015. C     stored in packed form and estimates the condition of the matrix.
  30016. C
  30017. C     If  RCOND  is not needed, CPPFA is slightly faster.
  30018. C     To solve  A*X = B , follow CPPCO by CPPSL.
  30019. C     To compute  INVERSE(A)*C , follow CPPCO by CPPSL.
  30020. C     To compute  DETERMINANT(A) , follow CPPCO by CPPDI.
  30021. C     To compute  INVERSE(A) , follow CPPCO by CPPDI.
  30022. C
  30023. C     On Entry
  30024. C
  30025. C        AP      COMPLEX (N*(N+1)/2)
  30026. C                the packed form of a Hermitian matrix  A .  The
  30027. C                columns of the upper triangle are stored sequentially
  30028. C                in a one-dimensional array of length  N*(N+1)/2 .
  30029. C                See comments below for details.
  30030. C
  30031. C        N       INTEGER
  30032. C                the order of the matrix  A .
  30033. C
  30034. C     On Return
  30035. C
  30036. C        AP      an upper triangular matrix  R , stored in packed
  30037. C                form, so that  A = CTRANS(R)*R .
  30038. C                If  INFO .NE. 0 , the factorization is not complete.
  30039. C
  30040. C        RCOND   REAL
  30041. C                an estimate of the reciprocal condition of  A .
  30042. C                For the system  A*X = B , relative perturbations
  30043. C                in  A  and  B  of size  EPSILON  may cause
  30044. C                relative perturbations in  X  of size  EPSILON/RCOND .
  30045. C                If  RCOND  is so small that the logical expression
  30046. C                           1.0 + RCOND .EQ. 1.0
  30047. C                is true, then  A  may be singular to working
  30048. C                precision.  In particular,  RCOND  is zero  if
  30049. C                exact singularity is detected or the estimate
  30050. C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
  30051. C
  30052. C        Z       COMPLEX(N)
  30053. C                a work vector whose contents are usually unimportant.
  30054. C                If  A  is singular to working precision, then  Z  is
  30055. C                an approximate null vector in the sense that
  30056. C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
  30057. C                If  INFO .NE. 0 , Z  is unchanged.
  30058. C
  30059. C        INFO    INTEGER
  30060. C                = 0  for normal return.
  30061. C                = K  signals an error condition.  The leading minor
  30062. C                     of order  K  is not positive definite.
  30063. C
  30064. C     Packed Storage
  30065. C
  30066. C          The following program segment will pack the upper
  30067. C          triangle of a Hermitian matrix.
  30068. C
  30069. C                K = 0
  30070. C                DO 20 J = 1, N
  30071. C                   DO 10 I = 1, J
  30072. C                      K = K + 1
  30073. C                      AP(K) = A(I,J)
  30074. C             10    CONTINUE
  30075. C             20 CONTINUE
  30076. C
  30077. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  30078. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  30079. C***ROUTINES CALLED  CAXPY, CDOTC, CPPFA, CSSCAL, SCASUM
  30080. C***REVISION HISTORY  (YYMMDD)
  30081. C   780814  DATE WRITTEN
  30082. C   890531  Changed all specific intrinsics to generic.  (WRB)
  30083. C   890831  Modified array declarations.  (WRB)
  30084. C   890831  REVISION DATE from Version 3.2
  30085. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30086. C   900326  Removed duplicate information from DESCRIPTION section.
  30087. C           (WRB)
  30088. C   920501  Reformatted the REFERENCES section.  (WRB)
  30089. C***END PROLOGUE  CPPCO
  30090.       INTEGER N,INFO
  30091.       COMPLEX AP(*),Z(*)
  30092.       REAL RCOND
  30093. C
  30094.       COMPLEX CDOTC,EK,T,WK,WKM
  30095.       REAL ANORM,S,SCASUM,SM,YNORM
  30096.       INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1
  30097.       COMPLEX ZDUM,ZDUM2,CSIGN1
  30098.       REAL CABS1
  30099.       CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
  30100.       CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2))
  30101. C
  30102. C     FIND NORM OF A
  30103. C
  30104. C***FIRST EXECUTABLE STATEMENT  CPPCO
  30105.       J1 = 1
  30106.       DO 30 J = 1, N
  30107.          Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0)
  30108.          IJ = J1
  30109.          J1 = J1 + J
  30110.          JM1 = J - 1
  30111.          IF (JM1 .LT. 1) GO TO 20
  30112.          DO 10 I = 1, JM1
  30113.             Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0)
  30114.             IJ = IJ + 1
  30115.    10    CONTINUE
  30116.    20    CONTINUE
  30117.    30 CONTINUE
  30118.       ANORM = 0.0E0
  30119.       DO 40 J = 1, N
  30120.          ANORM = MAX(ANORM,REAL(Z(J)))
  30121.    40 CONTINUE
  30122. C
  30123. C     FACTOR
  30124. C
  30125.       CALL CPPFA(AP,N,INFO)
  30126.       IF (INFO .NE. 0) GO TO 180
  30127. C
  30128. C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
  30129. C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
  30130. C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
  30131. C        GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(R)*W = E .
  30132. C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
  30133. C
  30134. C        SOLVE CTRANS(R)*W = E
  30135. C
  30136.          EK = (1.0E0,0.0E0)
  30137.          DO 50 J = 1, N
  30138.             Z(J) = (0.0E0,0.0E0)
  30139.    50    CONTINUE
  30140.          KK = 0
  30141.          DO 110 K = 1, N
  30142.             KK = KK + K
  30143.             IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
  30144.             IF (CABS1(EK-Z(K)) .LE. REAL(AP(KK))) GO TO 60
  30145.                S = REAL(AP(KK))/CABS1(EK-Z(K))
  30146.                CALL CSSCAL(N,S,Z,1)
  30147.                EK = CMPLX(S,0.0E0)*EK
  30148.    60       CONTINUE
  30149.             WK = EK - Z(K)
  30150.             WKM = -EK - Z(K)
  30151.             S = CABS1(WK)
  30152.             SM = CABS1(WKM)
  30153.             WK = WK/AP(KK)
  30154.             WKM = WKM/AP(KK)
  30155.             KP1 = K + 1
  30156.             KJ = KK + K
  30157.             IF (KP1 .GT. N) GO TO 100
  30158.                DO 70 J = KP1, N
  30159.                   SM = SM + CABS1(Z(J)+WKM*CONJG(AP(KJ)))
  30160.                   Z(J) = Z(J) + WK*CONJG(AP(KJ))
  30161.                   S = S + CABS1(Z(J))
  30162.                   KJ = KJ + J
  30163.    70          CONTINUE
  30164.                IF (S .GE. SM) GO TO 90
  30165.                   T = WKM - WK
  30166.                   WK = WKM
  30167.                   KJ = KK + K
  30168.                   DO 80 J = KP1, N
  30169.                      Z(J) = Z(J) + T*CONJG(AP(KJ))
  30170.                      KJ = KJ + J
  30171.    80             CONTINUE
  30172.    90          CONTINUE
  30173.   100       CONTINUE
  30174.             Z(K) = WK
  30175.   110    CONTINUE
  30176.          S = 1.0E0/SCASUM(N,Z,1)
  30177.          CALL CSSCAL(N,S,Z,1)
  30178. C
  30179. C        SOLVE R*Y = W
  30180. C
  30181.          DO 130 KB = 1, N
  30182.             K = N + 1 - KB
  30183.             IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 120
  30184.                S = REAL(AP(KK))/CABS1(Z(K))
  30185.                CALL CSSCAL(N,S,Z,1)
  30186.   120       CONTINUE
  30187.             Z(K) = Z(K)/AP(KK)
  30188.             KK = KK - K
  30189.             T = -Z(K)
  30190.             CALL CAXPY(K-1,T,AP(KK+1),1,Z(1),1)
  30191.   130    CONTINUE
  30192.          S = 1.0E0/SCASUM(N,Z,1)
  30193.          CALL CSSCAL(N,S,Z,1)
  30194. C
  30195.          YNORM = 1.0E0
  30196. C
  30197. C        SOLVE CTRANS(R)*V = Y
  30198. C
  30199.          DO 150 K = 1, N
  30200.             Z(K) = Z(K) - CDOTC(K-1,AP(KK+1),1,Z(1),1)
  30201.             KK = KK + K
  30202.             IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 140
  30203.                S = REAL(AP(KK))/CABS1(Z(K))
  30204.                CALL CSSCAL(N,S,Z,1)
  30205.                YNORM = S*YNORM
  30206.   140       CONTINUE
  30207.             Z(K) = Z(K)/AP(KK)
  30208.   150    CONTINUE
  30209.          S = 1.0E0/SCASUM(N,Z,1)
  30210.          CALL CSSCAL(N,S,Z,1)
  30211.          YNORM = S*YNORM
  30212. C
  30213. C        SOLVE R*Z = V
  30214. C
  30215.          DO 170 KB = 1, N
  30216.             K = N + 1 - KB
  30217.             IF (CABS1(Z(K)) .LE. REAL(AP(KK))) GO TO 160
  30218.                S = REAL(AP(KK))/CABS1(Z(K))
  30219.                CALL CSSCAL(N,S,Z,1)
  30220.                YNORM = S*YNORM
  30221.   160       CONTINUE
  30222.             Z(K) = Z(K)/AP(KK)
  30223.             KK = KK - K
  30224.             T = -Z(K)
  30225.             CALL CAXPY(K-1,T,AP(KK+1),1,Z(1),1)
  30226.   170    CONTINUE
  30227. C        MAKE ZNORM = 1.0
  30228.          S = 1.0E0/SCASUM(N,Z,1)
  30229.          CALL CSSCAL(N,S,Z,1)
  30230.          YNORM = S*YNORM
  30231. C
  30232.          IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
  30233.          IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
  30234.   180 CONTINUE
  30235.       RETURN
  30236.       END
  30237. *DECK CPPDI
  30238.       SUBROUTINE CPPDI (AP, N, DET, JOB)
  30239. C***BEGIN PROLOGUE  CPPDI
  30240. C***PURPOSE  Compute the determinant and inverse of a complex Hermitian
  30241. C            positive definite matrix using factors from CPPCO or CPPFA.
  30242. C***LIBRARY   SLATEC (LINPACK)
  30243. C***CATEGORY  D2D1B, D3D1B
  30244. C***TYPE      COMPLEX (SPPDI-S, DPPDI-D, CPPDI-C)
  30245. C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
  30246. C             PACKED, POSITIVE DEFINITE
  30247. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  30248. C***DESCRIPTION
  30249. C
  30250. C     CPPDI computes the determinant and inverse
  30251. C     of a complex Hermitian positive definite matrix
  30252. C     using the factors computed by CPPCO or CPPFA .
  30253. C
  30254. C     On Entry
  30255. C
  30256. C        AP      COMPLEX (N*(N+1)/2)
  30257. C                the output from CPPCO or CPPFA.
  30258. C
  30259. C        N       INTEGER
  30260. C                the order of the matrix  A .
  30261. C
  30262. C        JOB     INTEGER
  30263. C                = 11   both determinant and inverse.
  30264. C                = 01   inverse only.
  30265. C                = 10   determinant only.
  30266. C
  30267. C     On Return
  30268. C
  30269. C        AP      the upper triangular half of the inverse .
  30270. C                The strict lower triangle is unaltered.
  30271. C
  30272. C        DET     REAL(2)
  30273. C                determinant of original matrix if requested.
  30274. C                Otherwise not referenced.
  30275. C                Determinant = DET(1) * 10.0**DET(2)
  30276. C                with  1.0 .LE. DET(1) .LT. 10.0
  30277. C                or  DET(1) .EQ. 0.0 .
  30278. C
  30279. C     Error Condition
  30280. C
  30281. C        A division by zero will occur if the input factor contains
  30282. C        a zero on the diagonal and the inverse is requested.
  30283. C        It will not occur if the subroutines are called correctly
  30284. C        and if CPOCO or CPOFA has set INFO .EQ. 0 .
  30285. C
  30286. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  30287. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  30288. C***ROUTINES CALLED  CAXPY, CSCAL
  30289. C***REVISION HISTORY  (YYMMDD)
  30290. C   780814  DATE WRITTEN
  30291. C   890831  Modified array declarations.  (WRB)
  30292. C   890831  REVISION DATE from Version 3.2
  30293. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30294. C   900326  Removed duplicate information from DESCRIPTION section.
  30295. C           (WRB)
  30296. C   920501  Reformatted the REFERENCES section.  (WRB)
  30297. C***END PROLOGUE  CPPDI
  30298.       INTEGER N,JOB
  30299.       COMPLEX AP(*)
  30300.       REAL DET(2)
  30301. C
  30302.       COMPLEX T
  30303.       REAL S
  30304.       INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1
  30305. C***FIRST EXECUTABLE STATEMENT  CPPDI
  30306. C
  30307. C     COMPUTE DETERMINANT
  30308. C
  30309.       IF (JOB/10 .EQ. 0) GO TO 70
  30310.          DET(1) = 1.0E0
  30311.          DET(2) = 0.0E0
  30312.          S = 10.0E0
  30313.          II = 0
  30314.          DO 50 I = 1, N
  30315.             II = II + I
  30316.             DET(1) = REAL(AP(II))**2*DET(1)
  30317.             IF (DET(1) .EQ. 0.0E0) GO TO 60
  30318.    10       IF (DET(1) .GE. 1.0E0) GO TO 20
  30319.                DET(1) = S*DET(1)
  30320.                DET(2) = DET(2) - 1.0E0
  30321.             GO TO 10
  30322.    20       CONTINUE
  30323.    30       IF (DET(1) .LT. S) GO TO 40
  30324.                DET(1) = DET(1)/S
  30325.                DET(2) = DET(2) + 1.0E0
  30326.             GO TO 30
  30327.    40       CONTINUE
  30328.    50    CONTINUE
  30329.    60    CONTINUE
  30330.    70 CONTINUE
  30331. C
  30332. C     COMPUTE INVERSE(R)
  30333. C
  30334.       IF (MOD(JOB,10) .EQ. 0) GO TO 140
  30335.          KK = 0
  30336.          DO 100 K = 1, N
  30337.             K1 = KK + 1
  30338.             KK = KK + K
  30339.             AP(KK) = (1.0E0,0.0E0)/AP(KK)
  30340.             T = -AP(KK)
  30341.             CALL CSCAL(K-1,T,AP(K1),1)
  30342.             KP1 = K + 1
  30343.             J1 = KK + 1
  30344.             KJ = KK + K
  30345.             IF (N .LT. KP1) GO TO 90
  30346.             DO 80 J = KP1, N
  30347.                T = AP(KJ)
  30348.                AP(KJ) = (0.0E0,0.0E0)
  30349.                CALL CAXPY(K,T,AP(K1),1,AP(J1),1)
  30350.                J1 = J1 + J
  30351.                KJ = KJ + J
  30352.    80       CONTINUE
  30353.    90       CONTINUE
  30354.   100    CONTINUE
  30355. C
  30356. C        FORM  INVERSE(R) * CTRANS(INVERSE(R))
  30357. C
  30358.          JJ = 0
  30359.          DO 130 J = 1, N
  30360.             J1 = JJ + 1
  30361.             JJ = JJ + J
  30362.             JM1 = J - 1
  30363.             K1 = 1
  30364.             KJ = J1
  30365.             IF (JM1 .LT. 1) GO TO 120
  30366.             DO 110 K = 1, JM1
  30367.                T = CONJG(AP(KJ))
  30368.                CALL CAXPY(K,T,AP(J1),1,AP(K1),1)
  30369.                K1 = K1 + K
  30370.                KJ = KJ + 1
  30371.   110       CONTINUE
  30372.   120       CONTINUE
  30373.             T = CONJG(AP(JJ))
  30374.             CALL CSCAL(J,T,AP(J1),1)
  30375.   130    CONTINUE
  30376.   140 CONTINUE
  30377.       RETURN
  30378.       END
  30379. *DECK CPPFA
  30380.       SUBROUTINE CPPFA (AP, N, INFO)
  30381. C***BEGIN PROLOGUE  CPPFA
  30382. C***PURPOSE  Factor a complex Hermitian positive definite matrix stored
  30383. C            in packed form.
  30384. C***LIBRARY   SLATEC (LINPACK)
  30385. C***CATEGORY  D2D1B
  30386. C***TYPE      COMPLEX (SPPFA-S, DPPFA-D, CPPFA-C)
  30387. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED,
  30388. C             POSITIVE DEFINITE
  30389. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  30390. C***DESCRIPTION
  30391. C
  30392. C     CPPFA factors a complex Hermitian positive definite matrix
  30393. C     stored in packed form.
  30394. C
  30395. C     CPPFA is usually called by CPPCO, but it can be called
  30396. C     directly with a saving in time if  RCOND  is not needed.
  30397. C     (Time for CPPCO) = (1 + 18/N)*(Time for CPPFA) .
  30398. C
  30399. C     On Entry
  30400. C
  30401. C        AP      COMPLEX (N*(N+1)/2)
  30402. C                the packed form of a Hermitian matrix  A .  The
  30403. C                columns of the upper triangle are stored sequentially
  30404. C                in a one-dimensional array of length  N*(N+1)/2 .
  30405. C                See comments below for details.
  30406. C
  30407. C        N       INTEGER
  30408. C                the order of the matrix  A .
  30409. C
  30410. C     On Return
  30411. C
  30412. C        AP      an upper triangular matrix  R , stored in packed
  30413. C                form, so that  A = CTRANS(R)*R .
  30414. C
  30415. C        INFO    INTEGER
  30416. C                = 0  for normal return.
  30417. C                = K  If the leading minor of order  K  is not
  30418. C                     positive definite.
  30419. C
  30420. C
  30421. C     Packed Storage
  30422. C
  30423. C          The following program segment will pack the upper
  30424. C          triangle of a Hermitian matrix.
  30425. C
  30426. C                K = 0
  30427. C                DO 20 J = 1, N
  30428. C                   DO 10 I = 1, J
  30429. C                      K = K + 1
  30430. C                      AP(K) = A(I,J)
  30431. C             10    CONTINUE
  30432. C             20 CONTINUE
  30433. C
  30434. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  30435. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  30436. C***ROUTINES CALLED  CDOTC
  30437. C***REVISION HISTORY  (YYMMDD)
  30438. C   780814  DATE WRITTEN
  30439. C   890831  Modified array declarations.  (WRB)
  30440. C   890831  REVISION DATE from Version 3.2
  30441. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30442. C   900326  Removed duplicate information from DESCRIPTION section.
  30443. C           (WRB)
  30444. C   920501  Reformatted the REFERENCES section.  (WRB)
  30445. C***END PROLOGUE  CPPFA
  30446.       INTEGER N,INFO
  30447.       COMPLEX AP(*)
  30448. C
  30449.       COMPLEX CDOTC,T
  30450.       REAL S
  30451.       INTEGER J,JJ,JM1,K,KJ,KK
  30452. C***FIRST EXECUTABLE STATEMENT  CPPFA
  30453.          JJ = 0
  30454.          DO 30 J = 1, N
  30455.             INFO = J
  30456.             S = 0.0E0
  30457.             JM1 = J - 1
  30458.             KJ = JJ
  30459.             KK = 0
  30460.             IF (JM1 .LT. 1) GO TO 20
  30461.             DO 10 K = 1, JM1
  30462.                KJ = KJ + 1
  30463.                T = AP(KJ) - CDOTC(K-1,AP(KK+1),1,AP(JJ+1),1)
  30464.                KK = KK + K
  30465.                T = T/AP(KK)
  30466.                AP(KJ) = T
  30467.                S = S + REAL(T*CONJG(T))
  30468.    10       CONTINUE
  30469.    20       CONTINUE
  30470.             JJ = JJ + J
  30471.             S = REAL(AP(JJ)) - S
  30472.             IF (S .LE. 0.0E0 .OR. AIMAG(AP(JJ)) .NE. 0.0E0) GO TO 40
  30473.             AP(JJ) = CMPLX(SQRT(S),0.0E0)
  30474.    30    CONTINUE
  30475.          INFO = 0
  30476.    40 CONTINUE
  30477.       RETURN
  30478.       END
  30479. *DECK CPPSL
  30480.       SUBROUTINE CPPSL (AP, N, B)
  30481. C***BEGIN PROLOGUE  CPPSL
  30482. C***PURPOSE  Solve the complex Hermitian positive definite system using
  30483. C            the factors computed by CPPCO or CPPFA.
  30484. C***LIBRARY   SLATEC (LINPACK)
  30485. C***CATEGORY  D2D1B
  30486. C***TYPE      COMPLEX (SPPSL-S, DPPSL-D, CPPSL-C)
  30487. C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, PACKED,
  30488. C             POSITIVE DEFINITE, SOLVE
  30489. C***AUTHOR  Moler, C. B., (U. of New Mexico)
  30490. C***DESCRIPTION
  30491. C
  30492. C     CPPSL solves the complex Hermitian positive definite system
  30493. C     A * X = B
  30494. C     using the factors computed by CPPCO or CPPFA.
  30495. C
  30496. C     On Entry
  30497. C
  30498. C        AP      COMPLEX (N*(N+1)/2)
  30499. C                the output from CPPCO or CPPFA.
  30500. C
  30501. C        N       INTEGER
  30502. C                the order of the matrix  A .
  30503. C
  30504. C        B       COMPLEX(N)
  30505. C                the right hand side vector.
  30506. C
  30507. C     On Return
  30508. C
  30509. C        B       the solution vector  X .
  30510. C
  30511. C     Error Condition
  30512. C
  30513. C        A division by zero will occur if the input factor contains
  30514. C        a zero on the diagonal.  Technically this indicates
  30515. C        singularity but it is usually caused by improper subroutine
  30516. C        arguments.  It will not occur if the subroutines are called
  30517. C        correctly and  INFO .EQ. 0 .
  30518. C
  30519. C     To compute  INVERSE(A) * C  where  C  is a matrix
  30520. C     with  P  columns
  30521. C           CALL CPPCO(AP,N,RCOND,Z,INFO)
  30522. C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
  30523. C           DO 10 J = 1, P
  30524. C              CALL CPPSL(AP,N,C(1,J))
  30525. C        10 CONTINUE
  30526. C
  30527. C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
  30528. C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
  30529. C***ROUTINES CALLED  CAXPY, CDOTC
  30530. C***REVISION HISTORY  (YYMMDD)
  30531. C   780814  DATE WRITTEN
  30532. C   890831  Modified array declarations.  (WRB)
  30533. C   890831  REVISION DATE from Version 3.2
  30534. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30535. C   900326  Removed duplicate information from DESCRIPTION section.
  30536. C           (WRB)
  30537. C   920501  Reformatted the REFERENCES section.  (WRB)
  30538. C***END PROLOGUE  CPPSL
  30539.       INTEGER N
  30540.       COMPLEX AP(*),B(*)
  30541. C
  30542.       COMPLEX CDOTC,T
  30543.       INTEGER K,KB,KK
  30544. C***FIRST EXECUTABLE STATEMENT  CPPSL
  30545.       KK = 0
  30546.       DO 10 K = 1, N
  30547.          T = CDOTC(K-1,AP(KK+1),1,B(1),1)
  30548.          KK = KK + K
  30549.          B(K) = (B(K) - T)/AP(KK)
  30550.    10 CONTINUE
  30551.       DO 20 KB = 1, N
  30552.          K = N + 1 - KB
  30553.          B(K) = B(K)/AP(KK)
  30554.          KK = KK - K
  30555.          T = -B(K)
  30556.          CALL CAXPY(K-1,T,AP(KK+1),1,B(1),1)
  30557.    20 CONTINUE
  30558.       RETURN
  30559.       END
  30560. *DECK CPQR79
  30561.       SUBROUTINE CPQR79 (NDEG, COEFF, ROOT, IERR, WORK)
  30562. C***BEGIN PROLOGUE  CPQR79
  30563. C***PURPOSE  Find the zeros of a polynomial with complex coefficients.
  30564. C***LIBRARY   SLATEC
  30565. C***CATEGORY  F1A1B
  30566. C***TYPE      COMPLEX (RPQR79-S, CPQR79-C)
  30567. C***KEYWORDS  COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS
  30568. C***AUTHOR  Vandevender, W. H., (SNLA)
  30569. C***DESCRIPTION
  30570. C
  30571. C   Abstract
  30572. C       This routine computes all zeros of a polynomial of degree NDEG
  30573. C       with complex coefficients by computing the eigenvalues of the
  30574. C       companion matrix.
  30575. C
  30576. C   Description of Parameters
  30577. C       The user must dimension all arrays appearing in the call list
  30578. C            COEFF(NDEG+1), ROOT(NDEG), WORK(2*NDEG*(NDEG+1))
  30579. C
  30580. C    --Input--
  30581. C      NDEG    degree of polynomial
  30582. C
  30583. C      COEFF   COMPLEX coefficients in descending order.  i.e.,
  30584. C              P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1)
  30585. C
  30586. C      WORK    REAL work array of dimension at least 2*NDEG*(NDEG+1)
  30587. C
  30588. C   --Output--
  30589. C      ROOT    COMPLEX vector of roots
  30590. C
  30591. C      IERR    Output Error Code
  30592. C           - Normal Code
  30593. C          0  means the roots were computed.
  30594. C           - Abnormal Codes
  30595. C          1  more than 30 QR iterations on some eigenvalue of the
  30596. C             companion matrix
  30597. C          2  COEFF(1)=0.0
  30598. C          3  NDEG is invalid (less than or equal to 0)
  30599. C
  30600. C***REFERENCES  (NONE)
  30601. C***ROUTINES CALLED  COMQR, XERMSG
  30602. C***REVISION HISTORY  (YYMMDD)
  30603. C   791201  DATE WRITTEN
  30604. C   890531  Changed all specific intrinsics to generic.  (WRB)
  30605. C   890531  REVISION DATE from Version 3.2
  30606. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30607. C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  30608. C   900326  Removed duplicate information from DESCRIPTION section.
  30609. C           (WRB)
  30610. C   911010  Code reworked and simplified.  (RWC and WRB)
  30611. C***END PROLOGUE  CPQR79
  30612.       COMPLEX COEFF(*), ROOT(*), SCALE, C
  30613.       REAL WORK(*)
  30614.       INTEGER NDEG, IERR, K, KHR, KHI, KWR, KWI, KAD, KJ
  30615. C***FIRST EXECUTABLE STATEMENT  CPQR79
  30616.       IERR = 0
  30617.       IF (ABS(COEFF(1)) .EQ. 0.0) THEN
  30618.          IERR = 2
  30619.          CALL XERMSG ('SLATEC', 'CPQR79',
  30620.      +      'LEADING COEFFICIENT IS ZERO.', 2, 1)
  30621.          RETURN
  30622.       ENDIF
  30623. C
  30624.       IF (NDEG .LE. 0) THEN
  30625.          IERR = 3
  30626.          CALL XERMSG ('SLATEC', 'CPQR79', 'DEGREE INVALID.', 3, 1)
  30627.          RETURN
  30628.       ENDIF
  30629. C
  30630.       IF (NDEG .EQ. 1) THEN
  30631.          ROOT(1) = -COEFF(2)/COEFF(1)
  30632.          RETURN
  30633.       ENDIF
  30634. C
  30635.       SCALE = 1.0E0/COEFF(1)
  30636.       KHR = 1
  30637.       KHI = KHR+NDEG*NDEG
  30638.       KWR = KHI+KHI-KHR
  30639.       KWI = KWR+NDEG
  30640. C
  30641.       DO 10 K=1,KWR
  30642.          WORK(K) = 0.0E0
  30643.    10 CONTINUE
  30644. C
  30645.       DO 20 K=1,NDEG
  30646.          KAD = (K-1)*NDEG+1
  30647.          C = SCALE*COEFF(K+1)
  30648.          WORK(KAD) = -REAL(C)
  30649.          KJ = KHI+KAD-1
  30650.          WORK(KJ) = -AIMAG(C)
  30651.          IF (K .NE. NDEG) WORK(KAD+K) = 1.0E0
  30652.    20 CONTINUE
  30653. C
  30654.       CALL COMQR (NDEG,NDEG,1,NDEG,WORK(KHR),WORK(KHI),WORK(KWR),
  30655.      1   WORK(KWI),IERR)
  30656. C
  30657.       IF (IERR .NE. 0) THEN
  30658.          IERR = 1
  30659.          CALL XERMSG ('SLATEC', 'CPQR79',
  30660.      +      'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1)
  30661.          RETURN
  30662.       ENDIF
  30663. C
  30664.       DO 30 K=1,NDEG
  30665.          KM1 = K-1
  30666.          ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1))
  30667.    30 CONTINUE
  30668.       RETURN
  30669.       END
  30670. *DECK CPROC
  30671.       SUBROUTINE CPROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A,
  30672.      +   B, C, D, W, YY)
  30673. C***BEGIN PROLOGUE  CPROC
  30674. C***SUBSIDIARY
  30675. C***PURPOSE  Subsidiary to CBLKTR
  30676. C***LIBRARY   SLATEC
  30677. C***TYPE      COMPLEX (CPROD-S, CPROC-C)
  30678. C***AUTHOR  (UNKNOWN)
  30679. C***DESCRIPTION
  30680. C
  30681. C PROC applies a sequence of matrix operations to the vector X and
  30682. C stores the result in Y.
  30683. C AA     Array containing scalar multipliers of the vector X.
  30684. C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively.
  30685. C BD,BM1,BM2 are arrays containing roots of certain B polynomials.
  30686. C NA     is the length of the array AA.
  30687. C X,Y    The matrix operations are applied to X and the result is Y.
  30688. C A,B,C  are arrays which contain the tridiagonal matrix.
  30689. C M      is the order of the matrix.
  30690. C D,W    are work arrays.
  30691. C ISGN   determines whether or not a change in sign is made.
  30692. C
  30693. C***SEE ALSO  CBLKTR
  30694. C***ROUTINES CALLED  (NONE)
  30695. C***REVISION HISTORY  (YYMMDD)
  30696. C   801001  DATE WRITTEN
  30697. C   890531  Changed all specific intrinsics to generic.  (WRB)
  30698. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30699. C   900402  Added TYPE section.  (WRB)
  30700. C***END PROLOGUE  CPROC
  30701. C
  30702.       COMPLEX         Y          ,D          ,W          ,BD         ,
  30703.      1                CRT        ,DEN        ,Y1         ,Y2         ,
  30704.      2                X          ,A          ,B          ,C
  30705.       DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
  30706.      1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
  30707.      2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
  30708. C***FIRST EXECUTABLE STATEMENT  CPROC
  30709.       DO 101 J=1,M
  30710.          Y(J) = X(J)
  30711.   101 CONTINUE
  30712.       MM = M-1
  30713.       ID = ND
  30714.       M1 = NM1
  30715.       M2 = NM2
  30716.       IA = NA
  30717.   102 IFLG = 0
  30718.       IF (ID) 109,109,103
  30719.   103 CRT = BD(ID)
  30720.       ID = ID-1
  30721. C
  30722. C BEGIN SOLUTION TO SYSTEM
  30723. C
  30724.       D(M) = A(M)/(B(M)-CRT)
  30725.       W(M) = Y(M)/(B(M)-CRT)
  30726.       DO 104 J=2,MM
  30727.          K = M-J
  30728.          DEN = B(K+1)-CRT-C(K+1)*D(K+2)
  30729.          D(K+1) = A(K+1)/DEN
  30730.          W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
  30731.   104 CONTINUE
  30732.       DEN = B(1)-CRT-C(1)*D(2)
  30733.       IF (ABS(DEN)) 105,106,105
  30734.   105 Y(1) = (Y(1)-C(1)*W(2))/DEN
  30735.       GO TO 107
  30736.   106 Y(1) = (1.,0.)
  30737.   107 DO 108 J=2,M
  30738.          Y(J) = W(J)-D(J)*Y(J-1)
  30739.   108 CONTINUE
  30740.   109 IF (M1) 110,110,112
  30741.   110 IF (M2) 121,121,111
  30742.   111 RT = BM2(M2)
  30743.       M2 = M2-1
  30744.       GO TO 117
  30745.   112 IF (M2) 113,113,114
  30746.   113 RT = BM1(M1)
  30747.       M1 = M1-1
  30748.       GO TO 117
  30749.   114 IF (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115
  30750.   115 RT = BM1(M1)
  30751.       M1 = M1-1
  30752.       GO TO 117
  30753.   116 RT = BM2(M2)
  30754.       M2 = M2-1
  30755.   117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)
  30756.       IF (MM-2) 120,118,118
  30757. C
  30758. C MATRIX MULTIPLICATION
  30759. C
  30760.   118 DO 119 J=2,MM
  30761.          Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1)
  30762.          Y(J-1) = Y1
  30763.          Y1 = Y2
  30764.   119 CONTINUE
  30765.   120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)
  30766.       Y(M-1) = Y1
  30767.       IFLG = 1
  30768.       GO TO 102
  30769.   121 IF (IA) 124,124,122
  30770.   122 RT = AA(IA)
  30771.       IA = IA-1
  30772.       IFLG = 1
  30773. C
  30774. C SCALAR MULTIPLICATION
  30775. C
  30776.       DO 123 J=1,M
  30777.          Y(J) = RT*Y(J)
  30778.   123 CONTINUE
  30779.   124 IF (IFLG) 125,125,102
  30780.   125 RETURN
  30781.       END
  30782. *DECK CPROCP
  30783.       SUBROUTINE CPROCP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A,
  30784.      +   B, C, D, U, YY)
  30785. C***BEGIN PROLOGUE  CPROCP
  30786. C***SUBSIDIARY
  30787. C***PURPOSE  Subsidiary to CBLKTR
  30788. C***LIBRARY   SLATEC
  30789. C***TYPE      COMPLEX (CPRODP-S, CPROCP-C)
  30790. C***AUTHOR  (UNKNOWN)
  30791. C***DESCRIPTION
  30792. C
  30793. C CPROCP applies a sequence of matrix operations to the vector X and
  30794. C stores the result in Y.
  30795. C
  30796. C BD,BM1,BM2  are arrays containing roots of certain B polynomials.
  30797. C ND,NM1,NM2  are the lengths of the arrays BD,BM1,BM2 respectively.
  30798. C AA          Array containing scalar multipliers of the vector X.
  30799. C NA          is the length of the array AA.
  30800. C X,Y        The matrix operations are applied to X and the result is Y.
  30801. C A,B,C       are arrays which contain the tridiagonal matrix.
  30802. C M           is the order of the matrix.
  30803. C D,U         are work arrays.
  30804. C ISGN        determines whether or not a change in sign is made.
  30805. C
  30806. C***SEE ALSO  CBLKTR
  30807. C***ROUTINES CALLED  (NONE)
  30808. C***REVISION HISTORY  (YYMMDD)
  30809. C   801001  DATE WRITTEN
  30810. C   890531  Changed all specific intrinsics to generic.  (WRB)
  30811. C   891214  Prologue converted to Version 4.0 format.  (BAB)
  30812. C   900402  Added TYPE section.  (WRB)
  30813. C***END PROLOGUE  CPROCP
  30814. C
  30815.       COMPLEX         Y          ,D          ,U          ,V          ,
  30816.      1                DEN        ,BH         ,YM         ,AM         ,
  30817.      2                Y1         ,Y2         ,YH         ,BD         ,
  30818.      3                CRT        ,X          ,A          ,B          ,C
  30819.       DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
  30820.      1                Y(*)       ,D(*)       ,U(*)       ,BD(*)      ,
  30821.      2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
  30822. C***FIRST EXECUTABLE STATEMENT  CPROCP
  30823.       DO 101 J=1,M
  30824.          Y(J) = X(J)
  30825.   101 CONTINUE
  30826.       MM = M-1
  30827.       MM2 = M-2
  30828.       ID = ND
  30829.       M1 = NM1
  30830.       M2 = NM2
  30831.       IA = NA
  30832.   102 IFLG = 0
  30833.       IF (ID) 111,111,103
  30834.   103 CRT = BD(ID)
  30835.       ID = ID-1
  30836.       IFLG = 1
  30837. C
  30838. C BEGIN SOLUTION TO SYSTEM
  30839. C
  30840.       BH = B(M)-CRT
  30841.       YM = Y(M)
  30842.       DEN = B(1)-CRT
  30843.       D(1) = C(1)/DEN
  30844.       U(1) = A(1)/DEN
  30845.       Y(1) = Y(1)/DEN
  30846.       V = C(M)
  30847.       IF (MM2-2) 106,104,104
  30848.   104 DO 105 J=2,MM2
  30849.          DEN = B(J)-CRT-A(J)*D(J-1)
  30850.          D(J) = C(J)/DEN
  30851.          U(J) = -A(J)*U(J-1)/DEN
  30852.          Y(J) = (Y(J)-A(J)*Y(J-1))/DEN
  30853.          BH = BH-V*U(J-1)
  30854.          YM = YM-V*Y(J-1)
  30855.          V = -V*D(J-1)
  30856.   105 CONTINUE
  30857.   106 DEN = B(M-1)-CRT-A(M-1)*D(M-2)
  30858.       D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
  30859.       Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN
  30860.       AM = A(M)-V*D(M-2)
  30861.       BH = BH-V*U(M-2)
  30862.       YM = YM-V*Y(M-2)
  30863.       DEN = BH-AM*D(M-1)
  30864.       IF (ABS(DEN)) 107,108,107
  30865.   107 Y(M) = (YM-AM*Y(M-1))/DEN
  30866.       GO TO 109
  30867.   108 Y(M) = (1.,0.)
  30868.   109 Y(M-1) = Y(M-1)-D(M-1)*Y(M)
  30869.       DO 110 J=2,MM
  30870.          K = M-J
  30871.          Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M)
  30872.   110 CONTINUE
  30873.   111 IF (M1) 112,112,114
  30874.   112 IF (M2) 123,123,113
  30875.   113 RT = BM2(M2)
  30876.       M2 = M2-1
  30877.       GO TO 119
  30878.   114 IF (M2) 115,115,116
  30879.   115 RT = BM1(M1)
  30880.       M1 = M1-1
  30881.       GO TO 119
  30882.   116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117
  30883.   117 RT = BM1(M1)
  30884.       M1 = M1-1
  30885.       GO TO