home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d142 / scisubr.lha / SciSubr / SciSubr.zoo / SSP1.For next >
Text File  |  1987-11-18  |  702KB  |  25,717 lines
  1. C
  2. C    ..................................................................
  3. C
  4. C       SUBROUTINE ABSNT
  5. C
  6. C       PURPOSE
  7. C          TEST MISSING OR ZERO VALUES FOR EACH OBSERVATION IN
  8. C          MATRIX A.
  9. C
  10. C       USAGE
  11. C          CALL ABSNT (A,S,NO,NV)
  12. C
  13. C       DESCRIPTION OF PARAMETERS
  14. C          A  - OBSERVATION MATRIX, NO BY NV
  15. C          S  - OUTPUT VECTOR OF LENGTH NO INDICATING THE FOLLOWING
  16. C               CODES FOR EACH OBSERVATION.
  17. C               1  THERE IS NOT A MISSING OR ZERO VALUE.
  18. C               0  AT LEAST ONE VALUE IS MISSING OR ZERO.
  19. C          NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1.
  20. C          NV - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV MUST BE
  21. C               GREATER THAN OR EQUAL TO 1.
  22. C
  23. C       REMARKS
  24. C          NONE
  25. C
  26. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  27. C          NONE
  28. C
  29. C       METHOD
  30. C          A TEST IS MADE FOR EACH ROW (OBSERVATION) OF THE MATRIX A.
  31. C          IF THERE IS NOT A MISSING OR ZERO VALUE, 1 IS PLACED IN
  32. C          S(J). IF AT LEAST ONE VALUE IS MISSING OR ZERO, 0 IS PLACED
  33. C          IN S(J).
  34. C
  35. C    ..................................................................
  36. C
  37.     SUBROUTINE ABSNT(A,S,NO,NV)
  38.     DIMENSION A(1),S(1)
  39. C
  40.     DO 20 J=1,NO
  41.     IJ=J-NO
  42.     S(J)=1.0
  43.     DO 10 I=1,NV
  44.     IJ=IJ+NO
  45.     IF(A(IJ)) 10,5,10
  46. 5    S(J)=0
  47.     GO TO 20
  48. 10    CONTINUE
  49. 20    CONTINUE
  50.     RETURN
  51.     END
  52. C
  53. C    ..................................................................
  54. C
  55. C       SUBROUTINE ACFI
  56. C
  57. C       PURPOSE
  58. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  59. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
  60. C          VALUES.
  61. C
  62. C       USAGE
  63. C          CALL ACFI (X,ARG,VAL,Y,NDIM,EPS,IER)
  64. C
  65. C       DESCRIPTION OF PARAMETERS
  66. C          X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
  67. C          ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
  68. C                   VALUES OF THE TABLE (POSSIBLY DESTROYED).
  69. C          VAL    - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION
  70. C                   VALUES OF THE TABLE (DESTROYED).
  71. C          Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
  72. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  73. C                   POINTS IN TABLE (ARG,VAL).
  74. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
  75. C                   FOR THE ABSOLUTE ERROR.
  76. C          IER    - A RESULTING ERROR PARAMETER.
  77. C
  78. C       REMARKS
  79. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  80. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  81. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  82. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  83. C              SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
  84. C              PREVIOUS STAGE.
  85. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  86. C              THAN 1.
  87. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  88. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  89. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  90. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  91. C              (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS
  92. C              DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN
  93. C              THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME
  94. C              AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY
  95. C              ELEMENT BY INTERCHANGING OF TABLE POINTS).
  96. C              FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO
  97. C              ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL.
  98. C              DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS
  99. C              CODED IN THE FOLLOWING FORM
  100. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  101. C                       ACCURACY (NO ERROR).
  102. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  103. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  104. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  105. C                       NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
  106. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  107. C                       TABLE. NDIM SHOULD BE INCREASED.
  108. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  109. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  110. C
  111. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  112. C          NONE
  113. C
  114. C       METHOD
  115. C          INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED-
  116. C          DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED
  117. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  118. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  119. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  120. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406.
  121. C
  122. C    ..................................................................
  123. C
  124.     SUBROUTINE ACFI(X,ARG,VAL,Y,NDIM,EPS,IER)
  125. C
  126. C
  127.     DIMENSION ARG(1),VAL(1)
  128.     IER=2
  129.     IF(NDIM)20,20,1
  130. 1    Y=VAL(1)
  131.     DELT2=0.
  132.     IF(NDIM-1)20,20,2
  133. C
  134. C    PREPARATIONS FOR INTERPOLATION LOOP
  135. 2    P2=1.
  136.     P3=Y
  137.     Q2=0.
  138.     Q3=1.
  139. C
  140. C
  141. C    START INTERPOLATION LOOP
  142.     DO 16 I=2,NDIM
  143.     II=0
  144.     P1=P2
  145.     P2=P3
  146.     Q1=Q2
  147.     Q2=Q3
  148.     Z=Y
  149.     DELT1=DELT2
  150.     JEND=I-1
  151. C
  152. C    COMPUTATION OF INVERTED DIFFERENCES
  153. 3    AUX=VAL(I)
  154.     DO 10 J=1,JEND
  155.     H=VAL(I)-VAL(J)
  156.     IF(ABS(H)-1.E-6*ABS(VAL(I)))4,4,9
  157. 4    IF(ARG(I)-ARG(J))5,17,5
  158. 5    IF(J-JEND)8,6,6
  159. C
  160. C    INTERCHANGE ROW I WITH ROW I+II
  161. 6    II=II+1
  162.     III=I+II
  163.     IF(III-NDIM)7,7,19
  164. 7    VAL(I)=VAL(III)
  165.     VAL(III)=AUX
  166.     AUX=ARG(I)
  167.     ARG(I)=ARG(III)
  168.     ARG(III)=AUX
  169.     GOTO 3
  170. C
  171. C    COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1
  172. 8    VAL(I)=1.7E38                                                             0
  173.     GOTO 10
  174. C
  175. C    COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J)
  176. 9    VAL(I)=(ARG(I)-ARG(J))/H
  177. 10    CONTINUE
  178. C    INVERTED DIFFERENCES ARE COMPUTED
  179. C
  180. C    COMPUTATION OF NEW Y
  181.     P3=VAL(I)*P2+(X-ARG(I-1))*P1
  182.     Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1
  183.     IF(Q3)11,12,11
  184. 11    Y=P3/Q3
  185.     GOTO 13
  186. 12    Y=1.7E38                                                                  0
  187. 13    DELT2=ABS(Z-Y)
  188.     IF(DELT2-EPS)19,19,14
  189. 14    IF(I-8)16,15,15
  190. 15    IF(DELT2-DELT1)16,18,18
  191. 16    CONTINUE
  192. C    END OF INTERPOLATION LOOP
  193. C
  194. C
  195.     RETURN
  196. C
  197. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  198. 17    IER=3
  199.     RETURN
  200. C
  201. C    TEST VALUE DELT2 STARTS OSCILLATING
  202. 18    Y=Z
  203.     IER=1
  204.     RETURN
  205. C
  206. C    THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS
  207. 19    IER=0
  208. 20    RETURN
  209.     END
  210. C
  211. C    ..................................................................
  212. C
  213. C       SAMPLE MAIN PROGRAM FOR MATRIX ADDITION - ADSAM
  214. C
  215. C       PURPOSE
  216. C          MATRIX ADDITION SAMPLE PROGRAM
  217. C
  218. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  219. C          MADD
  220. C          MATIN
  221. C          MXOUT
  222. C          LOC
  223. C
  224. C       METHOD
  225. C          TWO INPUT MATRICES ARE READ FROM THE STANDARD INPUT DEVICE.
  226. C          THEY ARE ADDED AND THE RESULTANT MATRIX IS LISTED ON
  227. C          THE STANDARD OUTPUT DEVICE. THIS CAN BE REPEATED FOR ANY
  228. C          NUMBER OF PAIRS OF MATRICES UNTIL A BLANK CARD IS
  229. C          ENCOUNTERED
  230. C
  231. C    ..................................................................
  232. C
  233. C       MATRICES ARE DIMENSIONED FOR 1000 ELEMENTS. THEREFORE, PRODUCT
  234. C       OF NUMBER OF ROWS BY NUMBER OF COLUMNS CANNOT EXCEED 1000.
  235. C
  236. c    DIMENSION A(1000),B(1000),R(1000)
  237. cC
  238. c10    FORMAT(1H1,15HMATRIX ADDITION)
  239. c11    FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4)
  240. c12    FORMAT(1H0,20HEXECUTION TERMINATED)
  241. c13    FORMAT(1H0,32HMATRIX DIMENSIONS NOT CONSISTENT)
  242. c14    FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4)
  243. c15    FORMAT(1H0,18HGO ON TO NEXT CASE)
  244. c16    FORMAT(1H0,11HEND OF CASE)
  245. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  246. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  247. cC
  248. cC    ..................................................................
  249. cC
  250. c    WRITE(6,10)
  251. c20    CALL MATIN(ICODA,A,1000,NA,MA,MSA,IER)
  252. c    IF( NA ) 25,95,25
  253. c25    IF(IER-1) 40,30,35
  254. c30    WRITE(6,11) ICODA
  255. c    GO TO 45
  256. c35    WRITE(6,14) ICODA
  257. c37    WRITE(6,12)
  258. c    GO TO 95
  259. c40    CALL MXOUT(ICODA,A,NA,MA,MSA,60,120,2)
  260. c45    CALL MATIN(ICODB,B,1000,NB,MB,MSB,IER)
  261. c    IF(IER-1) 60,50,55
  262. c50    WRITE(6,11) ICODB
  263. c    WRITE(6,15)
  264. c    GO TO 20
  265. c55    WRITE(6,14) ICODB
  266. c    GO TO 37
  267. c60    IF(NA-NB) 75,70,75
  268. c70    IF(MA-MB) 75,80,75
  269. c75    WRITE(6,13)
  270. c    WRITE(6,15)
  271. c    GO TO 20
  272. c80    CALL MXOUT(ICODB,B,NB,MB,MSB,60,120,2)
  273. c    ICODR=ICODA+ICODB
  274. c    CALL MADD(A,B,R,NA,MA,MSA,MSB)
  275. c    MSR=MSA
  276. c    IF(MSA-MSB) 90,90,85
  277. c85    MSR=MSB
  278. c90    CALL MXOUT(ICODR,R,NA,MA,MSR,60,120,2)
  279. c    WRITE(6,16)
  280. c    GO TO 20
  281. c   95    CONTINUE
  282. c    END
  283. C
  284. C    ..................................................................
  285. C
  286. C       SUBROUTINE AHI
  287. C
  288. C       PURPOSE
  289. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  290. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND
  291. C          DERIVATIVE VALUES.
  292. C
  293. C       USAGE
  294. C          CALL AHI (X,ARG,VAL,Y,NDIM,EPS,IER)
  295. C
  296. C       DESCRIPTION OF PARAMETERS
  297. C          X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
  298. C          ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
  299. C                   VALUES OF THE TABLE (NOT DESTROYED).
  300. C          VAL    - THE INPUT VECTOR (DIMENSION 2*NDIM) OF FUNCTION
  301. C                   AND DERIVATIVE VALUES OF THE TABLE (DESTROYED).
  302. C                   FUNCTION AND DERIVATIVE VALUES MUST BE STORED IN
  303. C                   PAIRS, THAT MEANS BEGINNING WITH FUNCTION VALUE AT
  304. C                   POINT ARG(1) EVERY FUNCTION VALUE MUST BE FOLLOWED
  305. C                   BY THE VALUE OF DERIVATIVE AT THE SAME POINT.
  306. C          Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
  307. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  308. C                   POINTS IN TABLE (ARG,VAL).
  309. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
  310. C                   FOR THE ABSOLUTE ERROR.
  311. C          IER    - A RESULTING ERROR PARAMETER.
  312. C
  313. C       REMARKS
  314. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  315. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  316. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  317. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  318. C              SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
  319. C              PREVIOUS STAGE.
  320. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  321. C              THAN 1.
  322. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  323. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  324. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  325. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  326. C              (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE
  327. C              PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
  328. C              WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
  329. C              ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
  330. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  331. C                       ACCURACY (NO ERROR).
  332. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  333. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  334. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  335. C                       NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
  336. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  337. C                       TABLE. NDIM SHOULD BE INCREASED.
  338. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  339. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  340. C
  341. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  342. C          NONE
  343. C
  344. C       METHOD
  345. C          INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
  346. C          HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
  347. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  348. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  349. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  350. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND
  351. C          GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION,
  352. C          JACM, VOL.11, ISS.3 (1964), PP.352-356.
  353. C
  354. C    ..................................................................
  355. C
  356.     SUBROUTINE AHI(X,ARG,VAL,Y,NDIM,EPS,IER)
  357. C
  358. C
  359.     DIMENSION ARG(1),VAL(1)
  360.     IER=2
  361.     H2=X-ARG(1)
  362.     IF(NDIM-1)2,1,3
  363. 1    Y=VAL(1)+VAL(2)*H2
  364. 2    RETURN
  365. C
  366. C    VECTOR ARG HAS MORE THAN 1 ELEMENT.
  367. C    THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE
  368. C    USED.
  369. 3    I=1
  370.     DO 5 J=2,NDIM
  371.     H1=H2
  372.     H2=X-ARG(J)
  373.     Y=VAL(I)
  374.     VAL(I)=Y+VAL(I+1)*H1
  375.     H=H1-H2
  376.     IF(H)4,13,4
  377. 4    VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H
  378. 5    I=I+2
  379.     VAL(I)=VAL(I)+VAL(I+1)*H2
  380. C    END OF FIRST STEP
  381. C
  382. C    PREPARE AITKEN SCHEME
  383.     DELT2=0.
  384.     IEND=I-1
  385. C
  386. C    START AITKEN-LOOP
  387.     DO 9 I=1,IEND
  388.     DELT1=DELT2
  389.     Y=VAL(1)
  390.     M=(I+3)/2
  391.     H1=ARG(M)
  392.     DO 6 J=1,I
  393.     K=I+1-J
  394.     L=(K+1)/2
  395.     H=ARG(L)-H1
  396.     IF(H)6,14,6
  397. 6    VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H
  398.     DELT2=ABS(Y-VAL(1))
  399.     IF(DELT2-EPS)11,11,7
  400. 7    IF(I-5)9,8,8
  401. 8    IF(DELT2-DELT1)9,12,12
  402. 9    CONTINUE
  403. C    END OF AITKEN-LOOP
  404. C
  405. 10    Y=VAL(1)
  406.     RETURN
  407. C
  408. C    THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS
  409. 11    IER=0
  410.     GOTO 10
  411. C
  412. C    TEST VALUE DELT2 STARTS OSCILLATING
  413. 12    IER=1
  414.     RETURN
  415. C
  416. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  417. 13    Y=VAL(1)
  418. 14    IER=3
  419.     RETURN
  420.     END
  421. C
  422. C    ..................................................................
  423. C
  424. C       SUBROUTINE ALI
  425. C
  426. C       PURPOSE
  427. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  428. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
  429. C          VALUES.
  430. C
  431. C       USAGE
  432. C          CALL ALI (X,ARG,VAL,Y,NDIM,EPS,IER)
  433. C
  434. C       DESCRIPTION OF PARAMETERS
  435. C          X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
  436. C          ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
  437. C                   VALUES OF THE TABLE (NOT DESTROYED).
  438. C          VAL    - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION
  439. C                   VALUES OF THE TABLE (DESTROYED).
  440. C          Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
  441. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  442. C                   POINTS IN TABLE (ARG,VAL).
  443. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
  444. C                   FOR THE ABSOLUTE ERROR.
  445. C          IER    - A RESULTING ERROR PARAMETER.
  446. C
  447. C       REMARKS
  448. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  449. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  450. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  451. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  452. C              SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
  453. C              PREVIOUS STAGE.
  454. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  455. C              THAN 1.
  456. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  457. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  458. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  459. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  460. C              (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE
  461. C              PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
  462. C              WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
  463. C              ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
  464. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  465. C                       ACCURACY (NO ERROR).
  466. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  467. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  468. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  469. C                       NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY
  470. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  471. C                       TABLE. NDIM SHOULD BE INCREASED.
  472. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  473. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  474. C
  475. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  476. C          NONE
  477. C
  478. C       METHOD
  479. C          INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
  480. C          LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
  481. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  482. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  483. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  484. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50.
  485. C
  486. C    ..................................................................
  487. C
  488.     SUBROUTINE ALI(X,ARG,VAL,Y,NDIM,EPS,IER)
  489. C
  490. C
  491.     DIMENSION ARG(1),VAL(1)
  492.     IER=2
  493.     DELT2=0.
  494.     IF(NDIM-1)9,7,1
  495. C
  496. C    START OF AITKEN-LOOP
  497. 1    DO 6 J=2,NDIM
  498.     DELT1=DELT2
  499.     IEND=J-1
  500.     DO 2 I=1,IEND
  501.     H=ARG(I)-ARG(J)
  502.     IF(H)2,13,2
  503. 2    VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H
  504.     DELT2=ABS(VAL(J)-VAL(IEND))
  505.     IF(J-2)6,6,3
  506. 3    IF(DELT2-EPS)10,10,4
  507. 4    IF(J-5)6,5,5
  508. 5    IF(DELT2-DELT1)6,11,11
  509. 6    CONTINUE
  510. C    END OF AITKEN-LOOP
  511. C
  512. 7    J=NDIM
  513. 8    Y=VAL(J)
  514. 9    RETURN
  515. C
  516. C    THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS
  517. 10    IER=0
  518.     GOTO 8
  519. C
  520. C    TEST VALUE DELT2 STARTS OSCILLATING
  521. 11    IER=1
  522. 12    J=IEND
  523.     GOTO 8
  524. C
  525. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  526. 13    IER=3
  527.     GOTO 12
  528.     END
  529. C
  530. C    ..................................................................
  531. C
  532. C       SAMPLE MAIN PROGRAM FOR ANALYSIS OF VARIANCE - ANOVA
  533. C
  534. C       PURPOSE
  535. C          (1) READ THE PROBLEM PARAMETER CARD FOR ANALYSIS OF VARI-
  536. C          ANCE, (2) CALL THE SUBROUTINES FOR THE CALCULATION OF SUMS
  537. C          OF SQUARES, DEGREES OF FREEDOM AND MEAN SQUARE, AND
  538. C          (3) PRINT FACTOR LEVELS, GRAND MEAN AND ANALYSIS OF VARI-
  539. C          ANCE TABLE.
  540. C
  541. C       REMARKS
  542. C          THE PROGRAM HANDLES ONLY COMPLETE FACTORIAL DESIGNS.  THERE-
  543. C          FORE, OTHER EXPERIMENTAL DESIGN MUST BE REDUCED TO THIS FORM
  544. C          PRIOR TO THE USE OF THE PROGRAM.
  545. C
  546. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  547. C          AVDAT
  548. C          AVCAL
  549. C          MEANQ
  550. C
  551. C       METHOD
  552. C          THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
  553. C          HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
  554. C          EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
  555. C          1962, CHAPTER 20.
  556. C
  557. C    ..................................................................
  558. C
  559. C    THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
  560. C    CUMULATIVE PRODUCT OF EACH FACTOR LEVEL PLUS ONE (LEVEL(I)+1)
  561. C    FOR I=1 TO K, WHERE K IS THE NUMBER OF FACTORS..
  562. C
  563. c       DIMENSION X(3000)
  564. cC
  565. cC    THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
  566. cC    NUMBER OF FACTORS..
  567. cC
  568. c       DIMENSION HEAD(6),LEVEL(6),ISTEP(6),KOUNT(6),LASTS(6)
  569. cC
  570. cC    THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO 2 TO
  571. cC    THE K-TH POWER MINUS 1, ((2**K)-1)..
  572. cC
  573. c       DIMENSION SUMSQ(63),NDF(63),SMEAN(63)
  574. cC
  575. cC    THE FOLLOWING DIMENSION IS USED TO PRINT FACTOR LABELS IN ANALYSIS
  576. cC    OF VARIANCE TABLE AND IS FIXED..
  577. cC
  578. c       DIMENSION FMT(15)
  579. cC    ..................................................................
  580. cC
  581. cC       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  582. cC       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  583. cC       STATEMENT WHICH FOLLOWS.
  584. cC
  585. cC    DOUBLE PRECISION X,GMEAN,SUMSQ,SMEAN,SUM
  586. cC
  587. cC       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  588. cC       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  589. cC       ROUTINE.
  590. cC
  591. cC       ...............................................................
  592. cC
  593. c1    FORMAT(A4,A2,I2,A4,3X,11(A1,I4)/(A1,I4,A1,I4,A1,I4,A1,I4,A1,I4))
  594. c2    FORMAT(26H1ANALYSIS OF VARIANCE.....A4,A2//)
  595. c3    FORMAT(18H0LEVELS OF FACTORS/(3X,A1,7X,I4))
  596. c4    FORMAT(1H0//11H GRAND MEANF20.5////)
  597. c5    FORMAT(10H0SOURCE OF18X,7HSUMS OF10X,10HDEGREES OF9X,4HMEAN/10H VA
  598. c     1RIATION18X,7HSQUARES11X,7HFREEDOM10X,7HSQUARES/)
  599. c6    FORMAT(1H 15A1,F20.5,10X,I6,F20.5)
  600. c7    FORMAT(6H TOTAL10X,F20.5,10X,I6)
  601. c8    FORMAT(12F6.0)
  602. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  603. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  604. cC
  605. cC    ..................................................................
  606. cC
  607. cC    READ PROBLEM PARAMETER CARD
  608. cC
  609. c    LOGICAL EOF
  610. c    CALL CHKEOF (EOF)
  611. c100    READ (5,1) PR,PR1,K,BLANK,(HEAD(I),LEVEL(I),I=1,K)
  612. c    IF (EOF) GOTO 999
  613. cC      PR.....PROBLEM NUMBER (MAY BE ALPHAMERIC)
  614. cC      PR1....PROBLEM NUMBER (CONTINUED)
  615. cC      K......NUMBER OF FACTORS
  616. cC      BLANK..BLANK FIELD
  617. cC      HEAD...FACTOR LABELS
  618. cC      LEVEL..LEVELS OF FACTORS
  619. cC
  620. cC    PRINT PROBLEM NUMBER AND LEVELS OF FACTORS
  621. cC
  622. c    WRITE (6,2) PR,PR1
  623. c    WRITE (6,3) (HEAD(I),LEVEL(I),I=1,K)
  624. cC
  625. cC    CALCULATE TOTAL NUMBER OF DATA
  626. cC
  627. c    N=LEVEL(1)
  628. c    DO 102 I=2,K
  629. c102    N=N*LEVEL(I)
  630. cC
  631. cC    READ ALL INPUT DATA
  632. cC
  633. c    READ (5,8) (X(I),I=1,N)
  634. cC
  635. c    CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
  636. c    CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
  637. c    CALL MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,ISTEP,KOUNT,LASTS)
  638. cC
  639. cC    PRINT GRAND MEAN
  640. cC
  641. c    WRITE (6,4) GMEAN
  642. cC
  643. cC    PRINT ANALYSIS OF VARIANCE TABLE
  644. cC
  645. c    WRITE (6,5)
  646. c    LL=(2**K)-1
  647. c    ISTEP(1)=1
  648. c    DO 105 I=2,K
  649. c105    ISTEP(I)=0
  650. c    DO 110 I=1,15
  651. c110    FMT(I)=BLANK
  652. c    NN=0
  653. c    SUM=0.0
  654. c120    NN=NN+1
  655. c    L=0
  656. c    DO 140 I=1,K
  657. c    FMT(I)=BLANK
  658. c    IF(ISTEP(I)) 130, 140, 130
  659. c130    L=L+1
  660. c    FMT(L)=HEAD(I)
  661. c140    CONTINUE
  662. c    WRITE (6,6) (FMT(I),I=1,15),SUMSQ(NN),NDF(NN),SMEAN(NN)
  663. c    SUM=SUM+SUMSQ(NN)
  664. c    IF(NN-LL) 145, 170, 170
  665. c145    DO 160 I=1,K
  666. c    IF(ISTEP(I)) 147, 150, 147
  667. c147    ISTEP(I)=0
  668. c    GO TO 160
  669. c150    ISTEP(I)=1
  670. c    GO TO 120
  671. c160    CONTINUE
  672. c170    N=N-1
  673. c    WRITE (6,7) SUM,N
  674. c    GO TO 100
  675. c999    STOP
  676. c    END
  677. C
  678. C    ..................................................................
  679. C
  680. C       SUBROUTINE APCH
  681. C
  682. C       PURPOSE
  683. C          SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF
  684. C          CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION
  685. C
  686. C       USAGE
  687. C          CALL APCH(DATI,N,IP,XD,X0,WORK,IER)
  688. C
  689. C       DESCRIPTION OF PARAMETERS
  690. C          DATI  - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1)
  691. C                  CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE
  692. C                  FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT
  693. C                  VALUES. THE CONTENT OF VECTOR DATI REMAINS
  694. C                  UNCHANGED.
  695. C          N     - NUMBER OF GIVEN POINTS
  696. C          IP    - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF
  697. C                  CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS
  698. C                  IP SHOULD NOT EXCEED N
  699. C          XD    - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR
  700. C                  TRANSFORMATION OF ARGUMENT RANGE
  701. C          X0    - RESULTANT ADDITIVE CONSTANT FOR LINEAR
  702. C                  TRANSFORMATION OF ARGUMENT RANGE
  703. C          WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2
  704. C                  ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
  705. C                  MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM
  706. C                  FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE
  707. C                  AND SQUARE SUM OF FUNCTION VALUES
  708. C          IER   - RESULTING ERROR PARAMETER
  709. C                  IER =-1 MEANS FORMAL ERRORS IN DIMENSION
  710. C                  IER = 0 MEANS NO ERRORS
  711. C                  IER = 1 MEANS COINCIDING ARGUMENTS
  712. C
  713. C       REMARKS
  714. C          NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS
  715. C          NOT POSITIVE.
  716. C          EXECUTION OF SUBROUTINE APCH IS A PREPARATORY STEP FOR
  717. C          CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS
  718. C          IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE APFS
  719. C
  720. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  721. C          NONE
  722. C
  723. C       METHOD
  724. C          THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV
  725. C          POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM.
  726. C          THE METHOD IS DISCUSSED IN THE ARTICLE
  727. C          A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED
  728. C          DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227.
  729. C
  730. C    ..................................................................
  731. C
  732.     SUBROUTINE APCH(DATI,N,IP,XD,X0,WORK,IER)
  733. C
  734. C
  735. C      DIMENSIONED DUMMY VARIABLES
  736.     DIMENSION DATI(1),WORK(1)
  737. C
  738. C       CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
  739.     IF(N-1)19,20,1
  740. 1    IF(IP)19,19,2
  741. C
  742. C       SEARCH SMALLEST AND LARGEST ARGUMENT
  743. 2    IF(IP-N)3,3,19
  744. 3    XA=DATI(1)
  745.     X0=XA
  746.     XE=0.
  747.     DO 7 I=1,N
  748.     XM=DATI(I)
  749.     IF(XA-XM)5,5,4
  750. 4    XA=XM
  751. 5    IF(X0-XM)6,7,7
  752. 6    X0=XM
  753. 7    CONTINUE
  754. C
  755. C       INITIALIZE CALCULATION OF NORMAL EQUATIONS
  756.     XD=X0-XA
  757.     M=(IP*(IP+1))/2
  758.     IEND=M+IP+1
  759.     MT2=IP+IP
  760.     MT2M=MT2-1
  761. C
  762. C       SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
  763.     DO 8 I=1,IP
  764.     J=MT2-I
  765.     WORK(J)=0.
  766.     WORK(I)=0.
  767.     K=M+I
  768. 8    WORK(K)=0.
  769. C
  770. C       CHECK FOR DEGENERATE ARGUMENT RANGE
  771.     IF(XD)20,20,9
  772. C
  773. C       CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS
  774. 9    X0=-(X0+XA)/XD
  775.     XD=2./XD
  776.     SUM=0.
  777. C
  778. C       START GREAT LOOP OVER ALL GIVEN POINTS
  779.     DO 15 I=1,N
  780.     T=DATI(I)*XD+X0
  781.     J=I+N
  782.     DF=DATI(J)
  783. C
  784. C       CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS
  785. C       FOR ARGUMENT T
  786.     XA=1.
  787.     XM=T
  788.     IF(DATI(2*N+1))11,11,10
  789. 10    J=J+N
  790.     XA=DATI(J)
  791.     XM=T*XA
  792. 11    T=T+T
  793.     SUM=SUM+DF*DF*XA
  794.     DF=DF+DF
  795.     J=1
  796. 12    K=M+J
  797.     WORK(K)=WORK(K)+DF*XA
  798. 13    WORK(J)=WORK(J)+XA
  799.     IF(J-MT2M)14,15,15
  800. 14    J=J+1
  801.     XE=T*XM-XA
  802.     XA=XM
  803.     XM=XE
  804.     IF(J-IP)12,12,13
  805. 15    CONTINUE
  806.     WORK(IEND)=SUM+SUM
  807. C
  808. C       CALCULATE MATRIX OF NORMAL EQUATIONS
  809.     LL=M
  810.     KK=MT2M
  811.     JJ=1
  812.     K=KK
  813.     DO 18 J=1,M
  814.     WORK(LL)=WORK(K)+WORK(JJ)
  815.     LL=LL-1
  816.     IF(K-JJ)16,16,17
  817. 16    KK=KK-2
  818.     K=KK
  819.     JJ=1
  820.     GOTO 18
  821. 17    JJ=JJ+1
  822.     K=K-1
  823. 18    CONTINUE
  824.     IER=0
  825.     RETURN
  826. C
  827. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  828. 19    IER=-1
  829.     RETURN
  830. C
  831. C       ERROR RETURN IN CASE OF COINCIDING ARGUMENTS
  832. 20    IER=1
  833.     RETURN
  834.     END
  835. C
  836. C    ..................................................................
  837. C
  838. C       SUBROUTINE APFS
  839. C
  840. C       PURPOSE
  841. C          PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL
  842. C          EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT
  843. C          OPTIONALLY
  844. C
  845. C       USAGE
  846. C          CALL APFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
  847. C
  848. C       DESCRIPTION OF PARAMETERS
  849. C          WORK  - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED
  850. C                  COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE.
  851. C                  THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP
  852. C                  LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK
  853. C                  CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0
  854. C                  THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G.
  855. C                  BY SUBROUTINE APLL.
  856. C                  THE GIVEN MATRIX IS FACTORED IN THE FORM
  857. C                  TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS
  858. C                  DIVIDED BY TRANSPOSE(T).
  859. C                  THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF
  860. C                  IOP EQUALS ZERO.
  861. C                  IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE
  862. C                  STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF
  863. C                  CORRESPONDING DIMENSION AND E0  IS REPLACED BY THE
  864. C                  SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES.
  865. C                  THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2
  866. C          IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
  867. C                  SQUARES FIT
  868. C          IRES  - DIMENSION OF CALCULATED LEAST SQUARES FIT.
  869. C                  LET N1, N2, DENOTE THE FOLLOWING NUMBERS
  870. C                  N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF
  871. C                       SIGNIFICANCE WAS INDICATED DURING FACTORIZATION
  872. C                  N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF
  873. C                       THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ)
  874. C                  THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE
  875. C                  AND  IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE
  876. C          IOP   - INPUT PARAMETER FOR SELECTION OF OPERATION
  877. C                  IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF
  878. C                          THE RIGHT HAND SIDE BY TRANSPOSE(T) AND
  879. C                          CALCULATION OF THE SQUARE SUM OF ERRORS IS
  880. C                          PERFORMED ONLY
  881. C                  IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES
  882. C                          IS CALCULATED ADDITIONALLY
  883. C                  IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE
  884. C                          UP TO IRES ARE CALCULATED ADDITIONALLY
  885. C          EPS   - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
  886. C                  A SENSIBLE VALUE IS BETWEEN 1.E-3 AND 1.E-6
  887. C          ETA   - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF
  888. C                  ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-6
  889. C          IER   - RESULTANT ERROR PARAMETER
  890. C                  IER =-1 MEANS NONPOSITIVE IP
  891. C                  IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED
  892. C                          AND SPECIFIED TOLERANCE OF ERRORS REACHED
  893. C                  IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR
  894. C                          SPECIFIED TOLERANCE OF ERRORS NOT REACHED
  895. C
  896. C       REMARKS
  897. C          THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF
  898. C          SIGNIFICANCE IS TOL=ABS(EPS*WORK(1)).
  899. C          THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF
  900. C          ERRORS IS ABS(ETA*FSQ).
  901. C          IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2.
  902. C          IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2.
  903. C          IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN
  904. C          ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE
  905. C
  906. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  907. C          NONE
  908. C
  909. C       METHOD
  910. C          CALCULATION OF THE LEAST SQUARES FITS IS DONE USING
  911. C          CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION.
  912. C          THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH
  913. C          RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE
  914. C          TOLERANCE TOL=ABS(EPS*WORK(1)).
  915. C          IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A
  916. C          SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED.
  917. C          IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS
  918. C          TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE
  919. C          ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION
  920. C          FOR LOSS OF SIGNIFICANCE
  921. C
  922. C    ..................................................................
  923. C
  924.     SUBROUTINE APFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
  925. C
  926. C
  927. C       DIMENSIONED DUMMY VARIABLES
  928.     DIMENSION WORK(1)
  929.     IRES=0
  930. C
  931. C       TEST OF SPECIFIED DIMENSION
  932.     IF(IP)1,1,2
  933. C
  934. C       ERROR RETURN IN CASE OF ILLEGAL DIMENSION
  935. 1    IER=-1
  936.     RETURN
  937. C
  938. C       INITIALIZE FACTORIZATION PROCESS
  939. 2    IPIV=0
  940.     IPP1=IP+1
  941.     IER=1
  942.     ITE=IP*IPP1/2
  943.     IEND=ITE+IPP1
  944.     TOL=ABS(EPS*WORK(1))
  945.     TEST=ABS(ETA*WORK(IEND))
  946. C
  947. C       START LOOP OVER ALL ROWS OF WORK
  948.     DO 11 I=1,IP
  949.     IPIV=IPIV+I
  950.     JA=IPIV-IRES
  951.     JE=IPIV-1
  952. C
  953. C       FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS
  954.     JK=IPIV
  955.     DO 9 K=I,IPP1
  956.     SUM=0.
  957.     IF(IRES)5,5,3
  958. 3    JK=JK-IRES
  959.     DO 4 J=JA,JE
  960.     SUM=SUM+WORK(J)*WORK(JK)
  961. 4    JK=JK+1
  962. 5    IF(JK-IPIV)6,6,8
  963. C
  964. C       TEST FOR LOSS OF SIGNIFICANCE
  965. 6    SUM=WORK(IPIV)-SUM
  966.     IF(SUM-TOL)12,12,7
  967. 7    SUM=SQRT(SUM)
  968.     WORK(IPIV)=SUM
  969.     PIV=1./SUM
  970.     GOTO 9
  971. C
  972. C       UPDATE OFF-DIAGONAL TERMS
  973. 8    SUM=(WORK(JK)-SUM)*PIV
  974.     WORK(JK)=SUM
  975. 9    JK=JK+K
  976. C
  977. C       UPDATE SQUARE SUM OF ERRORS
  978.     WORK(IEND)=WORK(IEND)-SUM*SUM
  979. C
  980. C       RECORD ADDRESS OF LAST PIVOT ELEMENT
  981.     IRES=IRES+1
  982.     IADR=IPIV
  983. C
  984. C       TEST FOR TOLERABLE ERROR IF SPECIFIED
  985.     IF(IOP)10,11,11
  986. 10    IF(WORK(IEND)-TEST)13,13,11
  987. 11    CONTINUE
  988.     IF(IOP)12,22,12
  989. C
  990. C       PERFORM BACK SUBSTITUTION IF SPECIFIED
  991. 12    IF(IOP)14,23,14
  992. 13    IER=0
  993. 14    IPIV=IRES
  994. 15    IF(IPIV)23,23,16
  995. 16    SUM=0.
  996.     JA=ITE+IPIV
  997.     JJ=IADR
  998.     JK=IADR
  999.     K=IPIV
  1000.     DO 19 I=1,IPIV
  1001.     WORK(JK)=(WORK(JA)-SUM)/WORK(JJ)
  1002.     IF(K-1)20,20,17
  1003. 17    JE=JJ-1
  1004.     SUM=0.
  1005.     DO 18 J=K,IPIV
  1006.     SUM=SUM+WORK(JK)*WORK(JE)
  1007.     JK=JK+1
  1008. 18    JE=JE+J
  1009.     JK=JE-IPIV
  1010.     JA=JA-1
  1011.     JJ=JJ-K
  1012. 19    K=K-1
  1013. 20    IF(IOP/2)21,23,21
  1014. 21    IADR=IADR-IPIV
  1015.     IPIV=IPIV-1
  1016.     GOTO 15
  1017. C
  1018. C       NORMAL RETURN
  1019. 22    IER=0
  1020. 23    RETURN
  1021.     END
  1022. C
  1023. C    ..................................................................
  1024. C
  1025. C       SUBROUTINE APLL
  1026. C
  1027. C       PURPOSE
  1028. C          SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT
  1029. C          TO A GIVEN DISCRETE FUNCTION
  1030. C
  1031. C       USAGE
  1032. C          CALL APLL(FFCT,N,IP,P,WORK,DATI,IER)
  1033. C          SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT
  1034. C
  1035. C       DESCRIPTION OF PARAMETERS
  1036. C          FFCT  - USER CODED SUBROUTINE WHICH MUST BE DECLARED
  1037. C                  EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED
  1038. C                  CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS
  1039. C                  THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR
  1040. C                  THE I-TH ARGUMENT IN P(1) UP TO P(IP)
  1041. C                  FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1)
  1042. C                  N IS THE NUMBER OF ALL POINTS
  1043. C                  DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY
  1044. C                  NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI
  1045. C                  WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT
  1046. C                  IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT
  1047. C          N     - NUMBER OF GIVEN POINTS
  1048. C          IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
  1049. C                  SQUARES FIT
  1050. C                  IP SHOULD NOT EXCEED N
  1051. C          P     - WORKING STORAGE OF DIMENSION IP+1, WHICH
  1052. C                  IS USED AS INTERFACE BETWEEN APLL AND THE USER
  1053. C                  CODED SUBROUTINE FFCT
  1054. C          WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2.
  1055. C                  ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
  1056. C                  MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM,
  1057. C                  I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE.
  1058. C                  THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT
  1059. C                  HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS
  1060. C                  THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES
  1061. C          DATI  - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN
  1062. C                  MAIN LINE AND SUBROUTINE FFCT.
  1063. C          IER   - RESULTING ERROR PARAMETER
  1064. C                  IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS
  1065. C                  IER = 0 MEANS NO ERRORS
  1066. C                  IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT
  1067. C
  1068. C       REMARKS
  1069. C          TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES
  1070. C          BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR
  1071. C          PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN
  1072. C          SUBROUTINE APLL. ADDITIONAL COMPONENTS OF IER MAY BE
  1073. C          INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH.
  1074. C          IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A
  1075. C          VECTOR IN HIS MAINLINE.
  1076. C          EXECUTION OF SUBROUTINE APLL IS A PREPARATORY STEP FOR
  1077. C          CALCULATION OF THE LINEAR LEAST SQUARES FIT.
  1078. C          NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE APFS
  1079. C
  1080. C      SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  1081. C          THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER
  1082. C
  1083. C       METHOD
  1084. C          HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES
  1085. C          AND WEIGHTS) IS COMPLETELY LEFT TO THE USER
  1086. C          ESSENTIALLY HE HAS THREE CHOICES
  1087. C          (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  1088. C              ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I.
  1089. C          (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  1090. C              ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS
  1091. C              REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI
  1092. C              (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1
  1093. C              LOCATIONS).
  1094. C              ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE
  1095. C              BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE
  1096. C              STORAGE FOR THE DATA SET IN COMMON.
  1097. C          (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  1098. C              ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY
  1099. C              ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM
  1100. C              ONE UP TO N WITHIN APLL
  1101. C
  1102. C    ..................................................................
  1103. C
  1104.     SUBROUTINE APLL(FFCT,N,IP,P,WORK,DATI,IER)
  1105. C
  1106. C
  1107. C       DIMENSIONED DUMMY VARIABLES
  1108.     DIMENSION P(1),WORK(1),DATI(1),IER(1)
  1109. C
  1110. C       CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
  1111.     IF(N)10,10,1
  1112. 1    IF(IP)10,10,2
  1113. 2    IF(N-IP)10,3,3
  1114. C
  1115. C       SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
  1116. 3    IPP1=IP+1
  1117.     M=IPP1*(IP+2)/2
  1118.     IER(1)=0
  1119.     DO 4 I=1,M
  1120. 4    WORK(I)=0.
  1121. C
  1122. C       START GREAT LOOP OVER ALL GIVEN POINTS
  1123.     DO 8 I=1,N
  1124.     CALL FFCT(I,N,IP,P,DATI,WGT,IER)
  1125.     IF(IER(1))9,5,9
  1126. 5    J=0
  1127.     DO 7 K=1,IPP1
  1128.     AUX=P(K)*WGT
  1129.     DO 6 L=1,K
  1130.     J=J+1
  1131. 6    WORK(J)=WORK(J)+P(L)*AUX
  1132. 7    CONTINUE
  1133. 8    CONTINUE
  1134. C
  1135. C       NORMAL RETURN
  1136. 9    RETURN
  1137. C
  1138. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  1139. 10    IER(1)=-1
  1140.     RETURN
  1141.     END
  1142. C
  1143. C    ..................................................................
  1144. C
  1145. C       SUBROUTINE APMM
  1146. C
  1147. C       PURPOSE
  1148. C          APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR
  1149. C          COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE
  1150. C          OF CHEBYSHEV.
  1151. C
  1152. C       USAGE
  1153. C          CALL APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
  1154. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE
  1155. C          CALLING PROGRAM.
  1156. C
  1157. C       DESCRIPTION OF PARAMETERS
  1158. C          FCT    - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER.
  1159. C                   IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR
  1160. C                   ARGUMENT VALUE X.
  1161. C                   USAGE
  1162. C                      CALL FCT(Y,X,K)
  1163. C                   DESCRIPTION OF PARAMETERS
  1164. C                      Y   - RESULT VECTOR OF DIMENSION M CONTAINING
  1165. C                            THE VALUES OF GIVEN CONTINUOUS FUNCTIONS
  1166. C                            FOR GIVEN ARGUMENT X
  1167. C                      X   - ARGUMENT VALUE
  1168. C                      K   - AN INTEGER VALUE WHICH IS EQUAL TO M-1
  1169. C                   REMARKS
  1170. C                      IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED
  1171. C                      CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO-
  1172. C                      MIALS IS DESIRED SUBROUTINES CNP, CSP, LEP,
  1173. C                      LAP, HEP, RESPECTIVELY FROM SSP COULD BE USED.
  1174. C          N      - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH
  1175. C                   IS TO BE APPROXIMATED
  1176. C          M      - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH
  1177. C                   THE APPROXIMATING FUNCTION IS CONSTRUCTED.
  1178. C          TOP    - VECTOR OF DIMENSION 3*N.
  1179. C                   ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N)
  1180. C                   THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP
  1181. C                   TO TOP(2*N) THE CORRESPONDING NODES
  1182. C                   ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N)
  1183. C                   THE ERRORS AT THOSE N NODES.
  1184. C                   OTHER VALUES OF TOP ARE SCRATCH.
  1185. C          IHE    - INTEGER VECTOR OF DIMENSION 3*M+4*N+6
  1186. C          PIV    - VECTOR OF DIMENSION 3*M+6.
  1187. C                   ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE
  1188. C                   RESULTING COEFFICIENTS OF LINEAR APPROXIMATION.
  1189. C          T      - AUXILIARY VECTOR OF DIMENSION (M+2)*(M+2)
  1190. C          ITER   - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF
  1191. C                   ITERATIONS NEEDED
  1192. C          IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
  1193. C                   FORM
  1194. C                    IER=0  - NO ERROR
  1195. C                    IER=1  - THE NUMBER OF ITERATIONS HAS REACHED
  1196. C                             THE INTERNAL MAXIMUM N+M
  1197. C                    IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA-
  1198. C                             METER M OR N OR SINCE AT SOME ITERATION
  1199. C                             NO SUITABLE PIVOT COULD BE FOUND
  1200. C
  1201. C       REMARKS
  1202. C          NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR
  1203. C          N LESS THAN 2.
  1204. C
  1205. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  1206. C          THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER.
  1207. C
  1208. C       METHOD
  1209. C          THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY
  1210. C          LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF
  1211. C          CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS-
  1212. C          FORMED INTO A LINEAR PROGRAMMING PROBLEM. APMM USES A
  1213. C          REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL
  1214. C          PROBLEM. FOR REFERENCE, SEE
  1215. C          I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND
  1216. C          L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET,
  1217. C          NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306.
  1218. C
  1219. C    ..................................................................
  1220. C
  1221.     SUBROUTINE APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
  1222. C
  1223. C
  1224.     DIMENSION TOP(1),IHE(1),PIV(1),T(1)
  1225.     DOUBLE PRECISION DSUM
  1226. C
  1227. C       TEST ON WRONG INPUT PARAMETERS N AND M
  1228.     IER=-1
  1229.     IF (N-1) 81,81,1
  1230. 1    IF(M) 81,81,2
  1231. C
  1232. C       INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU
  1233. 2    IER=0
  1234. C
  1235. C       PREPARE TOP-ROW TOP
  1236.     DO 3 I=1,N
  1237.     K=I+N
  1238.     J=K+N
  1239.     TOP(J)=TOP(K)
  1240. 3    TOP(K)=-TOP(I)
  1241. C
  1242. C       PREPARE INVERSE TRANSFORMATION MATRIX T
  1243.     L=M+2
  1244.     LL=L*L
  1245.     DO 4 I=1,LL
  1246. 4    T(I)=0.
  1247.     K=1
  1248.     J=L+1
  1249.     DO 5 I=1,L
  1250.     T(K)=1.
  1251. 5    K=K+J
  1252. C
  1253. C       PREPARE INDEX-VECTOR IHE
  1254.     DO 6 I=1,L
  1255.     K=I+L
  1256.     J=K+L
  1257.     IHE(I)=0
  1258.     IHE(K)=I
  1259. 6    IHE(J)=1-I
  1260.     NAN=N+N
  1261.     K=L+L+L
  1262.     J=K+NAN
  1263.     DO 7 I=1,NAN
  1264.     K=K+1
  1265.     IHE(K)=I
  1266.     J=J+1
  1267. 7    IHE(J)=I
  1268. C
  1269. C       SET COUNTER ITER FOR ITERATION-STEPS
  1270.     ITER=-1
  1271. 8    ITER=ITER+1
  1272. C
  1273. C       TEST FOR MAXIMUM ITERATION-STEPS
  1274.     IF(N+M-ITER) 9,9,10
  1275. 9    IER=1
  1276.     GO TO 69
  1277. C
  1278. C       DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP
  1279. 10    ISE=0
  1280.     IPIV=0
  1281.     K=L+L+L
  1282.     SAVE=0.
  1283. C
  1284. C       START TOP-LOOP
  1285.     DO 14 I=1,NAN
  1286.     IDO=K+I
  1287.     HELP=TOP(I)
  1288.     IF(HELP-SAVE) 12,12,11
  1289. 11    SAVE=HELP
  1290.     IPIV=I
  1291. 12    IF(IHE(IDO)) 14,13,14
  1292. 13    ISE=I
  1293. 14    CONTINUE
  1294. C       END OF TOP-LOOP
  1295. C
  1296. C       IS OPTIMAL TABLEAU REACHED
  1297.     IF(IPIV) 69,69,15
  1298. C
  1299. C       DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE
  1300. 15    ILAB=1
  1301.     IND=0
  1302.     J=ISE
  1303.     IF(J) 21,21,34
  1304. C
  1305. C       TRANSFER K-TH COLUMN FROM T TO PIV
  1306. 16    K=(K-1)*L
  1307.     DO 17 I=1,L
  1308.     J=L+I
  1309.     K=K+1
  1310. 17    PIV(J)=T(K)
  1311. C
  1312. C       IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT
  1313. 18    IF(ISE) 22,22,19
  1314. 19    ISE=-ISE
  1315. C
  1316. C       TRANSFER COLUMNS IN PIV
  1317.     J=L+1
  1318.     IDO=L+L
  1319.     DO 20 I=J,IDO
  1320.     K=I+L
  1321. 20    PIV(K)=PIV(I)
  1322. 21    J=IPIV
  1323.     GO TO 34
  1324. C
  1325. C       SEARCH PIVOT-ELEMENT PIV(IND)
  1326. 22    SAVE=1.E38
  1327.     IDO=0
  1328.     K=L+1
  1329.     LL=L+L
  1330.     IND=0
  1331. C
  1332. C       START PIVOT-LOOP
  1333.     DO 29 I=K,LL
  1334.     J=I+L
  1335.     HELP=PIV(I)
  1336.     IF(HELP) 29,29,23
  1337. 23    HELP=-HELP
  1338.     IF(ISE) 26,24,26
  1339. 24    IF(IHE(J)) 27,25,27
  1340. 25    IDO=I
  1341.     GO TO 29
  1342. 26    HELP=-PIV(J)/HELP
  1343. 27    IF(HELP-SAVE) 28,29,29
  1344. 28    SAVE=HELP
  1345.     IND=I
  1346. 29    CONTINUE
  1347. C       END OF PIVOT-LOOP
  1348. C
  1349. C       TEST FOR SUITABLE PIVOT-ELEMENT
  1350.     IF(IND) 30,30,32
  1351. 30    IF(IDO) 68,68,31
  1352. 31    IND=IDO
  1353. C       PIVOT-ELEMENT IS STORED IN PIV(IND)
  1354. C
  1355. C       COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI
  1356. 32    REPI=1./PIV(IND)
  1357.     IND=IND-L
  1358. C
  1359. C       UPDATE THE TOP-ROW TOP OF THE TABLEAU
  1360.     ILAB=0
  1361.     SAVE=-TOP(IPIV)*REPI
  1362.     TOP(IPIV)=SAVE
  1363. C
  1364. C       INITIALIZE J AS COUNTER FOR TOP-LOOP
  1365.     J=NAN
  1366. 33    IF(J-IPIV) 34,53,34
  1367. 34    K=0
  1368. C
  1369. C       SEARCH COLUMN IN TRANSFORMATION-MATRIX T
  1370.     DO 36 I=1,L
  1371.     IF(IHE(I)-J) 36,35,36
  1372. 35    K=I
  1373.     IF(ILAB) 50,50,16
  1374. 36    CONTINUE
  1375. C
  1376. C       GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX
  1377.     I=L+L+L+NAN+J
  1378.     I=IHE(I)-N
  1379.     IF(I) 37,37,38
  1380. 37    I=I+N
  1381.     K=1
  1382. 38    I=I+NAN
  1383. C
  1384. C       CALL SUBROUTINE FCT
  1385.     CALL FCT(PIV,TOP(I),M-1)
  1386. C
  1387. C       PREPARE THE CALLED VECTOR PIV
  1388.     DSUM=0.D0
  1389.     IDO=M
  1390.     DO 41 I=1,M
  1391.     HELP=PIV(IDO)
  1392.     IF(K) 39,39,40
  1393. 39    HELP=-HELP
  1394. 40    DSUM=DSUM+DBLE(HELP)
  1395.     PIV(IDO+1)=HELP
  1396. 41    IDO=IDO-1
  1397.     PIV(L)=-DSUM
  1398.     PIV(1)=1.
  1399. C
  1400. C       TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T
  1401.     IDO=IND
  1402.     IF(ILAB) 44,44,42
  1403. 42    K=1
  1404. 43    IDO=K
  1405. 44    DSUM=0.D0
  1406.     HELP=0.
  1407. C
  1408. C       START MULTIPLICATION-LOOP
  1409.     DO 46 I=1,L
  1410.     DSUM=DSUM+DBLE(PIV(I)*T(IDO))
  1411.     TOL=ABS(SNGL(DSUM))
  1412.     IF(TOL-HELP) 46,46,45
  1413. 45    HELP=TOL
  1414. 46    IDO=IDO+L
  1415. C       END OF MULTIPLICATION-LOOP
  1416. C
  1417.     TOL=1.E-5*HELP
  1418.     IF(ABS(SNGL(DSUM))-TOL) 47,47,48
  1419. 47    DSUM=0.D0
  1420. 48    IF(ILAB) 51,51,49
  1421. 49    I=K+L
  1422.     PIV(I)=DSUM
  1423. C
  1424. C       TEST FOR LAST COLUMN-TERM
  1425.     K=K+1
  1426.     IF(K-L) 43,43,18
  1427. 50    I=(K-1)*L+IND
  1428.     DSUM=T(I)
  1429. C
  1430. C       COMPUTE NEW TOP-ELEMENT
  1431. 51    DSUM=DSUM*DBLE(SAVE)
  1432.     TOL=1.E-5*ABS(SNGL(DSUM))
  1433.     TOP(J)=TOP(J)+SNGL(DSUM)
  1434.     IF(ABS(TOP(J))-TOL) 52,52,53
  1435. 52    TOP(J)=0.
  1436. C
  1437. C       TEST FOR LAST TOP-TERM
  1438. 53    J=J-1
  1439.     IF(J) 54,54,33
  1440. C       END OF TOP-LOOP
  1441. C
  1442. C       TRANSFORM PIVOT-COLUMN
  1443. 54    I=IND+L
  1444.     PIV(I)=-1.
  1445.     DO 55 I=1,L
  1446.     J=I+L
  1447. 55    PIV(I)=-PIV(J)*REPI
  1448. C
  1449. C       UPDATE TRANSFORMATION-MATRIX T
  1450.     J=0
  1451.     DO 57 I=1,L
  1452.     IDO=J+IND
  1453.     SAVE=T(IDO)
  1454.     T(IDO)=0.
  1455.     DO 56 K=1,L
  1456.     ISE=K+J
  1457. 56    T(ISE)=T(ISE)+SAVE*PIV(K)
  1458. 57    J=J+L
  1459. C
  1460. C       UPDATE INDEX-VECTOR IHE
  1461. C       INITIALIZE CHARACTERISTICS
  1462.     J=0
  1463.     K=0
  1464.     ISE=0
  1465.     IDO=0
  1466. C
  1467. C       START QUESTION-LOOP
  1468.     DO 61 I=1,L
  1469.     LL=I+L
  1470.     ILAB=IHE(LL)
  1471.     IF(IHE(I)-IPIV) 59,58,59
  1472. 58    ISE=I
  1473.     J=ILAB
  1474. 59    IF(ILAB-IND) 61,60,61
  1475. 60    IDO=I
  1476.     K=IHE(I)
  1477. 61    CONTINUE
  1478. C       END OF QUESTION-LOOP
  1479. C
  1480. C       START MODIFICATION
  1481.     IF(K) 62,62,63
  1482. 62    IHE(IDO)=IPIV
  1483.     IF(ISE) 67,67,65
  1484. 63    IF(IND-J) 64,66,64
  1485. 64    LL=L+L+L+NAN
  1486.     K=K+LL
  1487.     I=IPIV+LL
  1488.     ILAB=IHE(K)
  1489.     IHE(K)=IHE(I)
  1490.     IHE(I)=ILAB
  1491.     IF(ISE) 67,67,65
  1492. 65    IDO=IDO+L
  1493.     I=ISE+L
  1494.     IHE(IDO)=J
  1495.     IHE(I)=IND
  1496. 66    IHE(ISE)=0
  1497. 67    LL=L+L
  1498.     J=LL+IND
  1499.     I=LL+L+IPIV
  1500.     ILAB=IHE(I)
  1501.     IHE(I)=IHE(J)
  1502.     IHE(J)=ILAB
  1503. C       END OF MODIFICATION
  1504. C
  1505.     GO TO 8
  1506. C
  1507. C       SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND
  1508. 68    IER=-1
  1509. C
  1510. C       EVALUATE FINAL TABLEAU
  1511. C       COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND
  1512. C       HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS
  1513. 69    SAVE=0.
  1514.     HELP=0.
  1515.     K=L+L+L
  1516.     DO 73 I=1,NAN
  1517.     IDO=K+I
  1518.     J=IHE(IDO)
  1519.     IF(J) 71,70,73
  1520. 70    SAVE=-TOP(I)
  1521. 71    IF(M+J+1) 73,72,73
  1522. 72    HELP=TOP(I)
  1523. 73    CONTINUE
  1524. C
  1525. C       PREPARE T,TOP,PIV
  1526.     T(1)=SAVE
  1527.     IDO=NAN+1
  1528.     J=NAN+N
  1529.     DO 74 I=IDO,J
  1530. 74    TOP(I)=SAVE
  1531.     DO 75 I=1,M
  1532. 75    PIV(I)=HELP
  1533. C
  1534. C       COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI
  1535. C       AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N)
  1536.     DO 79 I=1,NAN
  1537.     IDO=K+I
  1538.     J=IHE(IDO)
  1539.     IF(J) 76,79,77
  1540. 76    J=-J
  1541.     PIV(J)=HELP-TOP(I)
  1542.     GO TO 79
  1543. 77    IF(J-N) 78,78,79
  1544. 78    J=J+NAN
  1545.     TOP(J)=SAVE+TOP(I)
  1546. 79    CONTINUE
  1547.     DO 80 I=1,N
  1548.     IDO=NAN+I
  1549. 80    TOP(I)=TOP(IDO)
  1550. 81    RETURN
  1551.     END
  1552. C
  1553. C    ..................................................................
  1554. C
  1555. C       SUBROUTINE ARAT
  1556. C
  1557. C       PURPOSE
  1558. C          CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE
  1559. C          FUNCTION IN THE LEAST SQUARES SENSE
  1560. C
  1561. C       USAGE
  1562. C          CALL ARAT(DATI,N,WORK,P,IP,IQ,IER)
  1563. C
  1564. C       DESCRIPTION OF PARAMETERS
  1565. C          DATI  - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS
  1566. C                  THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS,
  1567. C                  THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND
  1568. C                  THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY.
  1569. C                  IF NO WEIGHTS ARE TO BE USED THEN THE THIRD
  1570. C                  COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT
  1571. C                  WHICH MUST CONTAIN A NONPOSITIVE VALUE
  1572. C          N     - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION
  1573. C          WORK  - WORKING STORAGE WHICH IS OF DIMENSION
  1574. C                  (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST.
  1575. C                  ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED
  1576. C                  IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF
  1577. C                  THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO
  1578. C                  WORK(3*N)
  1579. C          P     - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND
  1580. C                  NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ
  1581. C                  LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP
  1582. C                  LOCATIONS.
  1583. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH.
  1584. C          IP    - DIMENSION OF THE NUMERATOR   (INPUT VALUE)
  1585. C          IQ    - DIMENSION OF THE DENOMINATOR (INPUT VALUE)
  1586. C          IER   - RESULTANT ERROR PARAMETER
  1587. C                  IER =-1 MEANS FORMAL ERRORS
  1588. C                  IER = 0 MEANS NO ERRORS
  1589. C                  IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION
  1590. C                  IER IS ALSO USED AS INPUT VALUE
  1591. C                  A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN
  1592. C                  INITIAL APPROXIMATION STORED IN P
  1593. C
  1594. C       REMARKS
  1595. C          THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR
  1596. C          OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P
  1597. C          STARTING WITH LOW POWERS (DENOMINATOR FIRST).
  1598. C          IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE.
  1599. C          SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL
  1600. C          FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL
  1601. C          (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR
  1602. C          TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS.
  1603. C          IF A FIT IN OTHER FUNCTIONS IS REQUIRED, CNP AND CNPS MUST
  1604. C          BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN.
  1605. C
  1606. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  1607. C          APLL, APFS, FRAT, CNPS, CNP
  1608. C          CNP IS REQUIRED WITHIN FRAT
  1609. C
  1610. C       METHOD
  1611. C          THE ITERATIVE SCHEME USED FOR CALCULATION OF THE
  1612. C          APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS
  1613. C          WHICH ARE OBTAINED BY LINEARIZATION.
  1614. C          A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH
  1615. C          IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF
  1616. C          ZEROES WITHIN THE APPROXIMATION INTERVAL.
  1617. C          FOR REFERENCE SEE
  1618. C          D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN,
  1619. C          COMPUTING(1966), VOL.1, ED.3, PP.264-272.
  1620. C          D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION
  1621. C          OF NONLINEAR PARAMETERS,
  1622. C          JSIAM(1963), VOL.11, ED.2, PP.431-441.
  1623. C
  1624. C    ..................................................................
  1625. C
  1626.     SUBROUTINE ARAT(DATI,N,WORK,P,IP,IQ,IER)
  1627. C
  1628. C
  1629.     EXTERNAL FRAT
  1630. C
  1631. C       DIMENSIONED LOCAL VARIABLE
  1632.     DIMENSION IERV(3)
  1633. C
  1634. C       DIMENSIONED DUMMY VARIABLES
  1635.     DIMENSION DATI(1),WORK(1),P(1)
  1636. C
  1637. C       INITIALIZE TESTVALUES
  1638.     LIMIT=20
  1639.     ETA =1.E-11
  1640.     EPS=1.E-5
  1641. C
  1642. C       CHECK FOR FORMAL ERRORS
  1643.     IF(N)4,4,1
  1644. 1    IF(IP)4,4,2
  1645. 2    IF(IQ)4,4,3
  1646. 3    IPQ=IP+IQ
  1647.     IF(N-IPQ)4,5,5
  1648. C
  1649. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  1650. 4    IER=-1
  1651.     RETURN
  1652. C
  1653. C       INITIALIZE ITERATION PROCESS
  1654. 5    KOUNT=0
  1655.     IERV(2)=IP
  1656.     IERV(3)=IQ
  1657.     NDP=N+N+1
  1658.     NNE=NDP+NDP
  1659.     IX=IPQ-1
  1660.     IQP1=IQ+1
  1661.     IRHS=NNE+IPQ*IX/2
  1662.     IEND=IRHS+IX
  1663. C
  1664. C       TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION
  1665.     IF(IER)8,6,8
  1666. C
  1667. C       INITIALIZE NUMERATOR AND DENOMINATOR
  1668. 6    DO 7 I=2,IPQ
  1669. 7    P(I)=0.
  1670.     P(1)=1.
  1671. C
  1672. C       CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL
  1673. C       APPROXIMATION
  1674. 8    DO 9 J=1,N
  1675.     T=DATI(J)
  1676.     I=J+N
  1677.     CALL CNPS(WORK(I),T,P(IQP1),IP)
  1678.     K=I+N
  1679. 9    CALL CNPS(WORK(K),T,P,IQ)
  1680. C
  1681. C       SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION)
  1682. 10    CALL APLL(FRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV)
  1683. C
  1684. C       CHECK FOR ZERO DENOMINATOR
  1685.     IF(IERV(1))4,11,4
  1686. 11    INCR=0
  1687.     RELAX=2.
  1688. C
  1689. C       RESTORE MATRIX IN WORKING STORAGE
  1690. 12    J=IEND
  1691.     DO 13 I=NNE,IEND
  1692.     J=J+1
  1693. 13    WORK(I)=WORK(J)
  1694.     IF(KOUNT)14,14,15
  1695. C
  1696. C       SAVE SQUARE SUM OF ERRORS
  1697. 14    OSUM=WORK(IEND)
  1698.     DIAG=OSUM*EPS
  1699.     K=IQ
  1700. C
  1701. C       ADD CONSTANT TO DIAGONAL
  1702.     IF(WORK(NNE))17,17,19
  1703. 15    IF(INCR)19,19,16
  1704. 16    K=IPQ
  1705. 17    J=NNE-1
  1706.     DO 18 I=1,K
  1707.     WORK(J)=WORK(J)+DIAG
  1708. 18    J=J+I
  1709. C
  1710. C       SOLVE NORMAL EQUATIONS
  1711. 19    CALL APFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER)
  1712. C
  1713. C       CHECK FOR FAILURE OF EQUATION SOLVER
  1714.     IF(IRES)4,4,20
  1715. C
  1716. C       TEST FOR DEFECTIVE NORMALEQUATIONS
  1717. 20    IF(IRES-IX)21,24,24
  1718. 21    IF(INCR)22,22,23
  1719. 22    DIAG=DIAG*0.125
  1720. 23    DIAG=DIAG+DIAG
  1721.     INCR=INCR+1
  1722. C
  1723. C       START WITH OVER RELAXATION
  1724.     RELAX=8.
  1725.     IF(INCR-LIMIT)12,45,45
  1726. C
  1727. C       CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR
  1728. 24    L=NDP
  1729.     J=NNE+IRES*(IRES-1)/2-1
  1730.     K=J+IQ
  1731.     WORK(J)=0.
  1732.     IRQ=IQ
  1733.     IRP=IRES-IQ+1
  1734.     IF(IRP)25,26,26
  1735. 25    IRQ=IRES+1
  1736. 26    DO 29 I=1,N
  1737.     T=DATI(I)
  1738.     WORK(I)=0.
  1739.     CALL CNPS(WORK(I),T,WORK(K),IRP)
  1740.     M=L+N
  1741.     CALL CNPS(WORK(M),T,WORK(J),IRQ)
  1742.     IF(WORK(M)*WORK(L))27,29,29
  1743. 27    SUM=WORK(L)/WORK(M)
  1744.     IF(RELAX+SUM)29,29,28
  1745. 28    RELAX=-SUM
  1746. 29    L=L+1
  1747. C
  1748. C       MODIFY RELAXATION FACTOR IF NECESSARY
  1749.     SSOE=OSUM
  1750.     ITER=LIMIT
  1751. 30    SUM=0.
  1752.     RELAX=RELAX*0.5
  1753.     DO 32 I=1,N
  1754.     M=I+N
  1755.     K=M+N
  1756.     L=K+N
  1757.     SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L))
  1758.     SAVE=SAVE*SAVE
  1759.     IF(DATI(NDP))32,32,31
  1760. 31    SAVE=SAVE*DATI(K)
  1761. 32    SUM=SUM+SAVE
  1762.     IF(ITER)45,33,33
  1763. 33    ITER=ITER-1
  1764.     IF(SUM-OSUM)34,37,35
  1765. 34    OSUM=SUM
  1766.     GOTO 30
  1767. C
  1768. C       TEST FOR IMPROVEMENT
  1769. 35    IF(OSUM-SSOE)36,30,30
  1770. 36    RELAX=RELAX+RELAX
  1771. 37    T=0.
  1772.     SAVE=0.
  1773.     K=IRES+1
  1774.     DO 38 I=2,K
  1775.     J=J+1
  1776.     T=T+ABS(P(I))
  1777.     P(I)=P(I)+RELAX*WORK(J)
  1778. 38    SAVE=SAVE+ABS(P(I))
  1779. C
  1780. C       UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR
  1781.     DO 39 I=1,N
  1782.     J=I+N
  1783.     K=J+N
  1784.     L=K+N
  1785.     WORK(J)=WORK(J)+RELAX*WORK(I)
  1786. 39    WORK(K)=WORK(K)+RELAX*WORK(L)
  1787. C
  1788. C       TEST FOR CONVERGENCE
  1789.     IF(INCR)40,40,42
  1790. 40    IF(SSOE-OSUM-RELAX*EPS*OSUM)46,46,41
  1791. 41    IF(ABS(T-SAVE)-RELAX*EPS*SAVE)46,46,42
  1792. 42    IF(OSUM-ETA*SAVE)46,46,43
  1793. 43    KOUNT=KOUNT+1
  1794.     IF(KOUNT-LIMIT)10,44,44
  1795. C
  1796. C       ERROR RETURN IN CASE OF POOR CONVERGENCE
  1797. 44    IER=2
  1798.     RETURN
  1799. 45    IER=1
  1800.     RETURN
  1801. C
  1802. C       NORMAL RETURN
  1803. 46    IER=0
  1804.     RETURN
  1805.     END
  1806. C
  1807. C    ..................................................................
  1808. C
  1809. C       SUBROUTINE ARRAY
  1810. C
  1811. C       PURPOSE
  1812. C          CONVERT DATA ARRAY FROM SINGLE TO DOUBLE DIMENSION OR VICE
  1813. C          VERSA.  THIS SUBROUTINE IS USED TO LINK THE USER PROGRAM
  1814. C          WHICH HAS DOUBLE DIMENSION ARRAYS AND THE SSP SUBROUTINES
  1815. C          WHICH OPERATE ON ARRAYS OF DATA IN A VECTOR FASHION.
  1816. C
  1817. C       USAGE
  1818. C          CALL ARRAY (MODE,I,J,N,M,S,D)
  1819. C
  1820. C       DESCRIPTION OF PARAMETERS
  1821. C          MODE - CODE INDICATING TYPE OF CONVERSION
  1822. C                   1 - FROM SINGLE TO DOUBLE DIMENSION
  1823. C                   2 - FROM DOUBLE TO SINGLE DIMENSION
  1824. C          I    - NUMBER OF ROWS IN ACTUAL DATA MATRIX
  1825. C          J    - NUMBER OF COLUMNS IN ACTUAL DATA MATRIX
  1826. C          N    - NUMBER OF ROWS SPECIFIED FOR THE MATRIX D IN
  1827. C                 DIMENSION STATEMENT
  1828. C          M    - NUMBER OF COLUMNS SPECIFIED FOR THE MATRIX D IN
  1829. C                 DIMENSION STATEMENT
  1830. C          S    - IF MODE=1, THIS VECTOR IS INPUT WHICH CONTAINS THE
  1831. C                 ELEMENTS OF A DATA MATRIX OF SIZE I BY J. COLUMN I+1
  1832. C                 OF DATA MATRIX FOLLOWS COLUMN I, ETC. IF MODE=2,
  1833. C                 THIS VECTOR IS OUTPUT REPRESENTING A DATA MATRIX OF
  1834. C                 SIZE I BY J CONTAINING ITS COLUMNS CONSECUTIVELY.
  1835. C                 THE LENGTH OF S IS IJ, WHERE IJ=I*J.
  1836. C          D    - IF MODE=1, THIS MATRIX OF SIZE N BY M IS OUTPUT,
  1837. C                 CONTAINING A DATA MATRIX OF SIZE I BY J IN THE FIRST
  1838. C                 I ROWS AND J COLUMNS. IF MODE=2, THIS N BY M MATRIX
  1839. C                 IS INPUT CONTAINING A DATA MATRIX OF SIZE I BY J IN
  1840. C                 THE FIRST I ROWS AND J COLUMNS.
  1841. C
  1842. C       REMARKS
  1843. C          VECTOR S CAN BE IN THE SAME LOCATION AS MATRIX D.  VECTOR S
  1844. C          IS REFERRED AS A MATRIX IN OTHER SSP ROUTINES, SINCE IT
  1845. C          CONTAINS A DATA MATRIX.
  1846. C          THIS SUBROUTINE CONVERTS ONLY GENERAL DATA MATRICES (STORAGE
  1847. C          MODE OF 0).
  1848. C
  1849. C       SUBROUTINES AND FUNCTION SUBROUTINES REQUIRED
  1850. C          NONE
  1851. C
  1852. C       METHOD
  1853. C          REFER TO THE DISCUSSION ON VARIABLE DATA SIZE IN THE SECTION
  1854. C          DESCRIBING OVERALL RULES FOR USAGE IN THIS MANUAL.
  1855. C
  1856. C    ..................................................................
  1857. C
  1858.     SUBROUTINE ARRAY (MODE,I,J,N,M,S,D)
  1859.     DIMENSION S(1),D(1)
  1860. C
  1861.     NI=N-I
  1862. C
  1863. C       TEST TYPE OF CONVERSION
  1864. C
  1865.     IF(MODE-1) 100, 100, 120
  1866. C
  1867. C       CONVERT FROM SINGLE TO DOUBLE DIMENSION
  1868. C
  1869. 100    IJ=I*J+1
  1870.     NM=N*J+1
  1871.     DO 110 K=1,J
  1872.     NM=NM-NI
  1873.     DO 110 L=1,I
  1874.     IJ=IJ-1
  1875.     NM=NM-1
  1876. 110    D(NM)=S(IJ)
  1877.     GO TO 140
  1878. C
  1879. C       CONVERT FROM DOUBLE TO SINGLE DIMENSION
  1880. C
  1881. 120    IJ=0
  1882.     NM=0
  1883.     DO 130 K=1,J
  1884.     DO 125 L=1,I
  1885.     IJ=IJ+1
  1886.     NM=NM+1
  1887. 125    S(IJ)=D(NM)
  1888. 130    NM=NM+NI
  1889. C
  1890. 140    RETURN
  1891.     END
  1892. C
  1893. C    ..................................................................
  1894. C
  1895. C       SUBROUTINE ATEIG
  1896. C
  1897. C       PURPOSE
  1898. C          COMPUTE THE EIGENVALUES OF A REAL ALMOST TRIANGULAR MATRIX
  1899. C
  1900. C       USAGE
  1901. C          CALL ATEIG(M,A,RR,RI,IANA,IA)
  1902. C
  1903. C       DESCRIPTION OF THE PARAMETERS
  1904. C          M      ORDER OF THE MATRIX
  1905. C          A      THE INPUT MATRIX, M BY M
  1906. C          RR     VECTOR CONTAINING THE REAL PARTS OF THE EIGENVALUES
  1907. C                 ON RETURN
  1908. C          RI     VECTOR CONTAINING THE IMAGINARY PARTS OF THE EIGEN-
  1909. C                 VALUES ON RETURN
  1910. C          IANA   VECTOR WHOSE DIMENSION MUST BE GREATER THAN OR EQUAL
  1911. C                 TO M, CONTAINING ON RETURN INDICATIONS ABOUT THE WAY
  1912. C                 THE EIGENVALUES APPEARED (SEE MATH. DESCRIPTION)
  1913. C          IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A
  1914. C                 IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE
  1915. C                 SUBSCRIPTED DATA STORAGE MODE.
  1916. C                 IA=M WHEN THE MATRIX IS IN SSP VECTOR STORAGE MODE.
  1917. C
  1918. C       REMARKS
  1919. C          THE ORIGINAL MATRIX IS DESTROYED
  1920. C          THE DIMENSION OF RR AND RI MUST BE GREATER OR EQUAL TO M
  1921. C
  1922. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  1923. C          NONE
  1924. C
  1925. C       METHOD
  1926. C          QR DOUBLE ITERATION
  1927. C
  1928. C       REFERENCES
  1929. C          J.G.F. FRANCIS - THE QR TRANSFORMATION---THE COMPUTER
  1930. C          JOURNAL, VOL. 4, NO. 3, OCTOBER 1961, VOL. 4, NO. 4, JANUARY
  1931. C          1962.  J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
  1932. C          CLARENDON PRESS, OXFORD, 1965.
  1933. C
  1934. C    ..................................................................
  1935. C
  1936.     SUBROUTINE ATEIG(M,A,RR,RI,IANA,IA)
  1937.     DIMENSION A(1),RR(1),RI(1),PRR(2),PRI(2),IANA(1)
  1938.     INTEGER P,P1,Q
  1939. C
  1940.     E7=1.0E-8
  1941.     E6=1.0E-6
  1942.     E10=1.0E-10
  1943.     DELTA=0.5
  1944.     MAXIT=30
  1945. C
  1946. C       INITIALIZATION
  1947. C
  1948.     N=M
  1949. 20    N1=N-1
  1950.     IN=N1*IA
  1951.     NN=IN+N
  1952.     IF(N1) 30,1300,30
  1953. 30    NP=N+1
  1954. C
  1955. C       ITERATION COUNTER
  1956. C
  1957.     IT=0
  1958. C
  1959. C       ROOTS OF THE 2ND ORDER MAIN SUBMATRIX AT THE PREVIOUS
  1960. C       ITERATION
  1961. C
  1962.     DO 40 I=1,2
  1963.     PRR(I)=0.0
  1964. 40    PRI(I)=0.0
  1965. C
  1966. C       LAST TWO SUBDIAGONAL ELEMENTS AT THE PREVIOUS ITERATION
  1967. C
  1968.     PAN=0.0
  1969.     PAN1=0.0
  1970. C
  1971. C       ORIGIN SHIFT
  1972. C
  1973.     R=0.0
  1974.     S=0.0
  1975. C
  1976. C       ROOTS OF THE LOWER MAIN 2 BY 2 SUBMATRIX
  1977. C
  1978.     N2=N1-1
  1979.     IN1=IN-IA
  1980.     NN1=IN1+N
  1981.     N1N=IN+N1
  1982.     N1N1=IN1+N1
  1983. 60    T=A(N1N1)-A(NN)
  1984.     U=T*T
  1985.     V=4.0*A(N1N)*A(NN1)
  1986.     IF(ABS(V)-U*E7) 100,100,65
  1987. 65    T=U+V
  1988.     IF(ABS(T)-AMAX1(U,ABS(V))*E6) 67,67,68
  1989. 67    T=0.0
  1990. 68    U=(A(N1N1)+A(NN))/2.0
  1991.     V=SQRT(ABS(T))/2.0
  1992.     IF(T)140,70,70
  1993. 70    IF(U) 80,75,75
  1994. 75    RR(N1)=U+V
  1995.     RR(N)=U-V
  1996.     GO TO 130
  1997. 80    RR(N1)=U-V
  1998.     RR(N)=U+V
  1999.     GO TO 130
  2000. 100    IF(T)120,110,110
  2001. 110    RR(N1)=A(N1N1)
  2002.     RR(N)=A(NN)
  2003.     GO TO 130
  2004. 120    RR(N1)=A(NN)
  2005.     RR(N)=A(N1N1)
  2006. 130    RI(N)=0.0
  2007.     RI(N1)=0.0
  2008.     GO TO 160
  2009. 140    RR(N1)=U
  2010.     RR(N)=U
  2011.     RI(N1)=V
  2012.     RI(N)=-V
  2013. 160    IF(N2)1280,1280,180
  2014. C
  2015. C       TESTS OF CONVERGENCE
  2016. C
  2017. 180    N1N2=N1N1-IA
  2018.     RMOD=RR(N1)*RR(N1)+RI(N1)*RI(N1)
  2019.     EPS=E10*SQRT(RMOD)
  2020.     IF(ABS(A(N1N2))-EPS)1280,1280,240
  2021. 240    IF(ABS(A(NN1))-E10*ABS(A(NN))) 1300,1300,250
  2022. 250    IF(ABS(PAN1-A(N1N2))-ABS(A(N1N2))*E6) 1240,1240,260
  2023. 260    IF(ABS(PAN-A(NN1))-ABS(A(NN1))*E6)1240,1240,300
  2024. 300    IF(IT-MAXIT) 320,1240,1240
  2025. C
  2026. C       COMPUTE THE SHIFT
  2027. C
  2028. 320    J=1
  2029.     DO 360 I=1,2
  2030.     K=NP-I
  2031.     IF(ABS(RR(K)-PRR(I))+ABS(RI(K)-PRI(I))-DELTA*(ABS(RR(K))
  2032.      1    +ABS(RI(K)))) 340,360,360
  2033. 340    J=J+I
  2034. 360    CONTINUE
  2035.     GO TO (440,460,460,480),J
  2036. 440    R=0.0
  2037.     S=0.0
  2038.     GO TO 500
  2039. 460    J=N+2-J
  2040.     R=RR(J)*RR(J)
  2041.     S=RR(J)+RR(J)
  2042.     GO TO 500
  2043. 480    R=RR(N)*RR(N1)-RI(N)*RI(N1)
  2044.     S=RR(N)+RR(N1)
  2045. C
  2046. C       SAVE THE LAST TWO SUBDIAGONAL TERMS AND THE ROOTS OF THE
  2047. C       SUBMATRIX BEFORE ITERATION
  2048. C
  2049. 500    PAN=A(NN1)
  2050.     PAN1=A(N1N2)
  2051.     DO 520 I=1,2
  2052.     K=NP-I
  2053.     PRR(I)=RR(K)
  2054. 520    PRI(I)=RI(K)
  2055. C
  2056. C       SEARCH FOR A PARTITION OF THE MATRIX, DEFINED BY P AND Q
  2057. C
  2058.     P=N2
  2059.     IF (N-3)600,600,525
  2060. 525    IPI=N1N2
  2061.     DO 580 J=2,N2
  2062.     IPI=IPI-IA-1
  2063.     IF(ABS(A(IPI))-EPS) 600,600,530
  2064. 530    IPIP=IPI+IA
  2065.     IPIP2=IPIP+IA
  2066.     D=A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R
  2067.     IF(D)540,560,540
  2068. 540   IF(ABS(A(IPI)*A(IPIP+1))*(ABS(A(IPIP)+A(IPIP2+1)-S)+ABS(A(IPIP2+2)
  2069.      1 )) -ABS(D)*EPS) 620,620,560
  2070. 560    P=N1-J
  2071. 580    CONTINUE
  2072. 600    Q=P
  2073.     GO TO 680
  2074. 620    P1=P-1
  2075.     Q=P1
  2076.     IF (P1-1) 680,680,650
  2077. 650    DO 660 I=2, P1
  2078.     IPI=IPI-IA-1
  2079.     IF(ABS(A(IPI))-EPS)680,680,660
  2080. 660    Q=Q-1
  2081. C
  2082. C       QR DOUBLE ITERATION
  2083. C
  2084. 680    II=(P-1)*IA+P
  2085.     DO 1220 I=P,N1
  2086.     II1=II-IA
  2087.     IIP=II+IA
  2088.     IF(I-P)720,700,720
  2089. 700    IPI=II+1
  2090.     IPIP=IIP+1
  2091. C
  2092. C       INITIALIZATION OF THE TRANSFORMATION
  2093. C
  2094.     G1=A(II)*(A(II)-S)+A(IIP)*A(IPI)+R
  2095.     G2=A(IPI)*(A(IPIP)+A(II)-S)
  2096.     G3=A(IPI)*A(IPIP+1)
  2097.     A(IPI+1)=0.0
  2098.     GO TO 780
  2099. 720    G1=A(II1)
  2100.     G2=A(II1+1)
  2101.     IF(I-N2)740,740,760
  2102. 740    G3=A(II1+2)
  2103.     GO TO 780
  2104. 760    G3=0.0
  2105. 780    CAP=SQRT(G1*G1+G2*G2+G3*G3)
  2106.     IF(CAP)800,860,800
  2107. 800    IF(G1)820,840,840
  2108. 820    CAP=-CAP
  2109. 840    T=G1+CAP
  2110.     PSI1=G2/T
  2111.     PSI2=G3/T
  2112.     ALPHA=2.0/(1.0+PSI1*PSI1+PSI2*PSI2)
  2113.     GO TO 880
  2114. 860    ALPHA=2.0
  2115.     PSI1=0.0
  2116.     PSI2=0.0
  2117. 880    IF(I-Q)900,960,900
  2118. 900    IF(I-P)920,940,920
  2119. 920    A(II1)=-CAP
  2120.     GO TO 960
  2121. 940    A(II1)=-A(II1)
  2122. C
  2123. C       ROW OPERATION
  2124. C
  2125. 960    IJ=II
  2126.     DO 1040 J=I,N
  2127.     T=PSI1*A(IJ+1)
  2128.     IF(I-N1)980,1000,1000
  2129. 980    IP2J=IJ+2
  2130.     T=T+PSI2*A(IP2J)
  2131. 1000    ETA=ALPHA*(T+A(IJ))
  2132.     A(IJ)=A(IJ)-ETA
  2133.     A(IJ+1)=A(IJ+1)-PSI1*ETA
  2134.     IF(I-N1)1020,1040,1040
  2135. 1020    A(IP2J)=A(IP2J)-PSI2*ETA
  2136. 1040    IJ=IJ+IA
  2137. C
  2138. C       COLUMN OPERATION
  2139. C
  2140.     IF(I-N1)1080,1060,1060
  2141. 1060    K=N
  2142.     GO TO 1100
  2143. 1080    K=I+2
  2144. 1100    IP=IIP-I
  2145.     DO 1180 J=Q,K
  2146.     JIP=IP+J
  2147.     JI=JIP-IA
  2148.     T=PSI1*A(JIP)
  2149.     IF(I-N1)1120,1140,1140
  2150. 1120    JIP2=JIP+IA
  2151.     T=T+PSI2*A(JIP2)
  2152. 1140    ETA=ALPHA*(T+A(JI))
  2153.     A(JI)=A(JI)-ETA
  2154.     A(JIP)=A(JIP)-ETA*PSI1
  2155.     IF(I-N1)1160,1180,1180
  2156. 1160    A(JIP2)=A(JIP2)-ETA*PSI2
  2157. 1180    CONTINUE
  2158.     IF(I-N2)1200,1220,1220
  2159. 1200    JI=II+3
  2160.     JIP=JI+IA
  2161.     JIP2=JIP+IA
  2162.     ETA=ALPHA*PSI2*A(JIP2)
  2163.     A(JI)=-ETA
  2164.     A(JIP)=-ETA*PSI1
  2165.     A(JIP2)=A(JIP2)-ETA*PSI2
  2166. 1220    II=IIP+1
  2167.     IT=IT+1
  2168.     GO TO 60
  2169. C
  2170. C       END OF ITERATION
  2171. C
  2172. 1240    IF(ABS(A(NN1))-ABS(A(N1N2))) 1300,1280,1280
  2173. C
  2174. C       TWO EIGENVALUES HAVE BEEN FOUND
  2175. C
  2176. 1280    IANA(N)=0
  2177.     IANA(N1)=2
  2178.     N=N2
  2179.     IF(N2)1400,1400,20
  2180. C
  2181. C       ONE EIGENVALUE HAS BEEN FOUND
  2182. C
  2183. 1300    RR(N)=A(NN)
  2184.     RI(N)=0.0
  2185.     IANA(N)=1
  2186.     IF(N1)1400,1400,1320
  2187. 1320    N=N1
  2188.     GO TO 20
  2189. 1400    RETURN
  2190.     END
  2191. C
  2192. C    ..................................................................
  2193. C
  2194. C       SUBROUTINE ATSE
  2195. C
  2196. C       PURPOSE
  2197. C          NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE
  2198. C          SELECTED AND ORDERED SUCH THAT
  2199. C          ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  2200. C
  2201. C       USAGE
  2202. C          CALL ATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
  2203. C
  2204. C       DESCRIPTION OF PARAMETERS
  2205. C          X      - THE SEARCH ARGUMENT.
  2206. C          ZS     - THE STARTING VALUE OF ARGUMENTS.
  2207. C          DZ     - THE INCREMENT OF ARGUMENT VALUES.
  2208. C          F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
  2209. C                   (DIMENSION IROW).
  2210. C                   IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
  2211. C                   COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
  2212. C                   THE SECOND THE VECTOR OF DERIVATIVES.
  2213. C          IROW   - THE DIMENSION OF EACH COLUMN IN MATRIX F.
  2214. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  2215. C          ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
  2216. C                   ARGUMENT VALUES (DIMENSION NDIM).
  2217. C          VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
  2218. C                   (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
  2219. C                   VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
  2220. C                   (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
  2221. C                   EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
  2222. C                   VALUE).
  2223. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  2224. C                   THE GIVEN TABLE.
  2225. C
  2226. C       REMARKS
  2227. C          NO ACTION IN CASE IROW LESS THAN 1.
  2228. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  2229. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  2230. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  2231. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  2232. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  2233. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  2234. C          SUBROUTINE ATSE.
  2235. C          SUBROUTINE ATSE ESPECIALLY CAN BE USED FOR GENERATING THE
  2236. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
  2237. C
  2238. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2239. C          NONE
  2240. C
  2241. C       METHOD
  2242. C          SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT
  2243. C          ARGUMENT, WHICH IS NEXT TO X.
  2244. C          AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
  2245. C          SELECTED IN THE ABOVE SENSE.
  2246. C
  2247. C    ..................................................................
  2248. C
  2249.     SUBROUTINE ATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
  2250. C
  2251. C
  2252.     DIMENSION F(1),ARG(1),VAL(1)
  2253.     IF(IROW-1)19,17,1
  2254. C
  2255. C    CASE DZ=0 IS CHECKED OUT
  2256. 1    IF(DZ)2,17,2
  2257. 2    N=NDIM
  2258. C
  2259. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  2260.     IF(N-IROW)4,4,3
  2261. 3    N=IROW
  2262. C
  2263. C    COMPUTATION OF STARTING SUBSCRIPT J.
  2264. 4    J=(X-ZS)/DZ+1.5
  2265.     IF(J)5,5,6
  2266. 5    J=1
  2267. 6    IF(J-IROW)8,8,7
  2268. 7    J=IROW
  2269. C
  2270. C    GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0.
  2271. 8    II=J
  2272.     JL=0
  2273.     JR=0
  2274.     DO 16 I=1,N
  2275.     ARG(I)=ZS+FLOAT(II-1)*DZ
  2276.     IF(ICOL-2)9,10,10
  2277. 9    VAL(I)=F(II)
  2278.     GOTO 11
  2279. 10    VAL(2*I-1)=F(II)
  2280.     III=II+IROW
  2281.     VAL(2*I)=F(III)
  2282. 11    IF(J+JR-IROW)12,15,12
  2283. 12    IF(J-JL-1)13,14,13
  2284. 13    IF((ARG(I)-X)*DZ)14,15,15
  2285. 14    JR=JR+1
  2286.     II=J+JR
  2287.     GOTO 16
  2288. 15    JL=JL+1
  2289.     II=J-JL
  2290. 16    CONTINUE
  2291.     RETURN
  2292. C
  2293. C    CASE DZ=0
  2294. 17    ARG(1)=ZS
  2295.     VAL(1)=F(1)
  2296.     IF(ICOL-2)19,19,18
  2297. 18    VAL(2)=F(2)
  2298. 19    RETURN
  2299.     END
  2300. C
  2301. C    ..................................................................
  2302. C
  2303. C       SUBROUTINE ATSG
  2304. C
  2305. C       PURPOSE
  2306. C          NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND
  2307. C          ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  2308. C
  2309. C       USAGE
  2310. C          CALL ATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
  2311. C
  2312. C       DESCRIPTION OF PARAMETERS
  2313. C          X      - THE SEARCH ARGUMENT.
  2314. C          Z      - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW).
  2315. C          F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
  2316. C                   (DIMENSION IROW).
  2317. C                   IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
  2318. C                   COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
  2319. C                   THE SECOND THE VECTOR OF DERIVATIVES.
  2320. C          WORK   - A WORKING STORAGE (DIMENSION IROW).
  2321. C          IROW   - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH
  2322. C                   COLUMN IN MATRIX F.
  2323. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  2324. C          ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
  2325. C                   ARGUMENT VALUES (DIMENSION NDIM).
  2326. C          VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
  2327. C                   (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
  2328. C                   VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
  2329. C                   (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
  2330. C                   EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
  2331. C                   VALUE).
  2332. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  2333. C                   THE GIVEN TABLE (Z,F).
  2334. C
  2335. C       REMARKS
  2336. C          NO ACTION IN CASE IROW LESS THAN 1.
  2337. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  2338. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  2339. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  2340. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  2341. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  2342. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  2343. C          SUBROUTINE ATSG.
  2344. C          SUBROUTINE ATSG ESPECIALLY CAN BE USED FOR GENERATING THE
  2345. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
  2346. C
  2347. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2348. C          NONE
  2349. C
  2350. C       METHOD
  2351. C          SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH
  2352. C          COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS
  2353. C          (OR IROW STEPS IF NDIM IS GREATER THAN IROW)
  2354. C          SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH
  2355. C          IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN
  2356. C          MAX(WORK(I)).
  2357. C
  2358. C    ..................................................................
  2359. C
  2360.     SUBROUTINE ATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
  2361. C
  2362. C
  2363.     DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1)
  2364.     IF(IROW)11,11,1
  2365. 1    N=NDIM
  2366. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  2367.     IF(N-IROW)3,3,2
  2368. 2    N=IROW
  2369. C
  2370. C    GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT.
  2371. 3    B=0.
  2372.     DO 5 I=1,IROW
  2373.     DELTA=ABS(Z(I)-X)
  2374.     IF(DELTA-B)5,5,4
  2375. 4    B=DELTA
  2376. 5    WORK(I)=DELTA
  2377. C
  2378. C    GENERATION OF TABLE (ARG,VAL)
  2379.     B=B+1.
  2380.     DO 10 J=1,N
  2381.     DELTA=B
  2382.     DO 7 I=1,IROW
  2383.     IF(WORK(I)-DELTA)6,7,7
  2384. 6    II=I
  2385.     DELTA=WORK(I)
  2386. 7    CONTINUE
  2387.     ARG(J)=Z(II)
  2388.     IF(ICOL-1)8,9,8
  2389. 8    VAL(2*J-1)=F(II)
  2390.     III=II+IROW
  2391.     VAL(2*J)=F(III)
  2392.     GOTO 10
  2393. 9    VAL(J)=F(II)
  2394. 10    WORK(II)=B
  2395. 11    RETURN
  2396.     END
  2397. C
  2398. C    ..................................................................
  2399. C
  2400. C       SUBROUTINE ATSM
  2401. C
  2402. C       PURPOSE
  2403. C          NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE
  2404. C          SELECTED AND ORDERED SUCH THAT
  2405. C          ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  2406. C
  2407. C       USAGE
  2408. C          CALL ATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  2409. C
  2410. C       DESCRIPTION OF PARAMETERS
  2411. C          X      - THE SEARCH ARGUMENT.
  2412. C          Z      - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW).
  2413. C                   THE ARGUMENT VALUES MUST BE STORED IN INCREASING
  2414. C                   OR DECREASING SEQUENCE.
  2415. C          F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
  2416. C                   (DIMENSION IROW).
  2417. C                   IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
  2418. C                   COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
  2419. C                   THE SECOND THE VECTOR OF DERIVATIVES.
  2420. C          IROW   - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN
  2421. C                   IN MATRIX F.
  2422. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  2423. C          ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
  2424. C                   ARGUMENT VALUES (DIMENSION NDIM).
  2425. C          VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
  2426. C                   (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
  2427. C                   VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
  2428. C                   (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
  2429. C                   EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
  2430. C                   VALUE).
  2431. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  2432. C                   THE GIVEN TABLE (Z,F).
  2433. C
  2434. C       REMARKS
  2435. C          NO ACTION IN CASE IROW LESS THAN 1.
  2436. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  2437. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  2438. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  2439. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  2440. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  2441. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  2442. C          SUBROUTINE ATSM.
  2443. C          SUBROUTINE ATSM ESPECIALLY CAN BE USED FOR GENERATING THE
  2444. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
  2445. C
  2446. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2447. C          NONE
  2448. C
  2449. C       METHOD
  2450. C          SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT
  2451. C          ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH).
  2452. C          AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
  2453. C          SELECTED IN THE ABOVE SENSE.
  2454. C
  2455. C    ..................................................................
  2456. C
  2457.     SUBROUTINE ATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  2458. C
  2459. C
  2460.     DIMENSION Z(1),F(1),ARG(1),VAL(1)
  2461. C
  2462. C    CASE IROW=1 IS CHECKED OUT
  2463.     IF(IROW-1)23,21,1
  2464. 1    N=NDIM
  2465. C
  2466. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  2467.     IF(N-IROW)3,3,2
  2468. 2    N=IROW
  2469. C
  2470. C    CASE IROW.GE.2
  2471. C    SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X.
  2472. 3    IF(Z(IROW)-Z(1))5,4,4
  2473. 4    J=IROW
  2474.     I=1
  2475.     GOTO 6
  2476. 5    I=IROW
  2477.     J=1
  2478. 6    K=(J+I)/2
  2479.     IF(X-Z(K))7,7,8
  2480. 7    J=K
  2481.     GOTO 9
  2482. 8    I=K
  2483. 9    IF(IABS(J-I)-1)10,10,6
  2484. 10    IF(ABS(Z(J)-X)-ABS(Z(I)-X))12,12,11
  2485. 11    J=I
  2486. C
  2487. C    TABLE SELECTION
  2488. 12    K=J
  2489.     JL=0
  2490.     JR=0
  2491.     DO 20 I=1,N
  2492.     ARG(I)=Z(K)
  2493.     IF(ICOL-1)14,14,13
  2494. 13    VAL(2*I-1)=F(K)
  2495.     KK=K+IROW
  2496.     VAL(2*I)=F(KK)
  2497.     GOTO 15
  2498. 14    VAL(I)=F(K)
  2499. 15    JJR=J+JR
  2500.     IF(JJR-IROW)16,18,18
  2501. 16    JJL=J-JL
  2502.     IF(JJL-1)19,19,17
  2503. 17    IF(ABS(Z(JJR+1)-X)-ABS(Z(JJL-1)-X))19,19,18
  2504. 18    JL=JL+1
  2505.     K=J-JL
  2506.     GOTO 20
  2507. 19    JR=JR+1
  2508.     K=J+JR
  2509. 20    CONTINUE
  2510.     RETURN
  2511. C
  2512. C    CASE IROW=1
  2513. 21    ARG(1)=Z(1)
  2514.     VAL(1)=F(1)
  2515.     IF(ICOL-2)23,22,23
  2516. 22    VAL(2)=F(2)
  2517. 23    RETURN
  2518.     END
  2519. C
  2520. C    ..................................................................
  2521. C
  2522. C       SUBROUTINE AUTO
  2523. C
  2524. C       PURPOSE
  2525. C          TO FIND AUTOCOVARIANCES OF SERIES A FOR LAGS 0 TO L-1.
  2526. C
  2527. C       USAGE
  2528. C          CALL AUTO (A,N,L,R)
  2529. C
  2530. C       DESCRIPTION OF PARAMETERS
  2531. C          A    - INPUT VECTOR OF LENGTH N CONTAINING THE TIME SERIES
  2532. C                 WHOSE AUTOCOVARIANCE IS DESIRED.
  2533. C          N    - LENGTH OF THE VECTOR A.
  2534. C          L    - AUTOCOVARIANCE IS CALCULATED FOR LAGS OF 0, 1, 2,...,
  2535. C                 L-1.
  2536. C          R    - OUTPUT VECTOR OF LENGTH L CONTAINING AUTOCOVARIANCES
  2537. C                 OF SERIES A.
  2538. C
  2539. C       REMARKS
  2540. C          THE LENGTH OF R IS DIFFERENT FROM THE LENGTH OF A.  N MUST
  2541. C          BE GREATER THAN L.  IF NOT, R(1) IS SET TO ZERO AND RETURN
  2542. C          IS MADE TO THE CALLING PROGRAM.
  2543. C
  2544. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2545. C          NONE
  2546. C
  2547. C       METHOD
  2548. C          DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT
  2549. C       OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959.
  2550. C
  2551. C    ..................................................................
  2552. C
  2553.     SUBROUTINE AUTO (A,N,L,R)
  2554.     DIMENSION A(1),R(1)
  2555. C
  2556. C    CALCULATE AVERAGE OF TIME SERIES A
  2557. C
  2558.     AVER=0.0
  2559.     IF(N-L) 50,50,100
  2560. 50    R(1)=0.0
  2561.     RETURN
  2562. 100    DO 110 I=1,N
  2563. 110    AVER=AVER+A(I)
  2564.     FN=N
  2565.     AVER=AVER/FN
  2566. C
  2567. C    CALCULATE AUTOCOVARIANCES
  2568. C
  2569.     DO 130 J=1,L
  2570.     NJ=N-J+1
  2571.     SUM=0.0
  2572.     DO 120 I=1,NJ
  2573.     IJ=I+J-1
  2574. 120    SUM=SUM+(A(I)-AVER)*(A(IJ)-AVER)
  2575.     FNJ=NJ
  2576. 130    R(J)=SUM/FNJ
  2577.     RETURN
  2578.     END
  2579. C
  2580. C    ..................................................................
  2581. C
  2582. C       SUBROUTINE AVCAL
  2583. C
  2584. C       PURPOSE
  2585. C          PERFORM THE CALCULUS OF A FACTORIAL EXPERIMENT USING
  2586. C          OPERATOR SIGMA AND OPERATOR DELTA.  THIS SUBROUTINE IS
  2587. C          PRECEDED BY SUBROUTINE ADVAT AND FOLLOWED BY SUBROUTINE
  2588. C          MEANQ IN THE PERFORMANCE OF ANALYSIS OF VARIANCE FOR A
  2589. C          COMPLETE FACTORIAL DESIGN.
  2590. C
  2591. C       USAGE
  2592. C          CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
  2593. C
  2594. C       DESCRIPTION OF PARAMETERS
  2595. C          K     - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE.
  2596. C          LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE-
  2597. C                  GORIES) WITHIN EACH VARIABLE.
  2598. C          X     - INPUT VECTOR CONTAINING DATA.  DATA HAVE BEEN PLACED
  2599. C                  IN VECTOR X BY SUBROUTINE AVDAT.  THE LENGTH OF X
  2600. C                  IS (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).
  2601. C          L     - THE POSITION IN VECTOR X WHERE THE LAST INPUT DATA
  2602. C                  IS LOCATED.  L HAS BEEN CALCULATED BY SUBROUTINE
  2603. C                  AVDAT.
  2604. C          ISTEP - INPUT VECTOR OF LENGTH K CONTAINING STORAGE CONTROL
  2605. C                  STEPS WHICH HAVE BEEN CALCULATED BY SUBROUTINE
  2606. C                  AVDAT.
  2607. C          LASTS - WORKING VECTOR OF LENGTH K.
  2608. C
  2609. C       REMARKS
  2610. C          THIS SUBROUTINE MUST FOLLOW SUBROUTINE AVDAT.
  2611. C
  2612. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2613. C          NONE
  2614. C
  2615. C       METHOD
  2616. C          THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
  2617. C          HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
  2618. C          EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
  2619. C          1962, CHAPTER 20.
  2620. C
  2621. C    ..................................................................
  2622. C
  2623.     SUBROUTINE AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
  2624.     DIMENSION LEVEL(1),X(1),ISTEP(1),LASTS(1)
  2625. C
  2626. C       ...............................................................
  2627. C
  2628. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  2629. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  2630. C       STATEMENT WHICH FOLLOWS.
  2631. C
  2632. C    DOUBLE PRECISION X,SUM
  2633. C
  2634. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  2635. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  2636. C       ROUTINE.
  2637. C
  2638. C       ...............................................................
  2639. C
  2640. C    CALCULATE THE LAST DATA POSITION OF EACH FACTOR
  2641. C
  2642.     LASTS(1)=L+1
  2643.     DO 145 I=2,K
  2644. 145    LASTS(I)=LASTS(I-1)+ISTEP(I)
  2645. C
  2646. C    PERFORM CALCULUS OF OPERATION
  2647. C
  2648. 150    DO 175 I=1,K
  2649.     L=1
  2650.     LL=1
  2651.     SUM=0.0
  2652.     NN=LEVEL(I)
  2653.     FN=NN
  2654.     INCRE=ISTEP(I)
  2655.     LAST=LASTS(I)
  2656. C
  2657. C    SIGMA OPERATION
  2658. C
  2659. 155    DO 160 J=1,NN
  2660.     SUM=SUM+X(L)
  2661. 160    L=L+INCRE
  2662.     X(L)=SUM
  2663. C
  2664. C    DELTA OPERATION
  2665. C
  2666.     DO 165 J=1,NN
  2667.     X(LL)=FN*X(LL)-SUM
  2668. 165    LL=LL+INCRE
  2669.     SUM=0.0
  2670.     IF(L-LAST) 167, 175, 175
  2671. 167    IF(L-LAST+INCRE) 168, 168, 170
  2672. 168    L=L+INCRE
  2673.     LL=LL+INCRE
  2674.     GO TO 155
  2675. 170    L=L+INCRE+1-LAST
  2676.     LL=LL+INCRE+1-LAST
  2677.     GO TO 155
  2678. 175    CONTINUE
  2679.     RETURN
  2680.     END
  2681. C
  2682. C    ..................................................................
  2683. C
  2684. C       SUBROUTINE AVDAT
  2685. C
  2686. C       PURPOSE
  2687. C          PLACE DATA FOR ANALYSIS OF VARIANCE IN PROPERLY DISTRIBUTED
  2688. C          POSITIONS OF STORAGE.  THIS SUBROUTINE IS NORMALLY FOLLOWED
  2689. C          BY CALLS TO AVCAL AND MEANQ SUBROUTINES IN THE PERFORMANCE
  2690. C          OF ANALYSIS OF VARIANCE FOR A COMPLETE FACTORIAL DESIGN.
  2691. C
  2692. C       USAGE
  2693. C          CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
  2694. C
  2695. C       DESCRIPTION OF PARAMETERS
  2696. C          K     - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE.
  2697. C          LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE-
  2698. C                  GORIES) WITHIN EACH VARIABLE.
  2699. C          N     - TOTAL NUMBER OF DATA POINTS READ IN.
  2700. C          X     - WHEN THE SUBROUTINE IS CALLED, THIS VECTOR CONTAINS
  2701. C                  DATA IN LOCATIONS X(1) THROUGH X(N).  UPON RETURNING
  2702. C                  TO THE CALLING ROUTINE, THE VECTOR CONTAINS THE DATA
  2703. C                  IN PROPERLY REDISTRIBUTED LOCATIONS OF VECTOR X.
  2704. C                  THE LENGTH OF VECTOR X IS CALCULATED BY (1) ADDING
  2705. C                  ONE TO EACH LEVEL OF VARIABLE AND (2) OBTAINING THE
  2706. C                  CUMULATIVE PRODUCT OF ALL LEVELS.  (THE LENGTH OF
  2707. C                  X = (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).)
  2708. C          L     - OUTPUT VARIABLE CONTAINING THE POSITION IN VECTOR X
  2709. C                  WHERE THE LAST INPUT DATA IS STORED.
  2710. C          ISTEP - OUTPUT VECTOR OF LENGTH K CONTAINING CONTROL STEPS
  2711. C                  WHICH ARE USED TO LOCATE DATA IN PROPER POSITIONS
  2712. C                  OF VECTOR X.
  2713. C          KOUNT - WORKING VECTOR OF LENGTH K.
  2714. C
  2715. C       REMARKS
  2716. C          INPUT DATA MUST BE ARRANGED IN THE FOLLOWING MANNER.
  2717. C          CONSIDER THE 3-VARIABLE ANALYSIS OF VARIANCE DESIGN, WHERE
  2718. C          ONE VARIABLE HAS 3 LEVELS AND THE OTHER TWO VARIABLES HAVE
  2719. C          2 LEVELS.  THE DATA MAY BE REPRESENTED IN THE FORM X(I,J,K),
  2720. C          I=1,2,3  J=1,2  K=1,2.  IN ARRANGING DATA, THE INNER
  2721. C          SUBSCRIPT, NAMELY I, CHANGES FIRST.  WHEN I=3, THE NEXT
  2722. C          INNER SUBSCRIPT, J, CHANGES AND SO ON UNTIL I=3, J=2, AND
  2723. C          K=2.
  2724. C
  2725. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2726. C          NONE
  2727. C
  2728. C       METHOD
  2729. C          THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
  2730. C          HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
  2731. C          EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
  2732. C          1962, CHAPTER 20.
  2733. C
  2734. C    ..................................................................
  2735. C
  2736.     SUBROUTINE AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
  2737.     DIMENSION LEVEL(1),X(1),ISTEP(1),KOUNT(1)
  2738. C
  2739. C       ...............................................................
  2740. C
  2741. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  2742. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  2743. C       STATEMENT WHICH FOLLOWS.
  2744. C
  2745. C    DOUBLE PRECISION X
  2746. C
  2747. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  2748. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  2749. C       ROUTINE.
  2750. C
  2751. C       ...............................................................
  2752. C
  2753. C    CALCULATE TOTAL DATA AREA REQUIRED
  2754. C
  2755.     M=LEVEL(1)+1
  2756.     DO 105 I=2,K
  2757. 105    M=M*(LEVEL(I)+1)
  2758. C
  2759. C    MOVE DATA TO THE UPPER PART OF THE ARRAY X
  2760. C    FOR THE PURPOSE OF REARRANGEMENT
  2761. C
  2762.     N1=M+1
  2763.     N2=N+1
  2764.     DO 107 I=1,N
  2765.     N1=N1-1
  2766.     N2=N2-1
  2767. 107    X(N1)=X(N2)
  2768. C
  2769. C    CALCULATE MULTIPLIERS TO BE USED IN FINDING STORAGE LOCATIONS FOR
  2770. C    INPUT DATA
  2771. C
  2772.     ISTEP(1)=1
  2773.     DO 110 I=2,K
  2774. 110    ISTEP(I)=ISTEP(I-1)*(LEVEL(I-1)+1)
  2775.     DO 115 I=1,K
  2776. 115    KOUNT(I)=1
  2777. C
  2778. C    PLACE DATA IN PROPER LOCATIONS
  2779. C
  2780.     N1=N1-1
  2781.     DO 135 I=1,N
  2782.     L=KOUNT(1)
  2783.     DO 120 J=2,K
  2784. 120    L=L+ISTEP(J)*(KOUNT(J)-1)
  2785.     N1=N1+1
  2786.     X(L)=X(N1)
  2787.     DO 130 J=1,K
  2788.     IF(KOUNT(J)-LEVEL(J)) 124, 125, 124
  2789. 124    KOUNT(J)=KOUNT(J)+1
  2790.     GO TO 135
  2791. 125    KOUNT(J)=1
  2792. 130    CONTINUE
  2793. 135    CONTINUE
  2794.     RETURN
  2795.     END
  2796. C
  2797. C    ..................................................................
  2798. C
  2799. C       SUBROUTINE BDTR
  2800. C
  2801. C       PURPOSE
  2802. C          COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U,
  2803. C          DISTRIBUTED ACCORDING TO THE BETA DISTRIBUTION WITH
  2804. C          PARAMETERS A AND B, IS LESS THAN OR EQUAL TO X.  F(A,B,X),
  2805. C          THE ORDINATE OF THE BETA DENSITY AT X, IS ALSO COMPUTED.
  2806. C
  2807. C       USAGE
  2808. C          CALL BDTR(X,A,B,P,D,IER)
  2809. C
  2810. C       DESCRIPTION OF PARAMETERS
  2811. C          X   - INPUT SCALAR FOR WHICH P(X) IS COMPUTED.
  2812. C          A   - BETA DISTRIBUTION PARAMETER (CONTINUOUS).
  2813. C          B   - BETA DISTRIBUTION PARAMETER (CONTINUOUS).
  2814. C          P   - OUTPUT PROBABILITY.
  2815. C          D   - OUTPUT DENSITY.
  2816. C          IER - RESULTANT ERROR CODE WHERE
  2817. C              IER= 0 --- NO ERROR
  2818. C              IER=-1,+1  CDTR HAS BEEN CALLED AND AN ERROR HAS
  2819. C                         OCCURRED.  SEE CDTR.
  2820. C              IER=-2 --- AN INPUT PARAMETER IS INVALID.  X IS LESS
  2821. C                         THAN 0.0 OR GREATER THAN 1.0, OR EITHER A OR
  2822. C                         B IS LESS THAN 0.5 OR GREATER THAN 10**(+5).
  2823. C                         P AND D ARE SET TO -1.7E38.                          0
  2824. C              IER=+2 --- INVALID OUTPUT.  P IS LESS THAN ZERO OR
  2825. C                         GREATER THAN ONE.  P IS SET TO 1.7E38.               0
  2826. C
  2827. C       REMARKS
  2828. C          SEE MATHEMATICAL DESCRIPTION.
  2829. C
  2830. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  2831. C          DLGAM
  2832. C          NDTR
  2833. C          CDTR
  2834. C
  2835. C       METHOD
  2836. C          REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL
  2837. C          DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE,
  2838. C          IBM RESEARCH REPORT RC-1094, 1963.
  2839. C
  2840. C    ..................................................................
  2841. C
  2842.     SUBROUTINE BDTR(X,A,B,P,D,IER)
  2843.     DOUBLE PRECISION XX,DLXX,DL1X,AA,BB,G1,G2,G3,G4,DD,PP,XO,FF,FN,
  2844.      1XI,SS,CC,RR,DLBETA
  2845. C
  2846. C       TEST FOR VALID INPUT DATA
  2847. C
  2848.     IF(A-(.5-1.E-5)) 640,10,10
  2849. 10    IF(B-(.5-1.E-5)) 640,20,20
  2850. 20    IF(A-1.E+5) 30,30,640
  2851. 30    IF(B-1.E+5) 40,40,640
  2852. 40    IF(X) 640,50,50
  2853. 50    IF(1.-X) 640,60,60
  2854. C
  2855. C       COMPUTE LOG(BETA(A,B))
  2856. C
  2857. 60    AA=DBLE(A)
  2858.     BB=DBLE(B)
  2859.     CALL DLGAM(AA,G1,IOK)
  2860.     CALL DLGAM(BB,G2,IOK)
  2861.     CALL DLGAM(AA+BB,G3,IOK)
  2862.     DLBETA=G1+G2-G3
  2863. C
  2864. C       TEST FOR X NEAR 0.0 OR 1.0
  2865. C
  2866.     IF(X-1.E-8) 80,80,70
  2867. 70    IF((1.-X)-1.E-8) 130,130,140
  2868. 80    P=0.0
  2869.     IF(A-1.) 90,100,120
  2870. 90    D=1.7E38
  2871.     GO TO 660
  2872. 100    DD=-DLBETA
  2873.     IF(DD+1.68D02)  120,120,110
  2874. 110    DD=DEXP(DD)
  2875.     D=SNGL(DD)
  2876.     GO TO 660
  2877. 120    D=0.0
  2878.     GO TO 660
  2879. 130    P=1.0
  2880.     IF(B-1.) 90,100,120
  2881. C
  2882. C       SET PROGRAM PARAMETERS
  2883. C
  2884. 140    XX=DBLE(X)
  2885.     DLXX=DLOG(XX)
  2886.     DL1X=DLOG(1.D0-XX)
  2887.     XO=XX/(1.D0-XX)
  2888.     ID=0
  2889. C
  2890. C       COMPUTE ORDINATE
  2891. C
  2892.     DD=(AA-1.D0)*DLXX+(BB-1.D0)*DL1X-DLBETA
  2893.     IF(DD-1.68D02) 150,150,160
  2894. 150    IF(DD+1.68D02) 170,170,180
  2895. 160    D=1.7E38                                                                  0
  2896.     GO TO 190
  2897. 170    D=0.0
  2898.     GO TO 190
  2899. 180    DD=DEXP(DD)
  2900.     D=SNGL(DD)
  2901. C
  2902. C       A OR B OR BOTH WITHIN 1.E-8 OF 1.0
  2903. C
  2904. 190    IF(ABS(A-1.)-1.E-8)  200,200,210
  2905. 200    IF(ABS(B-1.)-1.E-8)  220,220,230
  2906. 210    IF(ABS(B-1.)-1.E-8)  260,260,290
  2907. 220    P=X
  2908.     GO TO 660
  2909. 230    PP=BB*DL1X
  2910.     IF(PP+1.68D02) 240,240,250
  2911. 240    P=1.0
  2912.     GO TO 660
  2913. 250    PP=DEXP(PP)
  2914.     PP=1.D0-PP
  2915.     P=SNGL(PP)
  2916.     GO TO 600
  2917. 260    PP=AA*DLXX
  2918.     IF(PP+1.68D02) 270,270,280
  2919. 270    P=0.0
  2920.     GO TO 660
  2921. 280    PP=DEXP(PP)
  2922.     P=SNGL(PP)
  2923.     GO TO 600
  2924. C
  2925. C       TEST FOR A OR B GREATER THAN 1000.0
  2926. C
  2927. 290    IF(A-1000.) 300,300,310
  2928. 300    IF(B-1000.) 330,330,320
  2929. 310    XX=2.D0*AA/XO
  2930.     XS=SNGL(XX)
  2931.     AA=2.D0*BB
  2932.     DF=SNGL(AA)
  2933.     CALL CDTR(XS,DF,P,DUMMY,IER)
  2934.     P=1.0-P
  2935.     GO TO 670
  2936. 320    XX=2.D0*BB*XO
  2937.     XS=SNGL(XX)
  2938.     AA=2.D0*AA
  2939.     DF=SNGL(AA)
  2940.     CALL CDTR(XS,DF,P,DUMMY,IER)
  2941.     GO TO 670
  2942. C
  2943. C       SELECT PARAMETERS FOR CONTINUED FRACTION COMPUTATION
  2944. C
  2945. 330    IF(X-.5) 340,340,380
  2946. 340    IF(AA-1.D0) 350,350,360
  2947. 350    RR=AA+1.D0
  2948.     GO TO 370
  2949. 360    RR=AA
  2950. 370    DD=DLXX/5.D0
  2951.     DD=DEXP(DD)
  2952.     DD=(RR-1.D0)-(RR+BB-1.D0)*XX*DD +2.D0
  2953.     IF(DD) 420,420,430
  2954. 380    IF(BB-1.D0) 390,390,400
  2955. 390    RR=BB+1.D0
  2956.     GO TO 410
  2957. 400    RR=BB
  2958. 410    DD=DL1X/5.D0
  2959.     DD=DEXP(DD)
  2960.     DD=(RR-1.D0)-(AA+RR-1.D0)*(1.D0-XX)*DD +2.D0
  2961.     IF(DD) 430,430,420
  2962. 420    ID=1
  2963.     FF=DL1X
  2964.     DL1X=DLXX
  2965.     DLXX=FF
  2966.     XO=1.D0/XO
  2967.     FF=AA
  2968.     AA=BB
  2969.     BB=FF
  2970.     G2=G1
  2971. C
  2972. C       TEST FOR A LESS THAN 1.0
  2973. C
  2974. 430    FF=0.D0
  2975.     IF(AA-1.D0) 440,440,470
  2976. 440    CALL DLGAM(AA+1.D0,G4,IOK)
  2977.     DD=AA*DLXX+BB*DL1X+G3-G2-G4
  2978.     IF(DD+1.68D02) 460,460,450
  2979. 450    FF=FF+DEXP(DD)
  2980. 460    AA=AA+1.D0
  2981. C
  2982. C       COMPUTE P USING CONTINUED FRACTION EXPANSION
  2983. C
  2984. 470    FN=AA+BB-1.D0
  2985.     RR=AA-1.D0
  2986.     II=80
  2987.     XI=DFLOAT(II)
  2988.     SS=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI))
  2989.     SS=SS*XO
  2990.     DO 480 I=1,79
  2991.     II=80-I
  2992.     XI=DFLOAT(II)
  2993.     DD=(XI*(FN+XI))/((RR+2.D0*XI+1.D0)*(RR+2.D0*XI))
  2994.     DD=DD*XO
  2995.     CC=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI))
  2996.     CC=CC*XO
  2997.     SS=CC/(1.D0+DD/(1.D0-SS))
  2998. 480    CONTINUE
  2999.     SS=1.D0/(1.D0-SS)
  3000.     IF(SS) 650,650,490
  3001. 490    CALL DLGAM(AA+BB,G1,IOK)
  3002.     CALL DLGAM(AA+1.D0,G4,IOK)
  3003.     CC=G1-G2-G4+AA*DLXX+(BB-1.D0)*DL1X
  3004.     PP=CC+DLOG(SS)
  3005.     IF(PP+1.68D02) 500,500,510
  3006. 500    PP=FF
  3007.     GO TO 520
  3008. 510    PP=DEXP(PP)+FF
  3009. 520    IF(ID) 540,540,530
  3010. 530    PP=1.D0-PP
  3011. 540    P=SNGL(PP)
  3012. C
  3013. C       SET ERROR INDICATOR
  3014. C
  3015.     IF(P) 550,570,570
  3016. 550    IF(ABS(P)-1.E-7) 560,560,650
  3017. 560    P=0.0
  3018.     GO TO 660
  3019. 570    IF(1.-P) 580,600,600
  3020. 580    IF(ABS(1.-P)-1.E-7) 590,590,650
  3021. 590    P=1.0
  3022.     GO TO 660
  3023. 600    IF(P-1.E-8) 610,610,620
  3024. 610    P=0.0
  3025.     GO TO 660
  3026. 620    IF((1.0-P)-1.E-8) 630,630,660
  3027. 630    P=1.0
  3028.     GO TO 660
  3029. 640    IER=-2
  3030.     D=-1.7E38                                                                 0
  3031.     P=-1.7E38                                                                 0
  3032.     GO TO 670
  3033. 650    IER=+2
  3034.     P= 1.7E38                                                                 0
  3035.     GO TO 670
  3036. 660    IER=0
  3037. 670    RETURN
  3038.     END
  3039. C
  3040. C    ..................................................................
  3041. C
  3042. C       SUBROUTINE BESJ
  3043. C
  3044. C       PURPOSE
  3045. C          COMPUTE THE J BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
  3046. C
  3047. C       USAGE
  3048. C          CALL BESJ(X,N,BJ,D,IER)
  3049. C
  3050. C       DESCRIPTION OF PARAMETERS
  3051. C          X  -THE ARGUMENT OF THE J BESSEL FUNCTION DESIRED
  3052. C          N  -THE ORDER OF THE J BESSEL FUNCTION DESIRED
  3053. C          BJ -THE RESULTANT J BESSEL FUNCTION
  3054. C          D  -REQUIRED ACCURACY
  3055. C          IER-RESULTANT ERROR CODE WHERE
  3056. C             IER=0  NO ERROR
  3057. C             IER=1  N IS NEGATIVE
  3058. C             IER=2  X IS NEGATIVE OR ZERO
  3059. C             IER=3  REQUIRED ACCURACY NOT OBTAINED
  3060. C             IER=4  RANGE OF N COMPARED TO X NOT CORRECT (SEE REMARKS)
  3061. C
  3062. C       REMARKS
  3063. C          N MUST BE GREATER THAN OR EQUAL TO ZERO, BUT IT MUST BE
  3064. C          LESS THAN
  3065. C             20+10*X-X** 2/3   FOR X LESS THAN OR EQUAL TO 15
  3066. C             90+X/2           FOR X GREATER THAN 15
  3067. C
  3068. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3069. C          NONE
  3070. C
  3071. C       METHOD
  3072. C          RECURRENCE RELATION TECHNIQUE DESCRIBED BY H. GOLDSTEIN AND
  3073. C          R.M. THALER,'RECURRENCE TECHNIQUES FOR THE CALCULATION OF
  3074. C          BESSEL FUNCTIONS',M.T.A.C.,V.13,PP.102-108 AND I.A. STEGUN
  3075. C          AND M. ABRAMOWITZ,'GENERATION OF BESSEL FUNCTIONS ON HIGH
  3076. C          SPEED COMPUTERS',M.T.A.C.,V.11,1957,PP.255-257
  3077. C
  3078. C    ..................................................................
  3079. C
  3080.     SUBROUTINE BESJ(X,N,BJ,D,IER)
  3081. C
  3082.     BJ=.0
  3083.     IF(N)10,20,20
  3084. 10    IER=1
  3085.     RETURN
  3086. 20    IF(X)30,30,31
  3087. 30    IER=2
  3088.     RETURN
  3089. 31    IF(X-15.)32,32,34
  3090. 32    NTEST=20.+10.*X-X** 2/3
  3091.     GO TO 36
  3092. 34    NTEST=90.+X/2.
  3093. 36    IF(N-NTEST)40,38,38
  3094. 38    IER=4
  3095.     RETURN
  3096. 40    IER=0
  3097.     N1=N+1
  3098.     BPREV=.0
  3099. C
  3100. C    COMPUTE STARTING VALUE OF M
  3101. C
  3102.     IF(X-5.)50,60,60
  3103. 50    MA=X+6.
  3104.     GO TO 70
  3105. 60    MA=1.4*X+60./X
  3106. 70    MB=N+IFIX(X)/4+2
  3107.     MZERO=MAX0(MA,MB)
  3108. C
  3109. C    SET UPPER LIMIT OF M
  3110. C
  3111.     MMAX=NTEST
  3112. 100    DO 190 M=MZERO,MMAX,3
  3113. C
  3114. C    SET F(M),F(M-1)
  3115. C
  3116.     FM1=1.0E-28
  3117.     FM=.0
  3118.     ALPHA=.0
  3119.     IF(M-(M/2)*2)120,110,120
  3120. 110    JT=-1
  3121.     GO TO 130
  3122. 120    JT=1
  3123. 130    M2=M-2
  3124.     DO 160 K=1,M2
  3125.     MK=M-K
  3126.     BMK=2.*FLOAT(MK)*FM1/X-FM
  3127.     FM=FM1
  3128.     FM1=BMK
  3129.     IF(MK-N-1)150,140,150
  3130. 140    BJ=BMK
  3131. 150    JT=-JT
  3132.     S=1+JT
  3133. 160    ALPHA=ALPHA+BMK*S
  3134.     BMK=2.*FM1/X-FM
  3135.     IF(N)180,170,180
  3136. 170    BJ=BMK
  3137. 180    ALPHA=ALPHA+BMK
  3138.     BJ=BJ/ALPHA
  3139.     IF(ABS(BJ-BPREV)-ABS(D*BJ))200,200,190
  3140. 190    BPREV=BJ
  3141.     IER=3
  3142. 200    RETURN
  3143.     END
  3144. C
  3145. C    ..................................................................
  3146. C
  3147. C       SUBROUTINE BESK
  3148. C
  3149. C          COMPUTE THE K BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
  3150. C
  3151. C       USAGE
  3152. C          CALL BESK(X,N,BK,IER)
  3153. C
  3154. C       DESCRIPTION OF PARAMETERS
  3155. C          X  -THE ARGUMENT OF THE K BESSEL FUNCTION DESIRED
  3156. C          N  -THE ORDER OF THE K BESSEL FUNCTION DESIRED
  3157. C          BK -THE RESULTANT K BESSEL FUNCTION
  3158. C          IER-RESULTANT ERROR CODE WHERE
  3159. C             IER=0  NO ERROR
  3160. C             IER=1  N IS NEGATIVE
  3161. C             IER=2  X IS ZERO OR NEGATIVE
  3162. C             IER=3  X .GT. 170, MACHINE RANGE EXCEEDED
  3163. C             IER=4  BK .GT. 10**70
  3164. C
  3165. C       REMARKS
  3166. C          N MUST BE GREATER THAN OR EQUAL TO ZERO
  3167. C
  3168. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3169. C          NONE
  3170. C
  3171. C       METHOD
  3172. C          COMPUTES ZERO ORDER AND FIRST ORDER BESSEL FUNCTIONS USING
  3173. C          SERIES APPROXIMATIONS AND THEN COMPUTES N TH ORDER FUNCTION
  3174. C          USING RECURRENCE RELATION.
  3175. C          RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE
  3176. C          AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS
  3177. C          TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED
  3178. C          FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON,
  3179. C          'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE
  3180. C          UNIVERSITY PRESS, 1958, P. 62
  3181. C
  3182. C    ..................................................................
  3183. C
  3184.     SUBROUTINE BESK(X,N,BK,IER)
  3185.     DIMENSION T(12)
  3186.     BK=.0
  3187.     IF(N)10,11,11
  3188. 10    IER=1
  3189.     RETURN
  3190. 11    IF(X)12,12,20
  3191. 12    IER=2
  3192.     RETURN
  3193. 20    IF(X-170.0)22,22,21
  3194. 21    IER=3
  3195.     RETURN
  3196. 22    IER=0
  3197.     IF(X-1.)36,36,25
  3198. 25    A=EXP(-X)
  3199.     B=1./X
  3200.     C=SQRT(B)
  3201.     T(1)=B
  3202.     DO 26 L=2,12
  3203. 26    T(L)=T(L-1)*B
  3204.     IF(N-1)27,29,27
  3205. C
  3206. C    COMPUTE KO USING POLYNOMIAL APPROXIMATION
  3207. C
  3208. 27    G0=A*(1.2533141-.1566642*T(1)+.08811128*T(2)-.09139095*T(3)
  3209.      2+.1344596*T(4)-.2299850*T(5)+.3792410*T(6)-.5247277*T(7)
  3210.      3+.5575368*T(8)-.4262633*T(9)+.2184518*T(10)-.06680977*T(11)
  3211.      4+.009189383*T(12))*C
  3212.     IF(N)20,28,29
  3213. 28    BK=G0
  3214.     RETURN
  3215. C
  3216. C    COMPUTE K1 USING POLYNOMIAL APPROXIMATION
  3217. C
  3218. 29    G1=A*(1.2533141+.4699927*T(1)-.1468583*T(2)+.1280427*T(3)
  3219.      2-.1736432*T(4)+.2847618*T(5)-.4594342*T(6)+.6283381*T(7)
  3220.      3-.6632295*T(8)+.5050239*T(9)-.2581304*T(10)+.07880001*T(11)
  3221.      4-.01082418*T(12))*C
  3222.     IF(N-1)20,30,31
  3223. 30    BK=G1
  3224.     RETURN
  3225. C
  3226. C    FROM KO,K1 COMPUTE KN USING RECURRENCE RELATION
  3227. C
  3228. 31    DO 35 J=2,N
  3229.     GJ=2.*(FLOAT(J)-1.)*G1/X+G0
  3230.     IF(GJ-1.7E33)33,33,32
  3231. 32    IER=4
  3232.     GO TO 34
  3233. 33    G0=G1
  3234. 35    G1=GJ
  3235. 34    BK=GJ
  3236.     RETURN
  3237. 36    B=X/2.
  3238.     A=.5772157+ALOG(B)
  3239.     C=B*B
  3240.     IF(N-1)37,43,37
  3241. C
  3242. C    COMPUTE KO USING SERIES EXPANSION
  3243. C
  3244. 37    G0=-A
  3245.     X2J=1.
  3246.     FACT=1.
  3247.     HJ=.0
  3248.     DO 40 J=1,6
  3249.     RJ=1./FLOAT(J)
  3250.     X2J=X2J*C
  3251.     FACT=FACT*RJ*RJ
  3252.     HJ=HJ+RJ
  3253. 40    G0=G0+X2J*FACT*(HJ-A)
  3254.     IF(N)43,42,43
  3255. 42    BK=G0
  3256.     RETURN
  3257. C
  3258. C    COMPUTE K1 USING SERIES EXPANSION
  3259. C
  3260. 43    X2J=B
  3261.     FACT=1.
  3262.     HJ=1.
  3263.     G1=1./X+X2J*(.5+A-HJ)
  3264.     DO 50 J=2,8
  3265.     X2J=X2J*C
  3266.     RJ=1./FLOAT(J)
  3267.     FACT=FACT*RJ*RJ
  3268.     HJ=HJ+RJ
  3269. 50    G1=G1+X2J*FACT*(.5+(A-HJ)*FLOAT(J))
  3270.     IF(N-1)31,52,31
  3271. 52    BK=G1
  3272.     RETURN
  3273.     END
  3274. C
  3275. C    ..................................................................
  3276. C
  3277. C       SUBROUTINE BESY
  3278. C
  3279. C       PURPOSE
  3280. C          COMPUTE THE Y BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
  3281. C
  3282. C       USAGE
  3283. C          CALL BESY(X,N,BY,IER)
  3284. C
  3285. C       DESCRIPTION OF PARAMETERS
  3286. C          X  -THE ARGUMENT OF THE Y BESSEL FUNCTION DESIRED
  3287. C          N  -THE ORDER OF THE Y BESSEL FUNCTION DESIRED
  3288. C          BY -THE RESULTANT Y BESSEL FUNCTION
  3289. C          IER-RESULTANT ERROR CODE WHERE
  3290. C             IER=0  NO ERROR
  3291. C             IER=1  N IS NEGATIVE
  3292. C             IER=2  X IS NEGATIVE OR ZERO
  3293. C             IER=3  BY HAS EXCEEDED MAGNITUDE OF 10**70
  3294. C
  3295. C       REMARKS
  3296. C          VERY SMALL VALUES OF X MAY CAUSE THE RANGE OF THE LIBRARY
  3297. C          FUNCTION ALOG TO BE EXCEEDED
  3298. C          X MUST BE GREATER THAN ZERO
  3299. C          N MUST BE GREATER THAN OR EQUAL TO ZERO
  3300. C
  3301. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3302. C          NONE
  3303. C
  3304. C       METHOD
  3305. C          RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE
  3306. C          AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS
  3307. C          TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED
  3308. C          FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON,
  3309. C          'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE
  3310. C          UNIVERSITY PRESS, 1958, P. 62
  3311. C
  3312. C    ..................................................................
  3313. C
  3314.     SUBROUTINE BESY(X,N,BY,IER)
  3315. C
  3316. C    CHECK FOR ERRORS IN N AND X
  3317. C
  3318.     IF(N)180,10,10
  3319. 10    IER=0
  3320.     IF(X)190,190,20
  3321. C
  3322. C    BRANCH IF X LESS THAN OR EQUAL 4
  3323. C
  3324. 20    IF(X-4.0)40,40,30
  3325. C
  3326. C      COMPUTE Y0 AND Y1 FOR X GREATER THAN 4
  3327. C
  3328. 30    T1=4.0/X
  3329.     T2=T1*T1
  3330.     P0=((((-.0000037043*T2+.0000173565)*T2-.0000487613)*T2
  3331.      1  +.00017343)*T2-.001753062)*T2+.3989423
  3332.     Q0=((((.0000032312*T2-.0000142078)*T2+.0000342468)*T2
  3333.      1  -.0000869791)*T2+.0004564324)*T2-.01246694
  3334.     P1=((((.0000042414*T2-.0000200920)*T2+.0000580759)*T2
  3335.      1  -.000223203)*T2+.002921826)*T2+.3989423
  3336.     Q1=((((-.0000036594*T2+.00001622)*T2-.0000398708)*T2
  3337.      1  +.0001064741)*T2-.0006390400)*T2+.03740084
  3338.     A=2.0/SQRT(X)
  3339.     B=A*T1
  3340.     C=X-.7853982
  3341.     Y0=A*P0*SIN(C)+B*Q0*COS(C)
  3342.     Y1=-A*P1*COS(C)+B*Q1*SIN(C)
  3343.     GO TO 90
  3344. C
  3345. C      COMPUTE Y0 AND Y1 FOR X LESS THAN OR EQUAL TO 4
  3346. C
  3347. 40    XX=X/2.
  3348.     X2=XX*XX
  3349.     T=ALOG(XX)+.5772157
  3350.     SUM=0.
  3351.     TERM=T
  3352.     Y0=T
  3353.     DO 70 L=1,15
  3354.     IF(L-1)50,60,50
  3355. 50    SUM=SUM+1./FLOAT(L-1)
  3356. 60    FL=L
  3357.     TS=T-SUM
  3358.     TERM=(TERM*(-X2)/FL**2)*(1.-1./(FL*TS))
  3359. 70    Y0=Y0+TERM
  3360.     TERM = XX*(T-.5)
  3361.     SUM=0.
  3362.     Y1=TERM
  3363.     DO 80 L=2,16
  3364.     SUM=SUM+1./FLOAT(L-1)
  3365.     FL=L
  3366.     FL1=FL-1.
  3367.     TS=T-SUM
  3368.     TERM=(TERM*(-X2)/(FL1*FL))*((TS-.5/FL)/(TS+.5/FL1))
  3369. 80    Y1=Y1+TERM
  3370.     PI2=.6366198
  3371.     Y0=PI2*Y0
  3372.     Y1=-PI2/X+PI2*Y1
  3373. C
  3374. C    CHECK IF ONLY Y0 OR Y1 IS DESIRED
  3375. C
  3376. 90    IF(N-1)100,100,130
  3377. C
  3378. C    RETURN EITHER Y0 OR Y1 AS REQUIRED
  3379. C
  3380. 100    IF(N)110,120,110
  3381. 110    BY=Y1
  3382.     GO TO 170
  3383. 120    BY=Y0
  3384.     GO TO 170
  3385. C
  3386. CP    ERFORM RECURRENCE OPERATIONS TO FIND YN(X)
  3387. C
  3388. 130    YA=Y0
  3389.     YB=Y1
  3390.     K=1
  3391. 140    T=FLOAT(2*K)/X
  3392.     YC=T*YB-YA
  3393.     IF(ABS(YC)-1.7E33)145,145,141
  3394. 141    IER=3
  3395.     RETURN
  3396. 145    K=K+1
  3397.     IF(K-N)150,160,150
  3398. 150    YA=YB
  3399.     YB=YC
  3400.     GO TO 140
  3401. 160    BY=YC
  3402. 170    RETURN
  3403. 180    IER=1
  3404.     RETURN
  3405. 190    IER=2
  3406.     RETURN
  3407.     END
  3408. C
  3409. C    ..................................................................
  3410. C
  3411. C       SUBROUTINE BISER
  3412. C
  3413. C       PURPOSE
  3414. C          TO COMPUTE THE BISERIAL CORRELATION COEFFICIENT BETWEEN TWO
  3415. C          CONTINUOUS VARIABLES WHEN ONE OF THEM HAS BEEN ARTIFICIALLY
  3416. C          DICHOTOMIZED.
  3417. C
  3418. C       USAGE
  3419. C          CALL BISER (N,A,B,HI,ANS,IER)
  3420. C
  3421. C       DESCRIPTION OF PARAMETERS
  3422. C          N   - NUMBER OF OBSERVATIONS
  3423. C          A   - INPUT VECTOR OF LENGTH N CONTAINING THE CONTINUOUS
  3424. C                VARIABLE
  3425. C          B   - INPUT VECTOR OF LENGTH N CONTAINING THE DICHOTOMIZED
  3426. C                VARIABLE
  3427. C          HI  - INPUT - NUMERICAL CODE TO INDICATE THE HIGHER CATEGORY
  3428. C                OF THE DICHOTOMIZED VARIABLE.  ANY VALUE IN VECTOR B
  3429. C                EQUAL TO OR GREATER THAN HI WILL BE CLASSIFIED INTO
  3430. C                THE HIGHER CATEGORY.
  3431. C          ANS - OUTPUT VECTOR OF LENGTH 8 CONTAINING THE FOLLOWING
  3432. C                ANS(1) - MEAN OF VARIABLE A
  3433. C                ANS(2) - STANDARD DEVIATION OF VARIABLE A
  3434. C                ANS(3) - PROPORTION OF THE CASES IN THE HIGHER
  3435. C                         CATEGORY OF VARIABLE B
  3436. C                ANS(4) - PROPORTION OF THE CASES IN THE LOWER
  3437. C                         CATEGORY OF VARIABLE B
  3438. C                ANS(5) - MEAN OF VARIABLE A FOR THOSE CASES FALLING
  3439. C                         INTO THE HIGHER CATEGORY OF VARIABLE B
  3440. C                ANS(6) - MEAN OF VARIABLE A FOR THOSE CASES FALLING
  3441. C                         INTO THE LOWER CATEGORY OF VARIABLE B
  3442. C                ANS(7) - BISERIAL CORRELATION COEFFICIENT
  3443. C                ANS(8) - STANDARD ERROR OF BISERIAL CORRELATION
  3444. C                         COEFFICIENT
  3445. C          IER -  1, IF NO CASES ARE IN THE LOWER CATEGORY OF VARIABLE
  3446. C                B.
  3447. C                -1, IF ALL CASES ARE IN THE LOWER CATEGORY OF
  3448. C                VARIABLE B.
  3449. C                0, OTHERWISE.
  3450. C                IF IER IS NON-ZERO, ANS(I)=10**75,I=5,...,8.
  3451. C
  3452. C       REMARKS
  3453. C          THE VALUES OF THE DICHOTOMIZED VARIABLE, B, MUST BE IN
  3454. C          NUMERIC FORM.  THEY CANNOR BE SPECIFIED BY MEANS OF
  3455. C          ALPHABETIC OR SPECIAL CHARACTERS.
  3456. C
  3457. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3458. C          NDTRI
  3459. C
  3460. C       METHOD
  3461. C          REFER TO P. HORST, 'PSYCHOLOGICAL MEASUREMENT AND
  3462. C          PREDICTION', P.95-96 (WADSWORTH, 1966).
  3463. C
  3464. C    ..................................................................
  3465. C
  3466.     SUBROUTINE BISER (N,A,B,HI,ANS,IER)
  3467. C
  3468.     DIMENSION A(1),B(1),ANS(1)
  3469. C
  3470. C       COMPUTE MEAN AND STANDARD DEVIATION OF VARIABLE A
  3471. C
  3472.     IER=0
  3473.     SUM=0.0
  3474.     SUM2=0.0
  3475.     DO 10 I=1,N
  3476.     SUM=SUM+A(I)
  3477. 10    SUM2=SUM2+A(I)*A(I)
  3478.     FN=N
  3479.     ANS(1)=SUM/FN
  3480.     ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0)
  3481.     ANS(2)= SQRT(ANS(2))
  3482. C
  3483. C       FIND PROPORTIONS OF CASES IN THE HIGHER AND LOWER CATEGORIES
  3484. C
  3485.     P=0.0
  3486.     SUM=0.0
  3487.     SUM2=0.0
  3488.     DO 30 I=1,N
  3489.     IF(B(I)-HI) 20, 25, 25
  3490. 20    SUM2=SUM2+A(I)
  3491.     GO TO 30
  3492. 25    P=P+1.0
  3493.     SUM=SUM+A(I)
  3494. 30    CONTINUE
  3495.     ANS(4)=1.0
  3496.     ANS(3)=0.0
  3497.     Q=FN-P
  3498.     IF (P) 35,35,40
  3499. 35    IER=-1
  3500.     GO TO 50
  3501. 40    ANS(5)=SUM/P
  3502.     IF (Q) 45,45,60
  3503. 45    IER=1
  3504.     ANS(4)=0.0
  3505.     ANS(3)=1.0
  3506. 50    DO 55 I=5,8
  3507. 55    ANS(I)=1.7E38                                                             0
  3508.     GO TO 65
  3509. 60    ANS(6)=SUM2/Q
  3510.     P=P/FN
  3511.     Q=1.0-P
  3512. C
  3513. C       FIND ORDINATE OF THE NORMAL DISTRIBUTION CURVE AT THE POINT OF
  3514. C       DIVISION BETWEEN SEGMENTS CONTAINING P AND Q PROPORTIONS
  3515. C
  3516.     CALL NDTRI (Q,X,Y,ER)
  3517. C
  3518. C       COMPUTE THE BISERIAL COEFFICIENT OF CORRELATION
  3519. C
  3520.     R=((ANS(5)-ANS(1))/ANS(2))*(P/Y)
  3521. C
  3522. C       COMPUTE THE STANDARD ERROR OF R
  3523. C
  3524.     ANS(8)=( SQRT(P*Q)/Y-R*R)/SQRT(FN)
  3525. C
  3526. C       STORE RESULTS
  3527. C
  3528.     ANS(3)=P
  3529.     ANS(4)=Q
  3530.     ANS(7)=R
  3531. C
  3532. 65    RETURN
  3533.     END
  3534. C
  3535. C    ..................................................................
  3536. C
  3537. C       USER-SUPPLIED SPECIAL SUBROUTINE - BOOL
  3538. C
  3539. C       THIS SPECIAL SUBROUTINE ILLUSTRATES AN EXTERNAL SUBROUTINE
  3540. C       CALLED BY SUBROUTINE SUBST.
  3541. C
  3542. C       IF DIFFERENT PROPOSITIONS ARE USED FOR DIFFERENT PROBLEMS IN
  3543. C       THE SAME RUN, DIFFERENT SUBROUTINES WITH APPROPRIATE PROPOSI-
  3544. C       TIONS MUST BE COMPILED UNDER DIFFERENT NAMES.  IF SO, THESE
  3545. C       SUBROUTINE NAMES MUST BE DEFINED BY AN EXTERNAL STATEMENT
  3546. C       APPEARING IN THE MAIN PROGRAM WHICH CALLS SUBST.  THEN, FOR
  3547. C       EACH PROBLEM, SUBST IS CALLED WITH A PROPER SUBROUTINE NAME
  3548. C       IN ITS ARGUMENT LIST.
  3549. C
  3550. C    ..................................................................
  3551. C
  3552.     SUBROUTINE BOOL(R,T)
  3553.     DIMENSION R(1)
  3554. C
  3555.     T=R(1)*R(2)
  3556. C
  3557.     RETURN
  3558.     END
  3559. C
  3560. C    ..................................................................
  3561. C
  3562. C       SUBROUTINE BOUND
  3563. C
  3564. C       PURPOSE
  3565. C          SELECT FROM A SET (OR A SUBSET) OF OBSERVATIONS THE NUMBER
  3566. C          OF OBSERVATIONS UNDER, BETWEEN AND OVER TWO GIVEN BOUNDS
  3567. C          FOR EACH VARIABLE
  3568. C
  3569. C       USAGE
  3570. C          CALL BOUND (A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV,IER)
  3571. C
  3572. C       DESCRIPTION OF PARAMETERS
  3573. C          A     - OBSERVATION MATRIX, NO BY NV
  3574. C          S     - VECTOR INDICATING SUBSET OF A. ONLY THOSE
  3575. C                  OBSERVATIONS WITH A NON-ZERO S(J) ARE CONSIDERED.
  3576. C                  VECTOR LENGTH IS NO.
  3577. C          BLO   - INPUT VECTOR OF LOWER BOUNDS ON ALL VARIABLES.
  3578. C                  VECTOR LENGTH IS NV.
  3579. C          BHI   - INPUT VECTOR OF UPPER BOUNDS ON ALL VARIABLES.
  3580. C                  VECTOR LENGTH IS NV.
  3581. C          UNDER - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
  3582. C                  OF OBSERVATIONS UNDER LOWER BOUNDS. VECTOR LENGTH
  3583. C                  IS NV.
  3584. C          BETW  - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
  3585. C                  OF OBSERVATIONS EQUAL TO OR BETWEEN LOWER AND UPPER
  3586. C                  BOUNDS. VECTOR LENGTH IS NV.
  3587. C          OVER  - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
  3588. C                  OF OBSERVATIONS OVER UPPER BOUNDS. VECTOR LENGTH
  3589. C                  IS NV.
  3590. C          NO    - NUMBER OF OBSERVATIONS
  3591. C          NV    - NUMBER OF VARIABLES FOR EACH OBSERVATION
  3592. C          IER   - ZERO, IF NO ERROR.
  3593. C                - 1, IF LOWER BOUND IS GREATER THAN THE UPPER BOUND
  3594. C                  FOR SOME VARIABLE
  3595. C
  3596. C       REMARKS
  3597. C          NONE
  3598. C
  3599. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3600. C          NONE
  3601. C
  3602. C       METHOD
  3603. C          EACH ROW (OBSERVATION) OF MATRIX A WITH CORRESPONDING
  3604. C          NON-ZERO ELEMENT IN S VECTOR IS TESTED. OBSERVATIONS ARE
  3605. C          COMPARED WITH SPECIFIED LOWER AND UPPER VARIABLE BOUNDS AND
  3606. C          A COUNT IS KEPT IN VECTORS UNDER, BETWEEN, AND OVER.
  3607. C
  3608. C    ..................................................................
  3609. C
  3610.     SUBROUTINE BOUND(A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV)
  3611.     DIMENSION A(1),S(1),BLO(1),BHI(1),UNDER(1),BETW(1),OVER(1)
  3612. C
  3613. C       CLEAR OUTPUT VECTORS.
  3614. C
  3615.     IER=0
  3616.     DO 10 I=1,NV
  3617.     IF (BLO(I)-BHI(I)) 10,10,11
  3618. 11    IER=1
  3619.     GO TO 12
  3620. 10    CONTINUE
  3621.     DO 1 K=1,NV
  3622.     UNDER(K)=0.0
  3623.     BETW(K)=0.0
  3624. 1    OVER(K)=0.0
  3625. C
  3626. C       TEST SUBSET VECTOR
  3627. C
  3628.     DO 8 J=1,NO
  3629.     IJ=J-NO
  3630.     IF(S(J)) 2,8,2
  3631. C
  3632. C       COMPARE OBSERVATIONS WITH BOUNDS
  3633. C
  3634. 2    DO 7 I=1,NV
  3635.     IJ=IJ+NO
  3636.     IF(A(IJ)-BLO(I)) 5,3,3
  3637. 3    IF(A(IJ)-BHI(I)) 4,4,6
  3638. C
  3639. C      COUNT
  3640. C
  3641. 4    BETW(I)=BETW(I)+1.0
  3642.     GO TO 7
  3643. 5    UNDER(I)=UNDER(I)+1.0
  3644.     GO TO 7
  3645. 6    OVER(I)=OVER(I)+1.0
  3646. 7    CONTINUE
  3647. 8    CONTINUE
  3648. 12    RETURN
  3649.     END
  3650. C
  3651. C    ..................................................................
  3652. C
  3653. C       SUBROUTINE CADD
  3654. C
  3655. C       PURPOSE
  3656. C          ADD COLUMN OF ONE MATRIX TO COLUMN OF ANOTHER MATRIX
  3657. C
  3658. C       USAGE
  3659. C          CALL CADD(A,ICA,R,ICR,N,M,MS,L)
  3660. C
  3661. C       DESCRIPTION OF PARAMETERS
  3662. C          A   - NAME OF INPUT MATRIX
  3663. C          ICA - COLUMN IN MATRIX A TO BE ADDED TO COLUMN ICR OF R
  3664. C          R   - NAME OF OUTPUT MATRIX
  3665. C          ICR - COLUMN IN MATRIX R WHERE SUMMATION IS DEVELOPED
  3666. C          N   - NUMBER OF ROWS IN A AND R
  3667. C          M   - NUMBER OF COLUMNS IN A
  3668. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  3669. C                 0 - GENERAL
  3670. C                 1 - SYMMETRIC
  3671. C                 2 - DIAGONAL
  3672. C          L   - NUMBER OF COLUMNS IN R
  3673. C
  3674. C       REMARKS
  3675. C          MATRIX R MUST BE A GENERAL MATRIX
  3676. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A UNLESS
  3677. C          A IS GENERAL
  3678. C
  3679. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3680. C          LOC
  3681. C
  3682. C       METHOD
  3683. C          EACH ELEMENT OF COLUMN ICA OF MATRIX A IS ADDED TO
  3684. C          CORRESPONDING ELEMENT OF COLUMN ICR OF MATRIX R
  3685. C
  3686. C    ..................................................................
  3687. C
  3688.     SUBROUTINE CADD(A,ICA,R,ICR,N,M,MS,L)
  3689.     DIMENSION A(1),R(1)
  3690. C
  3691.     IR=N*(ICR-1)
  3692.     DO 2 I=1,N
  3693.     IR=IR+1
  3694. C
  3695. C       LOCATE INPUT ELEMENT FOR ANY MATRIX STORAGE MODE
  3696. C
  3697.     CALL LOC(I,ICA,IA,N,M,MS)
  3698. C
  3699. C       TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
  3700. C
  3701.     IF(IA) 1,2,1
  3702. C
  3703. C       ADD ELEMENTS
  3704. C
  3705. 1    R(IR)=R(IR)+A(IA)
  3706. 2    CONTINUE
  3707.     RETURN
  3708.     END
  3709. C
  3710. C    ..................................................................
  3711. C
  3712. C       SUBROUTINE CANOR
  3713. C
  3714. C       PURPOSE
  3715. C          COMPUTE THE CANONICAL CORRELATIONS BETWEEN TWO SETS OF
  3716. C          VARIABLES.  CANOR IS NORMALLY PRECEDED BY A CALL TO SUBROU-
  3717. C          TINE CORRE.
  3718. C
  3719. C       USAGE
  3720. C          CALL CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR,
  3721. C                      COEFL,R)
  3722. C
  3723. C       DESCRIPTION OF PARAMETERS
  3724. C          N     - NUMBER OF OBSERVATIONS
  3725. C          MP    - NUMBER OF LEFT HAND VARIABLES
  3726. C          MQ    - NUMBER OF RIGHT HAND VARIABLES
  3727. C          RR    - INPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
  3728. C                  SYMMETRIC MATRIX OF M X M, WHERE M = MP + MQ)
  3729. C                  CONTAINING CORRELATION COEFFICIENTS.  (STORAGE MODE
  3730. C                  OF 1)
  3731. C          ROOTS - OUTPUT VECTOR OF LENGTH MQ CONTAINING EIGENVALUES
  3732. C                  COMPUTED IN THE NROOT SUBROUTINE.
  3733. C          WLAM  - OUTPUT VECTOR OF LENGTH MQ CONTAINING LAMBDA.
  3734. C          CANR  - OUTPUT VECTOR OF LENGTH MQ CONTAINING CANONICAL
  3735. C                  CORRELATIONS.
  3736. C          CHISQ - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE
  3737. C                  VALUES OF CHI-SQUARES.
  3738. C          NDF   - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE DEGREES
  3739. C                  OF FREEDOM ASSOCIATED WITH CHI-SQUARES.
  3740. C          COEFR - OUTPUT MATRIX (MQ X MQ) CONTAINING MQ SETS OF
  3741. C                  RIGHT HAND COEFFICIENTS COLUMNWISE.
  3742. C          COEFL - OUTPUT MATRIX (MP X MQ) CONTAINING MQ SETS OF
  3743. C                  LEFT HAND COEFFICIENTS COLUMNWISE.
  3744. C          R     - WORK MATRIX (M X M)
  3745. C
  3746. C       REMARKS
  3747. C          THE NUMBER OF LEFT HAND VARIABLES (MP) SHOULD BE GREATER
  3748. C          THAN OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES (MQ).
  3749. C          THE VALUES OF CANONICAL CORRELATION, LAMBDA, CHI-SQUARE,
  3750. C          DEGREES OF FREEDOM, AND CANONICAL COEFFICIENTS ARE COMPUTED
  3751. C          ONLY FOR THOSE EIGENVALUES IN ROOTS WHICH ARE GREATER THAN
  3752. C          ZERO.
  3753. C
  3754. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3755. C          MINV
  3756. C          NROOT  (WHICH, IN TURN, CALLS THE SUBROUTINE EIGEN.)
  3757. C
  3758. C       METHOD
  3759. C          REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-
  3760. C          CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,
  3761. C          1962, CHAPTER 3.
  3762. C
  3763. C    ..................................................................
  3764. C
  3765.     SUBROUTINE CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR,
  3766.      1                  COEFL,R)
  3767.       DIMENSION RR(1),ROOTS(1),WLAM(1),CANR(1),CHISQ(1),NDF(1),COEFR(1),
  3768.      1          COEFL(1),R(1)
  3769. C
  3770. C       ...............................................................
  3771. C
  3772. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  3773. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  3774. C       STATEMENT WHICH FOLLOWS.
  3775. C
  3776. C    DOUBLE PRECISION RR,ROOTS,WLAM,CANR,CHISQ,COEFR,COEFL,R,DET,SUM
  3777. C
  3778. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  3779. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  3780. C       ROUTINE.
  3781. C
  3782. C       THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
  3783. C       CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENT
  3784. C       165 MUST BE CHANGED TO DSQRT.  ALOG IN STATEMENT 175 MUST BE
  3785. C       CHANGED TO DLOG.
  3786. C
  3787. C       ...............................................................
  3788. C
  3789. C    PARTITION INTERCORRELATIONS AMONG LEFT HAND VARIABLES, BETWEEN
  3790. C    LEFT AND RIGHT HAND VARIABLES, AND AMONG RIGHT HAND VARIABLES.
  3791. C
  3792.     M=MP+MQ
  3793.     N1=0
  3794.     DO 105 I=1,M
  3795.     DO 105 J=1,M
  3796.     IF(I-J) 102, 103, 103
  3797. 102    L=I+(J*J-J)/2
  3798.     GO TO 104
  3799. 103    L=J+(I*I-I)/2
  3800. 104    N1=N1+1
  3801. 105     R(N1)=RR(L)
  3802.     L=MP
  3803.     DO 108 J=2,MP
  3804.     N1=M*(J-1)
  3805.     DO 108 I=1,MP
  3806.     L=L+1
  3807.     N1=N1+1
  3808. 108     R(L)=R(N1)
  3809.     N2=MP+1
  3810.     L=0
  3811.     DO 110 J=N2,M
  3812.     N1=M*(J-1)
  3813.     DO 110 I=1,MP
  3814.     L=L+1
  3815.     N1=N1+1
  3816. 110    COEFL(L)=R(N1)
  3817.     L=0
  3818.     DO 120 J=N2,M
  3819.     N1=M*(J-1)+MP
  3820.     DO 120 I=N2,M
  3821.     L=L+1
  3822.     N1=N1+1
  3823. 120    COEFR(L)=R(N1)
  3824. C
  3825. C    SOLVE THE CANONICAL EQUATION
  3826. C
  3827.     L=MP*MP+1
  3828.     K=L+MP
  3829.     CALL MINV (R,MP,DET,R(L),R(K))
  3830. C
  3831. C       CALCULATE T = INVERSE OF R11 * R12
  3832. C
  3833.     DO 140 I=1,MP
  3834.     N2=0
  3835.     DO 130 J=1,MQ
  3836.     N1=I-MP
  3837.     ROOTS(J)=0.0
  3838.     DO 130 K=1,MP
  3839.     N1=N1+MP
  3840.     N2=N2+1
  3841. 130    ROOTS(J)=ROOTS(J)+R(N1)*COEFL(N2)
  3842.     L=I-MP
  3843.     DO 140 J=1,MQ
  3844.     L=L+MP
  3845. 140    R(L)=ROOTS(J)
  3846. C
  3847. C       CALCULATE A = R21 * T
  3848. C
  3849.     L=MP*MQ
  3850.     N3=L+1
  3851.     DO 160 J=1,MQ
  3852.     N1=0
  3853.     DO 160 I=1,MQ
  3854.     N2=MP*(J-1)
  3855.     SUM=0.0
  3856.     DO 150 K=1,MP
  3857.     N1=N1+1
  3858.     N2=N2+1
  3859. 150    SUM=SUM+COEFL(N1)*R(N2)
  3860.     L=L+1
  3861. 160    R(L)=SUM
  3862. C
  3863. C       CALCULATE EIGENVALUES WITH ASSOCIATED EIGENVECTORS OF THE
  3864. C       INVERSE OF R22 * A
  3865. C
  3866.     L=L+1
  3867.     CALL NROOT (MQ,R(N3),COEFR,ROOTS,R(L))
  3868. C
  3869. C    FOR EACH VALUE OF I = 1, 2, ..., MQ, CALCULATE THE FOLLOWING
  3870. C    STATISTICS
  3871. C
  3872.     DO 210 I=1,MQ
  3873. C
  3874. C       TEST WHETHER EIGENVALUE IS GREATER THAN ZERO
  3875. C
  3876.     IF(ROOTS(I)) 220, 220, 165
  3877. C
  3878. C       CANONICAL CORRELATION
  3879. C
  3880. 165    CANR(I)= SQRT(ROOTS(I))
  3881. C
  3882. C       CHI-SQUARE
  3883. C
  3884.     WLAM(I)=1.0
  3885.     DO 170 J=I,MQ
  3886. 170    WLAM(I)=WLAM(I)*(1.0-ROOTS(J))
  3887.     FN=N
  3888.     FMP=MP
  3889.     FMQ=MQ
  3890. 175    CHISQ(I)=-(FN-0.5*(FMP+FMQ+1.0))*ALOG(WLAM(I))
  3891. C
  3892. C       DEGREES OF FREEDOM FOR CHI-SQUARE
  3893. C
  3894.     N1=I-1
  3895.     NDF(I)=(MP-N1)*(MQ-N1)
  3896. C
  3897. C       I-TH SET OF RIGHT HAND COEFFICIENTS
  3898. C
  3899.     N1=MQ*(I-1)
  3900.     N2=MQ*(I-1)+L-1
  3901.     DO 180 J=1,MQ
  3902.     N1=N1+1
  3903.     N2=N2+1
  3904. 180    COEFR(N1)=R(N2)
  3905. C
  3906. C       I-TH SET OF LEFT HAND COEFFICIENTS
  3907. C
  3908.     DO 200 J=1,MP
  3909.     N1=J-MP
  3910.     N2=MQ*(I-1)
  3911.     K=MP*(I-1)+J
  3912.     COEFL(K)=0.0
  3913.     DO 190 JJ=1,MQ
  3914.     N1=N1+MP
  3915.     N2=N2+1
  3916. 190    COEFL(K)=COEFL(K)+R(N1)*COEFR(N2)
  3917. 200    COEFL(K)=COEFL(K)/CANR(I)
  3918. 210    CONTINUE
  3919. 220    RETURN
  3920.     END
  3921. C
  3922. C    ..................................................................
  3923. C
  3924. C       SUBROUTINE CCPY
  3925. C
  3926. C       PURPOSE
  3927. C          COPY SPECIFIED COLUMN OF A MATRIX INTO A VECTOR
  3928. C
  3929. C       USAGE
  3930. C          CALL CCPY(A,L,R,N,M,MS)
  3931. C
  3932. C       DESCRIPTION OF PARAMETERS
  3933. C          A - NAME OF INPUT MATRIX
  3934. C          L - COLUMN OF A TO BE MOVED TO R
  3935. C          R - NAME OF OUTPUT VECTOR OF LENGTH N
  3936. C          N - NUMBER OR ROWS IN A
  3937. C          M - NUMBER OF COLUMNS IN A
  3938. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  3939. C                 0 - GENERAL
  3940. C                 1 - SYMMETRIC
  3941. C                 2 - DIAGONAL
  3942. C
  3943. C       REMARKS
  3944. C          NONE
  3945. C
  3946. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  3947. C          LOC
  3948. C
  3949. C       METHOD
  3950. C          ELEMENTS OF COLUMN L ARE MOVED TO CORRESPONDING POSITIONS
  3951. C          OF VECTOR R
  3952. C
  3953. C    ..................................................................
  3954. C
  3955.     SUBROUTINE CCPY(A,L,R,N,M,MS)
  3956.     DIMENSION A(1),R(1)
  3957. C
  3958.     DO 3 I=1,N
  3959. C
  3960. C       LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
  3961. C
  3962.     CALL LOC(I,L,IL,N,M,MS)
  3963. C
  3964. C       TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
  3965. C
  3966.     IF(IL) 1,2,1
  3967. C
  3968. C       MOVE ELEMENT TO R
  3969. C
  3970. 1    R(I)=A(IL)
  3971.     GO TO 3
  3972. 2    R(I)=0.0
  3973. 3    CONTINUE
  3974.     RETURN
  3975.     END
  3976. C
  3977. C    ..................................................................
  3978. C
  3979. C       SUBROUTINE CCUT
  3980. C
  3981. C       PURPOSE
  3982. C          PARTITION A MATRIX BETWEEN SPECIFIED COLUMNS TO FORM TWO
  3983. C          RESULTANT MATRICES
  3984. C
  3985. C       USAGE
  3986. C          CALL CCUT (A,L,R,S,N,M,MS)
  3987. C
  3988. C       DESCRIPTION OF PARAMETERS
  3989. C          A - NAME OF INPUT MATRIX
  3990. C          L - COLUMN OF A TO THE LEFT OF WHICH PARTITIONING TAKES
  3991. C              PLACE
  3992. C          R - NAME OF MATRIX TO BE FORMED FROM LEFT PORTION OF A
  3993. C          S - NAME OF MATRIX TO BE FORMED FROM RIGHT PORTION OF A
  3994. C          N - NUMBER OF ROWS IN A
  3995. C          M - NUMBER OF COLUMNS IN A
  3996. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  3997. C                 0 - GENERAL
  3998. C                 1 - SYMMETRIC
  3999. C                 2 - DIAGONAL
  4000. C
  4001. C       REMARKS
  4002. C          MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX A
  4003. C          MATRIX S CANNOT BE IN SAME LOCATION AS MATRIX A
  4004. C          MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX S
  4005. C          MATRIX R AND MATRIX S ARE ALWAYS GENERAL MATRICES
  4006. C
  4007. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4008. C          LOC
  4009. C
  4010. C       METHOD
  4011. C          ELEMENTS OF MATRIX A TO THE LEFT OF COLUMN L ARE MOVED TO
  4012. C          FORM MATRIX R OF N ROWS AND L-1 COLUMNS. ELEMENTS OF
  4013. C          MATRIX A IN COLUMN L AND TO THE RIGHT OF L ARE MOVED TO FORM
  4014. C          MATRIX S OF N ROWS AND M-L+1 COLUMNS.
  4015. C
  4016. C    ..................................................................
  4017. C
  4018.     SUBROUTINE CCUT(A,L,R,S,N,M,MS)
  4019.     DIMENSION A(1),R(1),S(1)
  4020. C
  4021.     IR=0
  4022.     IS=0
  4023.     DO 70 J=1,M
  4024.     DO 70 I=1,N
  4025. C
  4026. C       FIND LOCATION IN OUTPUT MATRIX AND SET TO ZERO
  4027. C
  4028.     IF(J-L) 20,10,10
  4029. 10    IS=IS+1
  4030.     S(IS)=0.0
  4031.     GO TO 30
  4032. 20    IR=IR+1
  4033.     R(IR)=0.0
  4034. C
  4035. C       LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
  4036. C
  4037. 30    CALL LOC(I,J,IJ,N,M,MS)
  4038. C
  4039. C       TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
  4040. C
  4041.     IF(IJ) 40,70,40
  4042. C
  4043. C       DETERMINE WHETHER RIGHT OR LEFT OF L
  4044. C
  4045. 40    IF(J-L) 60,50,50
  4046. 50    S(IS)=A(IJ)
  4047.     GO TO 70
  4048. 60    R(IR)=A(IJ)
  4049. 70    CONTINUE
  4050.     RETURN
  4051.     END
  4052. C
  4053. C    ..................................................................
  4054. C
  4055. C       SUBROUTINE CDTR
  4056. C
  4057. C       PURPOSE
  4058. C          COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U,
  4059. C          DISTRIBUTED ACCORDING TO THE CHI-SQUARE DISTRIBUTION WITH G
  4060. C          DEGREES OF FREEDOM, IS LESS THAN OR EQUAL TO X.  F(G,X), THE
  4061. C          ORDINATE OF THE CHI-SQUARE DENSITY AT X, IS ALSO COMPUTED.
  4062. C
  4063. C       USAGE
  4064. C          CALL CDTR(X,G,P,D,IER)
  4065. C
  4066. C       DESCRIPTION OF PARAMETERS
  4067. C          X   - INPUT SCALAR FOR WHICH P(X) IS COMPUTED.
  4068. C          G   - NUMBER OF DEGREES OF FREEDOM OF THE CHI-SQUARE
  4069. C                DISTRIBUTION.  G IS A CONTINUOUS PARAMETER.
  4070. C          P   - OUTPUT PROBABILITY.
  4071. C          D   - OUTPUT DENSITY.
  4072. C          IER - RESULTANT ERROR CODE WHERE
  4073. C              IER= 0 --- NO ERROR
  4074. C              IER=-1 --- AN INPUT PARAMETER IS INVALID.  X IS LESS
  4075. C                         THAN 0.0, OR G IS LESS THAN 0.5 OR GREATER
  4076. C                         THAN 2*10**(+5).  P AND D ARE SET TO -1.7E38.        0
  4077. C              IER=+1 --- INVALID OUTPUT.  P IS LESS THAN ZERO OR
  4078. C                         GREATER THAN ONE, OR SERIES FOR T1 (SEE
  4079. C                         MATHEMATICAL DESCRIPTION) HAS FAILED TO
  4080. C                         CONVERGE.  P IS SET TO 1.7E38.                       0
  4081. C
  4082. C       REMARKS
  4083. C          SEE MATHEMATICAL DESCRIPTION.
  4084. C
  4085. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4086. C          DLGAM
  4087. C          NDTR
  4088. C
  4089. C       METHOD
  4090. C          REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL
  4091. C          DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE,
  4092. C          IBM RESEARCH REPORT RC-1094, 1963.
  4093. C
  4094. C    ..................................................................
  4095. C
  4096.     SUBROUTINE CDTR(X,G,P,D,IER)
  4097.     DOUBLE PRECISION XX,DLXX,X2,DLX2,GG,G2,DLT3,THETA,THP1,
  4098.      1GLG2,DD,T11,SER,CC,XI,FAC,TLOG,TERM,GTH,A2,A,B,C,DT2,DT3,THPI
  4099. C
  4100. C       TEST FOR VALID INPUT DATA
  4101. C
  4102.     IF(G-(.5-1.E-5)) 590,10,10
  4103. 10    IF(G-2.E+5) 20,20,590
  4104. 20    IF(X) 590,30,30
  4105. C
  4106. C       TEST FOR X NEAR 0.0
  4107. C
  4108. 30    IF(X-1.E-8) 40,40,80
  4109. 40    P=0.0
  4110.     IF(G-2.) 50,60,70
  4111. 50    D=1.7E38                                                                  0
  4112.     GO TO 610
  4113. 60    D=0.5
  4114.     GO TO 610
  4115. 70    D=0.0
  4116.     GO TO 610
  4117. C
  4118. C       TEST FOR X GREATER THAN 1.E+6
  4119. C
  4120. 80    IF(X-1.E+6) 100,100,90
  4121. 90    D=0.0
  4122.     P=1.0
  4123.     GO TO 610
  4124. C
  4125. C       SET PROGRAM PARAMETERS
  4126. C
  4127. 100    XX=DBLE(X)
  4128.     DLXX=DLOG(XX)
  4129.     X2=XX/2.D0
  4130.     DLX2=DLOG(X2)
  4131.     GG=DBLE(G)
  4132.     G2=GG/2.D0
  4133. C
  4134. C       COMPUTE ORDINATE
  4135. C
  4136.     CALL DLGAM(G2,GLG2,IOK)
  4137.     DD=(G2-1.D0)*DLXX-X2-G2*.6931471805599453 -GLG2
  4138.     IF(DD-1.68D02) 110,110,120
  4139. 110    IF(DD+1.68D02) 130,130,140
  4140. 120    D=1.7E38                                                                  0
  4141.     GO TO 150
  4142. 130    D=0.0
  4143.     GO TO 150
  4144. 140    DD=DEXP(DD)
  4145.     D=SNGL(DD)
  4146. C
  4147. C       TEST FOR G GREATER THAN 1000.0
  4148. C       TEST FOR X GREATER THAN 2000.0
  4149. C
  4150. 150    IF(G-1000.) 160,160,180
  4151. 160    IF(X-2000.) 190,190,170
  4152. 170    P=1.0
  4153.     GO TO 610
  4154. 180    A=DLOG(XX/GG)/3.D0
  4155.     A=DEXP(A)
  4156.     B=2.D0/(9.D0*GG)
  4157.     C=(A-1.D0+B)/DSQRT(B)
  4158.     SC=SNGL(C)
  4159.     CALL NDTR(SC,P,DUMMY)
  4160.     GO TO 490
  4161. C
  4162. C       COMPUTE THETA
  4163. C
  4164. 190    K= IDINT(G2)
  4165.     THETA=G2-DFLOAT(K)
  4166.     IF(THETA-1.D-8) 200,200,210
  4167. 200    THETA=0.D0
  4168. 210    THP1=THETA+1.D0
  4169. C
  4170. C       SELECT METHOD OF COMPUTING T1
  4171. C
  4172.     IF(THETA) 230,230,220
  4173. 220    IF(XX-10.D0) 260,260,320
  4174. C
  4175. C       COMPUTE T1 FOR THETA EQUALS 0.0
  4176. C
  4177. 230    IF(X2-1.68D02) 250,240,240
  4178. 240    T1=1.0
  4179.     GO TO 400
  4180. 250    T11=1.D0-DEXP(-X2)
  4181.     T1=SNGL(T11)
  4182.     GO TO 400
  4183. C
  4184. C       COMPUTE T1 FOR THETA GREATER THAN 0.0 AND
  4185. C       X LESS THAN OR EQUAL TO 10.0
  4186. C
  4187. 260    SER=X2*(1.D0/THP1 -X2/(THP1+1.D0))
  4188.     J=+1
  4189.     CC=DFLOAT(J)
  4190.     DO 270 IT1=3,30
  4191.     XI=DFLOAT(IT1)
  4192.     CALL DLGAM(XI,FAC,IOK)
  4193.     TLOG= XI*DLX2-FAC-DLOG(XI+THETA)
  4194.     TERM=DEXP(TLOG)
  4195.     TERM=DSIGN(TERM,CC)
  4196.     SER=SER+TERM
  4197.     CC=-CC
  4198.     IF(DABS(TERM)-1.D-9) 280,270,270
  4199. 270    CONTINUE
  4200.     GO TO 600
  4201. 280    IF(SER) 600,600,290
  4202. 290    CALL DLGAM(THP1,GTH,IOK)
  4203.     TLOG=THETA*DLX2+DLOG(SER)-GTH
  4204.     IF(TLOG+1.68D02) 300,300,310
  4205. 300    T1=0.0
  4206.     GO TO 400
  4207. 310    T11=DEXP(TLOG)
  4208.     T1=SNGL(T11)
  4209.     GO TO 400
  4210. C
  4211. C       COMPUTE T1 FOR THETA GREATER THAN 0.0 AND
  4212. C       X GREATER THAN 10.0 AND LESS THAN 2000.0
  4213. C
  4214. 320    A2=0.D0
  4215.     DO 340 I=1,25
  4216.     XI=DFLOAT(I)
  4217.     CALL DLGAM(THP1,GTH,IOK)
  4218.     T11=-(13.D0*XX)/XI +THP1*DLOG(13.D0*XX/XI) -GTH-DLOG(XI)
  4219.     IF(T11+1.68D02) 340,340,330
  4220. 330    T11=DEXP(T11)
  4221.     A2=A2+T11
  4222. 340    CONTINUE
  4223.     A=1.01282051+THETA/156.D0-XX/312.D0
  4224.     B=DABS(A)
  4225.     C= -X2+THP1*DLX2+DLOG(B)-GTH-3.951243718581427
  4226.     IF(C+1.68D02) 370,370,350
  4227. 350    IF (A) 360,370,380
  4228. 360    C=-DEXP(C)
  4229.     GO TO 390
  4230. 370    C=0.D0
  4231.     GO TO 390
  4232. 380    C=DEXP(C)
  4233. 390    C=A2+C
  4234.     T11=1.D0-C
  4235.     T1=SNGL(T11)
  4236. C
  4237. C       SELECT PROPER EXPRESSION FOR P
  4238. C
  4239. 400    IF(G-2.) 420,410,410
  4240. 410    IF(G-4.) 450,460,460
  4241. C
  4242. C       COMPUTE P FOR G GREATER THAN ZERO AND LESS THAN 2.0
  4243. C
  4244. 420    CALL DLGAM(THP1,GTH,IOK)
  4245.     DT2=THETA*DLXX-X2-THP1*.6931471805599453 -GTH
  4246.     IF(DT2+1.68D02) 430,430,440
  4247. 430    P=T1
  4248.     GO TO 490
  4249. 440    DT2=DEXP(DT2)
  4250.     T2=SNGL(DT2)
  4251.     P=T1+T2+T2
  4252.     GO TO 490
  4253. C
  4254. C       COMPUTE P FOR G GREATER THAN OR EQUAL TO 2.0
  4255. C       AND LESS THAN 4.0
  4256. C
  4257. 450    P=T1
  4258.     GO TO 490
  4259. C
  4260. C       COMPUTE P FOR G GREATER THAN OR EQUAL TO 4.0
  4261. C       AND LESS THAN OR EQUAL TO 1000.0
  4262. C
  4263. 460    DT3=0.D0
  4264.     DO 480 I3=2,K
  4265.     THPI=DFLOAT(I3)+THETA
  4266.     CALL DLGAM(THPI,GTH,IOK)
  4267.     DLT3=THPI*DLX2-DLXX-X2-GTH
  4268.     IF(DLT3+1.68D02) 480,480,470
  4269. 470    DT3=DT3+DEXP(DLT3)
  4270. 480    CONTINUE
  4271.     T3=SNGL(DT3)
  4272.     P=T1-T3-T3
  4273. C
  4274. C       SET ERROR INDICATOR
  4275. C
  4276. 490    IF(P) 500,520,520
  4277. 500    IF(ABS(P)-1.E-7) 510,510,600
  4278. 510    P=0.0
  4279.     GO TO 610
  4280. 520    IF(1.-P) 530,550,550
  4281. 530    IF(ABS(1.-P)-1.E-7) 540,540,600
  4282. 540    P=1.0
  4283.     GO TO 610
  4284. 550    IF(P-1.E-8) 560,560,570
  4285. 560    P=0.0
  4286.     GO TO 610
  4287. 570    IF((1.0-P)-1.E-8) 580,580,610
  4288. 580    P=1.0
  4289.     GO TO 610
  4290. 590    IER=-1
  4291.     D=-1.7E38                                                                 0
  4292.     P=-1.7E38                                                                 0
  4293.     GO TO 620
  4294. 600    IER=+1
  4295.     P= 1.7E38                                                                 0
  4296.     GO TO 620
  4297. 610    IER=0
  4298. 620    RETURN
  4299.     END
  4300. C
  4301. C    ..................................................................
  4302. C
  4303. C       SUBROUTINE CEL1
  4304. C
  4305. C       PURPOSE
  4306. C          CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND
  4307. C
  4308. C       USAGE
  4309. C          CALL CEL1(RES,AK,IER)
  4310. C
  4311. C       DESCRIPTION OF PARAMETERS
  4312. C          RES   - RESULT VALUE
  4313. C          AK    - MODULUS (INPUT)
  4314. C          IER   - RESULTANT ERROR CODE WHERE
  4315. C                  IER=0  NO ERROR
  4316. C                  IER=1  AK NOT IN RANGE -1 TO +1
  4317. C
  4318. C       REMARKS
  4319. C          THE RESULT IS SET TO 1.7E38 IF ABS(AK) GE 1                         0
  4320. C          FOR MODULUS AK AND COMPLEMENTARY MODULUS CK,
  4321. C          EQUATION AK*AK+CK*CK=1.0 IS USED.
  4322. C          AK MUST BE IN THE RANGE -1 TO +1
  4323. C
  4324. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4325. C          NONE
  4326. C
  4327. C       METHOD
  4328. C          DEFINITION
  4329. C          CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
  4330. C          OVER T FROM 0 TO INFINITY).
  4331. C          EQUIVALENT ARE THE DEFINITIONS
  4332. C          CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED
  4333. C          OVER T FROM 0 TO PI/2),
  4334. C          CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T
  4335. C          FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK).
  4336. C          EVALUATION
  4337. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  4338. C          REFERENCE
  4339. C          R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
  4340. C          AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
  4341. C          NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  4342. C
  4343. C    ..................................................................
  4344. C
  4345.     SUBROUTINE CEL1(RES,AK,IER)
  4346.     IER=0
  4347.     ARI=2.
  4348.     GEO=(0.5-AK)+0.5
  4349.     GEO=GEO+GEO*AK
  4350.     RES=0.5
  4351.     IF(GEO)1,2,4
  4352. 1    IER=1
  4353. 2    RES=1.7E38                                                                0
  4354.     RETURN
  4355. 3    GEO=GEO*AARI
  4356. 4    GEO=SQRT(GEO)
  4357.     GEO=GEO+GEO
  4358.     AARI=ARI
  4359.     ARI=ARI+GEO
  4360.     RES=RES+RES
  4361.     IF(GEO/AARI-0.9999)3,5,5
  4362. 5    RES=RES/ARI*6.283185E0
  4363.     RETURN
  4364.     END
  4365. C
  4366. C    ..................................................................
  4367. C
  4368. C       SUBROUTINE CEL2
  4369. C
  4370. C       PURPOSE
  4371. C          COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF
  4372. C          SECOND KIND.
  4373. C
  4374. C       USAGE
  4375. C          CALL CEL2(RES,AK,A,B,IER)
  4376. C
  4377. C       DESCRIPTION OF PARAMETERS
  4378. C          RES   - RESULT VALUE
  4379. C          AK    - MODULUS (INPUT)
  4380. C          A     - CONSTANT TERM IN NUMERATOR
  4381. C          B     - FACTOR OF QUADRATIC TERM IN NUMERATOR
  4382. C          IER   - RESULTANT ERROR CODE WHERE
  4383. C                  IER=0  NO ERROR
  4384. C                  IER=1  AK NOT IN RANGE -1 TO +1
  4385. C
  4386. C       REMARKS
  4387. C          FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.7E38 IF B IS                0
  4388. C          POSITIVE, TO -1.7E38 IF B IS NEGATIVE.                              0
  4389. C          SPECIAL CASES ARE
  4390. C          K(K) OBTAINED WITH A = 1, B = 1
  4391. C          E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS
  4392. C          COMPLEMENTARY MODULUS.
  4393. C          B(K) OBTAINED WITH A = 1, B = 0
  4394. C          D(K) OBTAINED WITH A = 0, B = 1
  4395. C          WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED
  4396. C          COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL
  4397. C          NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS
  4398. C          THE MODULUS.
  4399. C
  4400. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4401. C          NONE
  4402. C
  4403. C       METHOD
  4404. C          DEFINITION
  4405. C          RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T))
  4406. C          SUMMED OVER T FROM 0 TO INFINITY).
  4407. C          EVALUATION
  4408. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  4409. C          REFERENCE
  4410. C          R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
  4411. C          AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
  4412. C          NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  4413. C
  4414. C    ..................................................................
  4415. C
  4416.     SUBROUTINE CEL2(RES,AK,A,B,IER)
  4417.     IER=0
  4418.     ARI=2.
  4419.     GEO=(0.5-AK)+0.5
  4420.     GEO=GEO+GEO*AK
  4421.     RES=A
  4422.     A1=A+B
  4423.     B0=B+B
  4424.     IF(GEO)1,2,6
  4425. 1    IER=1
  4426. 2    IF(B)3,8,4
  4427. 3    RES=-1.7E38                                                               0
  4428.     RETURN
  4429. 4    RES=1.7E38                                                                0
  4430.     RETURN
  4431. 5    GEO=GEO*AARI
  4432. 6    GEO=SQRT(GEO)
  4433.     GEO=GEO+GEO
  4434.     AARI=ARI
  4435.     ARI=ARI+GEO
  4436.     B0=B0+RES*GEO
  4437.     RES=A1
  4438.     B0=B0+B0
  4439.     A1=B0/ARI+A1
  4440.     IF(GEO/AARI-0.9999)5,7,7
  4441. 7    RES=A1/ARI
  4442.     RES=RES+0.5707963E0*RES
  4443. 8    RETURN
  4444.     END
  4445. C
  4446. C    ..................................................................
  4447. C
  4448. C       SUBROUTINE CHISQ
  4449. C
  4450. C       PURPOSE
  4451. C          COMPUTE CHI-SQUARE FROM A CONTINGENCY TABLE
  4452. C
  4453. C       USAGE
  4454. C          CALL CHISQ(A,N,M,CS,NDF,IERR,TR,TC)
  4455. C
  4456. C       DESCRIPTION OF PARAMETERS
  4457. C          A    - INPUT MATRIX, N BY M, CONTAINING CONTINGENCY TABLE
  4458. C          N    - NUMBER OF ROWS IN A
  4459. C          M    - NUMBER OF COLUMNS IN A
  4460. C          CS   - CHI-SQUARE (OUTPUT)
  4461. C          NDF  - NUMBER OF DEGREES OF FREEDOM (OUTPUT)
  4462. C          IERR - ERROR CODE (OUTPUT)
  4463. C                   0 - NORMAL CASE
  4464. C                   1 - EXPECTED VALUE IS LESS THAN 1.0 IN ONE OR
  4465. C                       MORE CELLS
  4466. C                   3 - NUMBER OF DEGREES OF FREEDOM IS ZERO
  4467. C          TR   - WORK VECTOR OF LENGTH N
  4468. C          TC   - WORK VECTOR OF LENGTH M
  4469. C
  4470. C       REMARKS
  4471. C          IF ONE OR MORE CELLS CONTAIN AN EXPECTED VALUE (I.E.,
  4472. C          THEORETICAL VALUE) LESS THAN 1.0, CHI-SQUARE WILL BE
  4473. C          COMPUTED, BUT ERROR CODE WILL BE SET TO 1.
  4474. C          SEE REFERENCE GIVEN BELOW.
  4475. C          CHI-SQUARE IS SET TO ZERO IF EITHER N OR M IS ONE (ERROR
  4476. C          CODE 3).
  4477. C
  4478. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4479. C          NONE
  4480. C
  4481. C       METHOD
  4482. C          DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
  4483. C          BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
  4484. C          CHAPTER 6 AND CHAPTER 8.
  4485. C
  4486. C    ..................................................................
  4487. C
  4488.     SUBROUTINE CHISQ(A,N,M,CS,NDF,IERR,TR,TC)
  4489.     DIMENSION A(1),TR(1),TC(1)
  4490. C
  4491.     NM=N*M
  4492.     IERR=0
  4493.     CS=0.0
  4494. C
  4495. C       FIND DEGREES OF FREEDOM
  4496. C
  4497.     NDF=(N-1)*(M-1)
  4498.     IF(NDF) 5,5,10
  4499. 5    IERR=3
  4500.     RETURN
  4501. C
  4502. C       COMPUTE TOTALS OF ROWS
  4503. C
  4504. 10    DO 90 I=1,N
  4505.     TR(I)=0.0
  4506.     IJ=I-N
  4507.     DO 90 J=1,M
  4508.     IJ=IJ+N
  4509. 90    TR(I)=TR(I)+A(IJ)
  4510. C
  4511. C       COMPUTE TOTALS OF COLUMNS
  4512. C
  4513.     IJ=0
  4514.     DO 100 J=1,M
  4515.     TC(J)=0.0
  4516.     DO 100 I=1,N
  4517.     IJ=IJ+1
  4518. 100    TC(J)=TC(J)+A(IJ)
  4519. C
  4520. C       COMPUTE GRAND TOTAL
  4521. C
  4522.     GT=0.0
  4523.     DO 110 I=1,N
  4524. 110    GT=GT+TR(I)
  4525. C
  4526. C       COMPUTE CHI SQUARE FOR 2 BY 2 TABLE (SPECIAL CASE)
  4527. C
  4528.     IF(NM-4) 130,120,130
  4529. 120    CS=GT*(ABS(A(1)*A(4)-A(2)*A(3))-GT/2.0)**2  /(TC(1)*TC(2)*TR(1)
  4530.      1*TR(2))
  4531.     RETURN
  4532. C
  4533. C       COMPUTE CHI SQUARE FOR OTHER CONTINGENCY TABLES
  4534. C
  4535. 130    IJ=0
  4536.     DO 140 J=1,M
  4537.     DO 140 I=1,N
  4538.     IJ=IJ+1
  4539.     E=TR(I)*TC(J)/GT
  4540.     IF(E-1.0) 135, 140, 140
  4541. 135    IERR=1
  4542. 140    CS=CS+(A(IJ)-E)*(A(IJ)-E)/E
  4543.     RETURN
  4544.     END
  4545. C
  4546. C    ..................................................................
  4547. C
  4548. C       SUBROUTINE CINT
  4549. C
  4550. C       PURPOSE
  4551. C          INTERCHANGE TWO COLUMNS OF A MATRIX
  4552. C
  4553. C       USAGE
  4554. C          CALL CINT(A,N,LA,LB)
  4555. C
  4556. C       DESCRIPTION OF PARAMETERS
  4557. C          A  - NAME OF MATRIX
  4558. C          N  - NUMBER OF ROWS IN A
  4559. C          LA - COLUMN TO BE INTERCHANGED WITH COLUMN LB
  4560. C          LB - COLUMN TO BE INTERCHANGED WITH COLUMN LA
  4561. C
  4562. C       REMARKS
  4563. C          MATRIX A MUST BE A GENERAL MATRIX
  4564. C
  4565. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4566. C          NONE
  4567. C
  4568. C       METHOD
  4569. C          EACH ELEMENT OF COLUMN LA IS INTERCHANGED WITH CORRESPONDING
  4570. C          ELEMENT OF COLUMN LB
  4571. C
  4572. C    ..................................................................
  4573. C
  4574.     SUBROUTINE CINT(A,N,LA,LB)
  4575.     DIMENSION A(1)
  4576. C
  4577. C       LOCATE STARTING POINT OF BOTH COLUMNS
  4578. C
  4579.     ILA=N*(LA-1)
  4580.     ILB=N*(LB-1)
  4581. C
  4582.     DO 3 I=1,N
  4583.     ILA=ILA+1
  4584.     ILB=ILB+1
  4585. C
  4586. C       INTERCHANGE ELEMENTS
  4587. C
  4588.     SAVE=A(ILA)
  4589.     A(ILA)=A(ILB)
  4590. 3    A(ILB)=SAVE
  4591.     RETURN
  4592.     END
  4593. C
  4594. C    ..................................................................
  4595. C
  4596. C       SUBROUTINE CNP
  4597. C
  4598. C       PURPOSE
  4599. C          COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X)
  4600. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  4601. C
  4602. C       USAGE
  4603. C          CALL CNP(Y,X,N)
  4604. C
  4605. C       DESCRIPTION OF PARAMETERS
  4606. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  4607. C                  OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
  4608. C                  FOR GIVEN ARGUMENT X.
  4609. C          Y     - RESULT VALUE
  4610. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  4611. C          X     - ARGUMENT OF CHEBYSHEV POLYNOMIAL
  4612. C          N     - ORDER OF CHEBYSHEV POLYNOMIAL
  4613. C
  4614. C       REMARKS
  4615. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  4616. C
  4617. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4618. C          NONE
  4619. C
  4620. C       METHOD
  4621. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  4622. C          CHEBYSHEV POLYNOMIALS T(N,X)
  4623. C          T(N+1,X)=2*X*T(N,X)-T(N-1,X),
  4624. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  4625. C          THE SECOND IS THE ARGUMENT.
  4626. C          STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
  4627. C
  4628. C    ..................................................................
  4629. C
  4630.     SUBROUTINE CNP(Y,X,N)
  4631. C
  4632.     DIMENSION Y(1)
  4633.     Y(1)=1.
  4634.     IF(N)1,1,2
  4635. 1    RETURN
  4636. C
  4637. 2    Y(2)=X
  4638.     IF(N-1)1,1,3
  4639. C
  4640. C       INITIALIZATION
  4641. 3    F=X+X
  4642. C
  4643.     DO 4 I=2,N
  4644. 4    Y(I+1)=F*Y(I)-Y(I-1)
  4645.     RETURN
  4646.     END
  4647. C
  4648. C    ..................................................................
  4649. C
  4650. C       SUBROUTINE CNPS
  4651. C
  4652. C       PURPOSE
  4653. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV
  4654. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  4655. C
  4656. C       USAGE
  4657. C          CALL CNPS(Y,X,C,N)
  4658. C
  4659. C       DESCRIPTION OF PARAMETERS
  4660. C          Y     - RESULT VALUE
  4661. C          X     - ARGUMENT VALUE
  4662. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  4663. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  4664. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  4665. C
  4666. C       REMARKS
  4667. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  4668. C
  4669. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4670. C          NONE
  4671. C
  4672. C       METHOD
  4673. C          DEFINITION
  4674. C          Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
  4675. C          EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
  4676. C          USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS
  4677. C          T(N+1,X)=2*X*T(N,X)-T(N-1,X).
  4678. C
  4679. C    ..................................................................
  4680. C
  4681.     SUBROUTINE CNPS(Y,X,C,N)
  4682. C
  4683.     DIMENSION C(1)
  4684. C
  4685. C       TEST OF DIMENSION
  4686.     IF(N)1,1,2
  4687. 1    RETURN
  4688. C
  4689. 2    IF(N-2)3,4,4
  4690. 3    Y=C(1)
  4691.     RETURN
  4692. C
  4693. C       INITIALIZATION
  4694. 4    ARG=X+X
  4695.     H1=0.
  4696.     H0=0.
  4697. C
  4698.     DO 5 I=1,N
  4699.     K=N-I
  4700.     H2=H1
  4701.     H1=H0
  4702. 5    H0=ARG*H1-H2+C(K+1)
  4703.     Y=0.5*(C(1)-H2+H0)
  4704.     RETURN
  4705.     END
  4706. C
  4707. C    ..................................................................
  4708. C
  4709. C       SUBROUTINE CONVT
  4710. C
  4711. C       PURPOSE
  4712. C          CONVERT NUMBERS FROM SINGLE PRECISION TO DOUBLE PRECISION
  4713. C          OR FROM DOUBLE PRECISION TO SINGLE PRECISION.
  4714. C
  4715. C       USAGE
  4716. C          CALL CONVT (N,M,MODE,S,D,MS)
  4717. C
  4718. C       DESCRIPTION OF PARAMETERS
  4719. C          N    - NUMBER OF ROWS IN MATRICES S AND D.
  4720. C          M    - NUMBER OF COLUMNS IN MATRICES S AND D.
  4721. C          MODE - CODE INDICATING TYPE OF CONVERSION
  4722. C                   1 - FROM SINGLE PRECISION TO DOUBLE PRECISION
  4723. C                   2 - FROM DOUBLE PRECISION TO SINGLE PRECISION
  4724. C          S    - IF MODE=1, THIS MATRIX CONTAINS SINGLE PRECISION
  4725. C                 NUMBERS AS INPUT.  IF MODE=2, IT CONTAINS SINGLE
  4726. C                 PRECISION NUMBERS AS OUTPUT.  THE SIZE OF MATRIX S
  4727. C                 IS N BY M.
  4728. C          D    - IF MODE=1, THIS MATRIX CONTAINS DOUBLE PRECISION
  4729. C                 NUMBERS AS OUTPUT.  IF MODE=2, IT CONTAINS DOUBLE
  4730. C                 PRECISION NUMBERS AS INPUT.  THE SIZE OF MATRIX D IS
  4731. C                 N BY M.
  4732. C          MS   - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX
  4733. C                   0 - GENERAL
  4734. C                   1 - SYMMETRIC
  4735. C                   2 - DIAGONAL
  4736. C
  4737. C       REMARKS
  4738. C          MATRIX D CANNOT BE IN THE SAME LOCATION AS MATRIX S.
  4739. C          MATRIX D MUST BE DEFINED BY A DOUBLE PRECISION STATEMENT IN
  4740. C          THE CALLING PROGRAM.
  4741. C
  4742. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4743. C          NONE
  4744. C
  4745. C       METHOD
  4746. C          ACCORDING TO THE TYPE OF CONVERSION INDICATED IN MODE, THIS
  4747. C          SUBROUTINE COPIES NUMBERS FROM MATRIX S TO MATRIX D OR FROM
  4748. C          MATRIX D TO MATRIX S.
  4749. C
  4750. C    ..................................................................
  4751. C
  4752.     SUBROUTINE CONVT (N,M,MODE,S,D,MS)
  4753.     DIMENSION S(1),D(1)
  4754.     DOUBLE PRECISION D
  4755. C
  4756. C       FIND STORAGE MODE OF MATRIX AND NUMBER OF DATA POINTS
  4757. C
  4758.     IF(MS-1) 2, 4, 6
  4759. 2    NM=N*M
  4760.     GO TO 8
  4761. 4    NM=((N+1)*N)/2
  4762.     GO TO 8
  4763. 6    NM=N
  4764. C
  4765. C       TEST TYPE OF CONVERSION
  4766. C
  4767. 8    IF(MODE-1) 10, 10, 20
  4768. C
  4769. C       SINGLE PRECISION TO DOUBLE PRECISION
  4770. C
  4771. 10    DO 15 L=1,NM
  4772. 15    D(L)=S(L)
  4773.     GO TO 30
  4774. C
  4775. C       DOUBLE PRECISION TO SINGLE PRECISION
  4776. C
  4777. 20    DO 25 L=1,NM
  4778. 25    S(L)=D(L)
  4779. C
  4780. 30    RETURN
  4781.     END
  4782. C
  4783. C    ..................................................................
  4784. C
  4785. C       SUBROUTINE CORRE
  4786. C
  4787. C       PURPOSE
  4788. C          COMPUTE MEANS, STANDARD DEVIATIONS, SUMS OF CROSS-PRODUCTS
  4789. C          OF DEVIATIONS, AND CORRELATION COEFFICIENTS.
  4790. C
  4791. C       USAGE
  4792. C          CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T)
  4793. C
  4794. C       DESCRIPTION OF PARAMETERS
  4795. C          N     - NUMBER OF OBSERVATIONS. N MUST BE > OR = TO 2.
  4796. C          M     - NUMBER OF VARIABLES. M MUST BE > OR = TO 1.
  4797. C          IO    - OPTION CODE FOR INPUT DATA
  4798. C                  0 IF DATA ARE TO BE READ IN FROM INPUT DEVICE IN THE
  4799. C                    SPECIAL SUBROUTINE NAMED DATA.  (SEE SUBROUTINES
  4800. C                    USED BY THIS SUBROUTINE BELOW.)
  4801. C                  1 IF ALL DATA ARE ALREADY IN CORE.
  4802. C          X     - IF IO=0, THE VALUE OF X IS 0.0.
  4803. C                  IF IO=1, X IS THE INPUT MATRIX (N BY M) CONTAINING
  4804. C                           DATA.
  4805. C          XBAR  - OUTPUT VECTOR OF LENGTH M CONTAINING MEANS.
  4806. C          STD   - OUTPUT VECTOR OF LENGTH M CONTAINING STANDARD
  4807. C                  DEVIATIONS.
  4808. C          RX    - OUTPUT MATRIX (M X M) CONTAINING SUMS OF CROSS-
  4809. C                  PRODUCTS OF DEVIATIONS FROM MEANS.
  4810. C          R     - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
  4811. C                  SYMMETRIC MATRIX OF M BY M) CONTAINING CORRELATION
  4812. C                  COEFFICIENTS.  (STORAGE MODE OF 1)
  4813. C          B     - OUTPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL
  4814. C                  OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF
  4815. C                  DEVIATIONS FROM MEANS.
  4816. C          D     - WORKING VECTOR OF LENGTH M.
  4817. C          T     - WORKING VECTOR OF LENGTH M.
  4818. C
  4819. C       REMARKS
  4820. C          CORRE WILL NOT ACCEPT A CONSTANT VECTOR.
  4821. C
  4822. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  4823. C          DATA(M,D) - THIS SUBROUTINE MUST BE PROVIDED BY THE USER.
  4824. C                      (1) IF IO=0, THIS SUBROUTINE IS EXPECTED TO
  4825. C                          FURNISH AN OBSERVATION IN VECTOR D FROM AN
  4826. C                          EXTERNAL INPUT DEVICE.
  4827. C                      (2) IF IO=1, THIS SUBROUTINE IS NOT USED BY
  4828. C                          CORRE BUT MUST EXIST IN JOB DECK. IF USER
  4829. C                          HAS NOT SUPPLIED A SUBROUTINE NAMED DATA,
  4830. C                          THE FOLLOWING IS SUGGESTED.
  4831. C                               SUBROUTINE DATA
  4832. C                               RETURN
  4833. C                               END
  4834. C
  4835. C       METHOD
  4836. C          PRODUCT-MOMENT CORRELATION COEFFICIENTS ARE COMPUTED.
  4837. C
  4838. C    ..................................................................
  4839. C
  4840.     SUBROUTINE CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T)
  4841.     DIMENSION X(1),XBAR(1),STD(1),RX(1),R(1),B(1),D(1),T(1)
  4842. C
  4843. C       ...............................................................
  4844. C
  4845. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  4846. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  4847. C       STATEMENT WHICH FOLLOWS.
  4848. C
  4849. C    DOUBLE PRECISION XBAR,STD,RX,R,B,T
  4850. C
  4851. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  4852. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  4853. C       ROUTINE.
  4854. C
  4855. C       THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
  4856. C       CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
  4857. C       STATEMENT 220 MUST BE CHANGED TO DSQRT AND DABS.
  4858. C
  4859. C       ...............................................................
  4860. C
  4861. C    INITIALIZATION
  4862. C
  4863.     DO 100 J=1,M
  4864.     B(J)=0.0
  4865. 100    T(J)=0.0
  4866.     K=(M*M+M)/2
  4867.     DO 102 I=1,K
  4868. 102    R(I)=0.0
  4869.     FN=N
  4870.     L=0
  4871. C
  4872.     IF(IO) 105, 127, 105
  4873. C
  4874. C    DATA ARE ALREADY IN CORE
  4875. C
  4876. 105    DO 108 J=1,M
  4877.     DO 107 I=1,N
  4878.     L=L+1
  4879. 107    T(J)=T(J)+X(L)
  4880.     XBAR(J)=T(J)
  4881. 108    T(J)=T(J)/FN
  4882. C
  4883.     DO 115 I=1,N
  4884.     JK=0
  4885.     L=I-N
  4886.     DO 110 J=1,M
  4887.     L=L+N
  4888.     D(J)=X(L)-T(J)
  4889. 110    B(J)=B(J)+D(J)
  4890.     DO 115 J=1,M
  4891.     DO 115 K=1,J
  4892.     JK=JK+1
  4893. 115    R(JK)=R(JK)+D(J)*D(K)
  4894.     GO TO 205
  4895. C
  4896. C    READ OBSERVATIONS AND CALCULATE TEMPORARY
  4897. C    MEANS FROM THESE DATA IN T(J)
  4898. C
  4899. 127    IF(N-M) 130, 130, 135
  4900. 130    KK=N
  4901.     GO TO 137
  4902. 135    KK=M
  4903. 137    DO 140 I=1,KK
  4904.     CALL DATA (M,D)
  4905.     DO 140 J=1,M
  4906.     T(J)=T(J)+D(J)
  4907.     L=L+1
  4908. 140    RX(L)=D(J)
  4909.     FKK=KK
  4910.     DO 150 J=1,M
  4911.     XBAR(J)=T(J)
  4912. 150    T(J)=T(J)/FKK
  4913. C
  4914. C    CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
  4915. C    FROM TEMPORARY MEANS FOR M OBSERVATIONS
  4916. C
  4917.     L=0
  4918.     DO 180 I=1,KK
  4919.     JK=0
  4920.     DO 170 J=1,M
  4921.     L=L+1
  4922. 170    D(J)=RX(L)-T(J)
  4923.     DO 180 J=1,M
  4924.     B(J)=B(J)+D(J)
  4925.     DO 180 K=1,J
  4926.     JK=JK+1
  4927. 180    R(JK)=R(JK)+D(J)*D(K)
  4928. C
  4929.     IF(N-KK) 205, 205, 185
  4930. C
  4931. C    READ THE REST OF OBSERVATIONS ONE AT A TIME, SUM
  4932. C    THE OBSERVATION, AND CALCULATE SUMS OF CROSS-
  4933. C    PRODUCTS OF DEVIATIONS FROM TEMPORARY MEANS
  4934. C
  4935. 185    KK=N-KK
  4936.     DO 200 I=1,KK
  4937.     JK=0
  4938.     CALL DATA (M,D)
  4939.     DO 190 J=1,M
  4940.     XBAR(J)=XBAR(J)+D(J)
  4941.     D(J)=D(J)-T(J)
  4942. 190    B(J)=B(J)+D(J)
  4943.     DO 200 J=1,M
  4944.     DO 200 K=1,J
  4945.     JK=JK+1
  4946. 200    R(JK)=R(JK)+D(J)*D(K)
  4947. C
  4948. C    CALCULATE MEANS
  4949. C
  4950. 205    JK=0
  4951.     DO 210 J=1,M
  4952.     XBAR(J)=XBAR(J)/FN
  4953. C
  4954. C    ADJUST SUMS OF CROSS-PRODUCTS OF DEVIATIONS
  4955. C    FROM TEMPORARY MEANS
  4956. C
  4957.     DO 210 K=1,J
  4958.     JK=JK+1
  4959. 210    R(JK)=R(JK)-B(J)*B(K)/FN
  4960. C
  4961. C    CALCULATE CORRELATION COEFFICIENTS
  4962. C
  4963.     JK=0
  4964.     DO 220 J=1,M
  4965.     JK=JK+J
  4966. 220    STD(J)= SQRT( ABS(R(JK)))
  4967.     DO 230 J=1,M
  4968.     DO 230 K=J,M
  4969.     JK=J+(K*K-K)/2
  4970.     L=M*(J-1)+K
  4971.     RX(L)=R(JK)
  4972.     L=M*(K-1)+J
  4973.     RX(L)=R(JK)
  4974.     IF(STD(J)*STD(K)) 225, 222, 225
  4975. 222    R(JK)=0.0
  4976.     GO TO 230
  4977. 225    R(JK)=R(JK)/(STD(J)*STD(K))
  4978. 230    CONTINUE
  4979. C
  4980. C    CALCULATE STANDARD DEVIATIONS
  4981. C
  4982.     FN=SQRT(FN-1.0)
  4983.     DO 240 J=1,M
  4984. 240    STD(J)=STD(J)/FN
  4985. C
  4986. C    COPY THE DIAGONAL OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF
  4987. C    DEVIATIONS FROM MEANS.
  4988. C
  4989.     L=-M
  4990.     DO 250 I=1,M
  4991.     L=L+M+1
  4992. 250    B(I)=RX(L)
  4993.     RETURN
  4994.     END
  4995. C
  4996. C    ..................................................................
  4997. C
  4998. C       SUBROUTINE CROSS
  4999. C
  5000. C       PURPOSE
  5001. C          TO FIND THE CROSSCOVARIANCES OF SERIES A WITH SERIES B
  5002. C          (WHICH LEADS AND LAGS A).
  5003. C
  5004. C       USAGE
  5005. C          CALL CROSS (A,B,N,L,R,S)
  5006. C
  5007. C       DESCRIPTION OF PARAMETERS
  5008. C          A    - INPUT VECTOR OF LENGTH N CONTAINING FIRST TIME
  5009. C                 SERIES.
  5010. C          B    - INPUT VECTOR OF LENGTH N CONTAINING SECOND TIME
  5011. C                 SERIES.
  5012. C          N    - LENGTH OF SERIES A AND B.
  5013. C          L    - CROSSCOVARIANCE IS CALCULATED FOR LAGS AND LEADS OF
  5014. C                 0, 1, 2,..., L-1.
  5015. C          R    - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI-
  5016. C                 ANCES OF A WITH B, WHERE B LAGS A.
  5017. C          S    - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI-
  5018. C                 ANCES OF A WITH B, WHERE B LEADS A.
  5019. C
  5020. C       REMARKS
  5021. C          N MUST BE GREATER THAN L.  IF NOT, R(1) AND S(1) ARE SET TO
  5022. C          ZERO AND RETURN IS MADE TO THE CALLING PROGRAM.
  5023. C
  5024. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5025. C          NONE
  5026. C
  5027. C       METHOD
  5028. C          DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT
  5029. C       OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959.
  5030. C
  5031. C    ..................................................................
  5032. C
  5033.     SUBROUTINE CROSS (A,B,N,L,R,S)
  5034.     DIMENSION A(1),B(1),R(1),S(1)
  5035. C
  5036. C    CALCULATE AVERAGES OF SERIES A AND B
  5037. C
  5038.     FN=N
  5039.     AVERA=0.0
  5040.     AVERB=0.0
  5041.     IF(N-L)50,50,100
  5042. 50    R(1)=0.0
  5043.     S(1)=0.0
  5044.     RETURN
  5045. 100    DO 110 I=1,N
  5046.     AVERA=AVERA+A(I)
  5047. 110    AVERB=AVERB+B(I)
  5048.     AVERA=AVERA/FN
  5049.     AVERB=AVERB/FN
  5050. C
  5051. C    CALCULATE CROSSCOVARIANCES OF SERIES A AND B
  5052. C
  5053.     DO 130 J=1,L
  5054.     NJ=N-J+1
  5055.     SUMR=0.0
  5056.     SUMS=0.0
  5057.     DO 120 I=1,NJ
  5058.     IJ=I+J-1
  5059.     SUMR=SUMR+(A(I)-AVERA)*(B(IJ)-AVERB)
  5060. 120    SUMS=SUMS+(A(IJ)-AVERA)*(B(I)-AVERB)
  5061.     FNJ=NJ
  5062.     R(J)=SUMR/FNJ
  5063. 130    S(J)=SUMS/FNJ
  5064.     RETURN
  5065.     END
  5066. C
  5067. C    ..................................................................
  5068. C
  5069. C       SUBROUTINE CS
  5070. C
  5071. C       PURPOSE
  5072. C          COMPUTES THE FRESNEL INTEGRALS.
  5073. C
  5074. C       USAGE
  5075. C          CALL CS (C,S,X)
  5076. C
  5077. C       DESCRIPTION OF PARAMETERS
  5078. C          C     - THE RESULTANT VALUE C(X).
  5079. C          S     - THE RESULTANT VALUE S(X).
  5080. C          X     - THE ARGUMENT OF FRESNEL INTEGRALS
  5081. C                  IF X IS NEGATIVE, THE ABSOLUTE VALUE IS USED.
  5082. C
  5083. C       REMARKS
  5084. C          THE ARGUMENT VALUE X REMAINS UNCHANGED.
  5085. C
  5086. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5087. C          NONE
  5088. C
  5089. C       METHOD
  5090. C          DEFINITION
  5091. C          C(X)=INTEGRAL(COS(T)/SQRT(2*LI*T) SUMMED OVER T FROM 0 TO X)
  5092. C          S(X)=INTEGRAL(SIN(T)/SQRT(I*LI*T) SUMMED OVER T FROM 0 TO X)
  5093. C          EVALUATION
  5094. C          USING DIFFERENT APPROXIMATIONS FOR X LESS THAN 4 AND X
  5095. C          GREATER THAN 4.
  5096. C          REFERENCE
  5097. C          'COMPUTATION OF FRESNEL INTEGRALS' BY BOERSMA,
  5098. C          MATHEMATICAL TABLES AND OTHER AIDS TO COMPUTATION, VOL. 14,
  5099. C          1960, NO. 72, P. 380.
  5100. C
  5101. C    ..................................................................
  5102. C
  5103.     SUBROUTINE CS(C,S,X)
  5104.     Z=ABS(X)
  5105.     IF(Z-4.)1,1,2
  5106. 1    C=SQRT(Z)
  5107.     S=Z*C
  5108.     Z=(4.-Z)*(4.+Z)
  5109.     C=C*((((((5.100785E-11*Z+5.244297E-9)*Z+5.451182E-7)*Z
  5110.      1+3.273308E-5)*Z+1.020418E-3)*Z+1.102544E-2)*Z+1.840965E-1)
  5111.     S=S*(((((6.677681E-10*Z+5.883158E-8)*Z+5.051141E-6)*Z
  5112.      1+2.441816E-4)*Z+6.121320E-3)*Z+8.026490E-2)
  5113.     RETURN
  5114. 2    D=COS(Z)
  5115.     S=SIN(Z)
  5116.     Z=4./Z
  5117.       A=(((((((8.768258E-4*Z-4.169289E-3)*Z+7.970943E-3)*Z-6.792801E-3)
  5118.      1*Z-3.095341E-4)*Z+5.972151E-3)*Z-1.606428E-5)*Z-2.493322E-2)*Z
  5119.      2-4.444091E-9
  5120.       B=((((((-6.633926E-4*Z+3.401409E-3)*Z-7.271690E-3)*Z+7.428246E-3)
  5121.      1*Z-4.027145E-4)*Z-9.314910E-3)*Z-1.207998E-6)*Z+1.994711E-1
  5122.     Z=SQRT(Z)
  5123.     C=0.5+Z*(D*A+S*B)
  5124.     S=0.5+Z*(S*A-D*B)
  5125.     RETURN
  5126.     END
  5127. C
  5128. C    ..................................................................
  5129. C
  5130. C       SUBROUTINE CSP
  5131. C
  5132. C       PURPOSE
  5133. C          COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS
  5134. C          TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N.
  5135. C
  5136. C       USAGE
  5137. C          CALL CSP(Y,X,N)
  5138. C
  5139. C       DESCRIPTION OF PARAMETERS
  5140. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  5141. C                  OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
  5142. C                  FOR GIVEN ARGUMENT X.
  5143. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  5144. C          X     - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL
  5145. C          N     - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL
  5146. C
  5147. C       REMARKS
  5148. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  5149. C
  5150. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5151. C          NONE
  5152. C
  5153. C       METHOD
  5154. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  5155. C          SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
  5156. C          TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
  5157. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  5158. C          THE SECOND IS THE ARGUMENT.
  5159. C          STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
  5160. C
  5161. C    ..................................................................
  5162. C
  5163.     SUBROUTINE CSP(Y,X,N)
  5164. C
  5165.     DIMENSION Y(1)
  5166. C
  5167. C       TEST OF ORDER
  5168.     Y(1)=1.
  5169.     IF(N)1,1,2
  5170. 1    RETURN
  5171. C
  5172. 2    Y(2)=X+X-1.
  5173.     IF(N-1)1,1,3
  5174. C
  5175. C       INITIALIZATION
  5176. 3    F=Y(2)+Y(2)
  5177. C
  5178.     DO 4 I=2,N
  5179. 4    Y(I+1)=F*Y(I)-Y(I-1)
  5180.     RETURN
  5181.     END
  5182. C
  5183. C    ..................................................................
  5184. C
  5185. C       SUBROUTINE CSPS
  5186. C
  5187. C       PURPOSE
  5188. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED
  5189. C          CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C
  5190. C          FOR ARGUMENT VALUE X.
  5191. C
  5192. C       USAGE
  5193. C          CALL CSPS(Y,X,C,N)
  5194. C
  5195. C       DESCRIPTION OF PARAMETERS
  5196. C          Y     - RESULT VALUE
  5197. C          X     - ARGUMENT VALUE
  5198. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  5199. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  5200. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  5201. C
  5202. C       REMARKS
  5203. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  5204. C
  5205. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5206. C          NONE
  5207. C
  5208. C       METHOD
  5209. C          DEFINITION
  5210. C          Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
  5211. C          EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
  5212. C          USING THE RECURRENCE EQUATION FOR SHIFTED
  5213. C          CHEBYSHEV POLYNOMIALS
  5214. C          TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X).
  5215. C
  5216. C    ..................................................................
  5217. C
  5218.     SUBROUTINE CSPS(Y,X,C,N)
  5219. C
  5220.     DIMENSION C(1)
  5221. C
  5222. C       TEST OF DIMENSION
  5223.     IF(N)1,1,2
  5224. 1    RETURN
  5225. C
  5226. 2    IF(N-2)3,4,4
  5227. 3    Y=C(1)
  5228.     RETURN
  5229. C
  5230. C       INITIALIZATION
  5231. 4    ARG=X+X-1.
  5232.     ARG=ARG+ARG
  5233.     H1=0.
  5234.     H0=0.
  5235. C
  5236.     DO 5 I=1,N
  5237.     K=N-I
  5238.     H2=H1
  5239.     H1=H0
  5240. 5    H0=ARG*H1-H2+C(K+1)
  5241.     Y=0.5*(C(1)-H2+H0)
  5242.     RETURN
  5243.     END
  5244. C
  5245. C    ..................................................................
  5246. C
  5247. C       SUBROUTINE CSRT
  5248. C
  5249. C       PURPOSE
  5250. C          SORT COLUMNS OF A MATRIX
  5251. C
  5252. C       USAGE
  5253. C          CALL CSRT(A,B,R,N,M,MS)
  5254. C
  5255. C       DESCRIPTION OF PARAMETERS
  5256. C          A - NAME OF INPUT MATRIX TO BE SORTED
  5257. C          B - NAME OF INPUT VECTOR WHICH CONTAINS SORTING KEY
  5258. C          R - NAME OF SORTED OUTPUT MATRIX
  5259. C          N - NUMBER OF ROWS IN A AND R
  5260. C          M - NUMBER OF COLUMNS IN A AND R AND LENGTH OF B
  5261. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  5262. C                 0 - GENERAL
  5263. C                 1 - SYMMETRIC
  5264. C                 2 - DIAGONAL
  5265. C
  5266. C       REMARKS
  5267. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
  5268. C          MATRIX R IS ALWAYS A GENERAL MATRIX
  5269. C          M MUST BE GREATER THAN ONE.
  5270. C
  5271. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5272. C          LOC
  5273. C          CCPY
  5274. C
  5275. C       METHOD
  5276. C          COLUMNS OF INPUT MATRIX A ARE SORTED TO FORM OUTPUT MATRIX
  5277. C          R. THE SORTED COLUMN SEQUENCE IS DETERMINED BY THE VALUES OF
  5278. C          ELEMENTS IN ROW VECTOR B. THE LOWEST VALUED ELEMENT IN
  5279. C          B WILL CAUSE THE CORRESPONDING COLUMN OF A TO BE PLACED IN
  5280. C          THE FIRST COLUMN OF R. THE HIGHEST VALUED ELEMENT OF B WILL
  5281. C          CAUSE THE CORRESPONDING ROW OF A TO BE PLACED IN THE LAST
  5282. C          COLUMN OF R. IF DUPLICATE VALUES EXIST IN B, THE
  5283. C          CORRESPONDING COLUMNS OF A ARE MOVED TO R IN THE SAME ORDER
  5284. C          AS IN A.
  5285. C
  5286. C    ..................................................................
  5287. C
  5288.     SUBROUTINE CSRT(A,B,R,N,M,MS)
  5289.     DIMENSION A(1),B(1),R(1)
  5290. C
  5291. C       MOVE SORTING KEY VECTOR TO FIRST ROW OF OUTPUT MATRIX
  5292. C       AND BUILD ORIGINAL SEQUENCE LIST IN SECOND ROW
  5293. C
  5294.     IK=1
  5295.     DO 10 J=1,M
  5296.     R(IK)=B(J)
  5297.     R(IK+1)=J
  5298. 10    IK=IK+N
  5299. C
  5300. C       SORT ELEMENTS IN SORTING KEY VECTOR (ORIGINAL SEQUENCE LIST
  5301. C       IS RESEQUENCED ACCORDINGLY)
  5302. C
  5303.     L=M+1
  5304. 20    ISORT=0
  5305.     L=L-1
  5306.     IP=1
  5307.     IQ=N+1
  5308.     DO 50 J=2,L
  5309.     IF(R(IQ)-R(IP)) 30,40,40
  5310. 30    ISORT=1
  5311.     RSAVE=R(IQ)
  5312.     R(IQ)=R(IP)
  5313.     R(IP)=RSAVE
  5314.     SAVER=R(IQ+1)
  5315.     R(IQ+1)=R(IP+1)
  5316.     R(IP+1)=SAVER
  5317. 40    IP=IP+N
  5318.     IQ=IQ+N
  5319. 50    CONTINUE
  5320.     IF(ISORT) 20,60,20
  5321. C
  5322. C       MOVE COLUMNS FROM MATRIX A TO MATRIX R (NUMBER IN SECOND ROW
  5323. C       OF R REPRESENTS COLUMN NUMBER OF MATRIX A TO BE MOVED)
  5324. C
  5325. 60    IQ=-N
  5326.     DO 70 J=1,M
  5327.     IQ=IQ+N
  5328. C
  5329. C       GET COLUMN NUMBER IN MATRIX A
  5330. C
  5331.     I2=IQ+2
  5332.     IN=R(I2)
  5333. C
  5334. C       MOVE COLUMN
  5335. C
  5336.     IR=IQ+1
  5337.     CALL CCPY(A,IN,R(IR),N,M,MS)
  5338. 70    CONTINUE
  5339.     RETURN
  5340.     END
  5341. C
  5342. C    ..................................................................
  5343. C
  5344. C       SUBROUTINE CSUM
  5345. C
  5346. C       PURPOSE
  5347. C          SUM ELEMENTS OF EACH COLUMN TO FORM ROW VECTOR
  5348. C
  5349. C       USAGE
  5350. C          CALL CSUM(A,R,N,M,MS)
  5351. C
  5352. C       DESCRIPTION OF PARAMETERS
  5353. C          A - NAME OF INPUT MATRIX
  5354. C          R - NAME OF VECTOR OF LENGTH M
  5355. C          N - NUMBER OF ROWS IN A
  5356. C          M - NUMBER OF COLUMNS IN A
  5357. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  5358. C                 0 - GENERAL
  5359. C                 1 - SYMMETRIC
  5360. C                 2 - DIAGONAL
  5361. C
  5362. C       REMARKS
  5363. C          VECTOR R CANNOT BE IN THE SAME LOCATION AS MATRIX A
  5364. C          UNLESS A IS GENERAL
  5365. C
  5366. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5367. C          LOC
  5368. C
  5369. C       METHOD
  5370. C          ELEMENTS ARE SUMMED DOWN EACH COLUMN INTO A CORRESPONDING
  5371. C          ELEMENT OF OUTPUT ROW VECTOR R
  5372. C
  5373. C    ..................................................................
  5374. C
  5375.     SUBROUTINE CSUM(A,R,N,M,MS)
  5376.     DIMENSION A(1),R(1)
  5377. C
  5378.     DO 3 J=1,M
  5379. C
  5380. C       CLEAR OUTPUT LOCATION
  5381. C
  5382.     R(J)=0.0
  5383. C
  5384.     DO 3 I=1,N
  5385. C
  5386. C       LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
  5387. C
  5388.     CALL LOC(I,J,IJ,N,M,MS)
  5389. C
  5390. C       TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
  5391. C
  5392.     IF(IJ) 2,3,2
  5393. C
  5394. C       ACCUMULATE IN OUTPUT VECTOR
  5395. C
  5396. 2    R(J)=R(J)+A(IJ)
  5397. 3    CONTINUE
  5398.     RETURN
  5399.     END
  5400. C
  5401. C    ..................................................................
  5402. C
  5403. C       SUBROUTINE CTAB
  5404. C
  5405. C       PURPOSE
  5406. C          TABULATE COLUMNS OF A MATRIX TO FORM A SUMMARY MATRIX
  5407. C
  5408. C       USAGE
  5409. C          CALL CTAB(A,B,R,S,N,M,MS,L)
  5410. C
  5411. C       DESCRIPTION OF PARAMETERS
  5412. C          A - NAME OF INPUT MATRIX
  5413. C          B - NAME OF INPUT VECTOR OF LENGTH M CONTAINING KEY
  5414. C          R - NAME OF OUTPUT MATRIX CONTAINING SUMMARY OF COLUMN DATA.
  5415. C              IT IS INITIALLY SET TO ZERO BY THIS SUBROUTINE.
  5416. C          S - NAME OF OUTPUT VECTOR OF LENGTH L+1 CONTAINING COUNTS
  5417. C          N - NUMBER OF ROWS IN A AND R
  5418. C          M - NUMBER OF COLUMNS IN A
  5419. C          L - NUMBER OF COLUMNS IN R
  5420. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  5421. C                 0 - GENERAL
  5422. C                 1 - SYMMETRIC
  5423. C                 2 - DIAGONAL
  5424. C
  5425. C       REMARKS
  5426. C          MATRIX R IS ALWAYS A GENERAL MATRIX
  5427. C
  5428. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5429. C          LOC
  5430. C          CADD
  5431. C
  5432. C       METHOD
  5433. C          COLUMNS OF DATA IN MATRIX A ARE TABULATED BASED ON THE KEY
  5434. C          CONTAINED IN VECTOR B. THE FLOATING POINT NUMBER IN B(I) IS
  5435. C          TRUNCATED TO FORM J. THE ITH COLUMN OF A IS ADDED TO THE JTH
  5436. C          COLUMN OF MATRIX R AND ONE IS ADDED TO S(J). IF THE VALUE OF
  5437. C          J IS NOT BETWEEN 1 AND L, ONE IS ADDED TO S(L+1)
  5438. C          UPON COMPLETION, THE OUTPUT MATRIX R CONTAINS A SUMMARY OF
  5439. C          COLUMN DATA AS SPECIFIED BY VECTOR B. EACH ELEMENT IN VECTOR
  5440. C          S CONTAINS A COUNT OF THE NUMBER OF COLUMNS OF A USED TO
  5441. C          FORM R. ELEMENT S(L+1) CONTAINS THE NUMBER OF COLUMNS OF A
  5442. C          NOT INCLUDED IN R AS A RESULT OF J BEING LESS THAN ONE OR
  5443. C          GREATER THAN L.
  5444. C
  5445. C    ..................................................................
  5446. C
  5447.     SUBROUTINE CTAB(A,B,R,S,N,M,MS,L)
  5448.     DIMENSION A(1),B(1),R(1),S(1)
  5449. C
  5450. C       CLEAR OUTPUT AREAS
  5451. C
  5452.     CALL LOC(N,L,IT,N,L,0)
  5453.     DO 10 IR=1,IT
  5454. 10    R(IR)=0.0
  5455.     DO 20 IS=1,L
  5456. 20    S(IS)=0.0
  5457.     S(L+1)=0.0
  5458. C
  5459.     DO 60 I=1,M
  5460. C
  5461. C       TEST FOR THE KEY OUTSIDE THE RANGE
  5462. C
  5463.     JR=B(I)
  5464.     IF (JR-1) 50,40,30
  5465. 30    IF (JR-L) 40,40,50
  5466. C
  5467. C
  5468. C       ADD COLUMN OF A TO COLUMN OF R AND 1 TO COUNT
  5469. C
  5470. 40    CALL CADD (A,I,R,JR,N,M,MS,L)
  5471.     S(JR)=S(JR)+1.0
  5472.     GO TO 60
  5473. C
  5474. 50    S(L+1)=S(L+1)+1.0
  5475. 60    CONTINUE
  5476.     RETURN
  5477.     END
  5478. C
  5479. C    ..................................................................
  5480. C
  5481. C       SUBROUTINE CTIE
  5482. C
  5483. C       PURPOSE
  5484. C          ADJOIN TWO MATRICES WITH SAME ROW DIMENSION TO FORM ONE
  5485. C          RESULTANT MATRIX (SEE METHOD)
  5486. C
  5487. C       USAGE
  5488. C          CALL CTIE(A,B,R,N,M,MSA,MSB,L)
  5489. C
  5490. C       DESCRIPTION OF PARAMETERS
  5491. C          A - NAME OF FIRST INPUT MATRIX
  5492. C          B - NAME OF SECOND INPUT MATRIX
  5493. C          R - NAME OF OUTPUT MATRIX
  5494. C          N - NUMBER OF ROWS IN A,B,R
  5495. C          M - NUMBER OF COLUMNS IN A
  5496. C          MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  5497. C                 0 - GENERAL
  5498. C                 1 - SYMMETRIC
  5499. C                 2 - DIAGONAL
  5500. C          MSB - SAME AS MSA EXCEPT FOR MATRIX B
  5501. C          L - NUMBER OF COLUMNS IN B
  5502. C
  5503. C       REMARKS
  5504. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B
  5505. C          MATRIX R IS ALWAYS A GENERAL MATRIX
  5506. C          MATRIX A MUST HAVE THE SAME NUMBER OF ROWS AS MATRIX B
  5507. C
  5508. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5509. C          LOC
  5510. C
  5511. C       METHOD
  5512. C          MATRIX B IS ATTACHED TO THE RIGHT OF MATRIX A .
  5513. C          THE RESULTANT MATRIX R CONTAINS N ROWS AND M+L COLUMNS
  5514. C
  5515. C    ..................................................................
  5516. C
  5517.     SUBROUTINE CTIE(A,B,R,N,M,MSA,MSB,L)
  5518.     DIMENSION A(1),B(1),R(1)
  5519. C
  5520.     MM=M
  5521.     IR=0
  5522.     MSX=MSA
  5523.     DO 6 JJ=1,2
  5524.     DO 5 J=1,MM
  5525.     DO 5 I=1,N
  5526.     IR=IR+1
  5527.     R(IR)=0.0
  5528. C
  5529. C       LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
  5530. C
  5531.     CALL LOC(I,J,IJ,N,MM,MSX)
  5532. C
  5533. C       TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
  5534. C
  5535.     IF(IJ) 2,5,2
  5536. C
  5537. C       MOVE ELEMENT TO MATRIX R
  5538. C
  5539. 2    GO TO(3,4),JJ
  5540. 3    R(IR)=A(IJ)
  5541.     GO TO 5
  5542. 4    R(IR)=B(IJ)
  5543. 5    CONTINUE
  5544. C
  5545. C       REPEAT ABOVE FOR MATRIX B
  5546. C
  5547.     MSX=MSB
  5548.     MM=L
  5549. 6    CONTINUE
  5550.     RETURN
  5551.     END
  5552. C
  5553. C    ..................................................................
  5554. C
  5555. C       SUBROUTINE DACFI
  5556. C
  5557. C       PURPOSE
  5558. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  5559. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
  5560. C          VALUES.
  5561. C
  5562. C       USAGE
  5563. C          CALL DACFI (X,ARG,VAL,Y,NDIM,EPS,IER)
  5564. C
  5565. C       DESCRIPTION OF PARAMETERS
  5566. C          X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
  5567. C          ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
  5568. C                   ARGUMENT VALUES OF THE TABLE (POSSIBLY DESTROYED).
  5569. C          VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
  5570. C                   FUNCTION VALUES OF THE TABLE (DESTROYED).
  5571. C          Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
  5572. C                   VALUE.
  5573. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  5574. C                   POINTS IN TABLE (ARG,VAL).
  5575. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  5576. C                   UPPER BOUND FOR THE ABSOLUTE ERROR.
  5577. C          IER    - A RESULTING ERROR PARAMETER.
  5578. C
  5579. C       REMARKS
  5580. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  5581. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  5582. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  5583. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  5584. C              SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
  5585. C              PREVIOUS STAGE.
  5586. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  5587. C              THAN 1.
  5588. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  5589. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  5590. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  5591. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  5592. C              (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS
  5593. C              DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN
  5594. C              THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME
  5595. C              AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY
  5596. C              ELEMENT BY INTERCHANGING OF TABLE POINTS).
  5597. C              FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO
  5598. C              ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL.
  5599. C              DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS
  5600. C              CODED IN THE FOLLOWING FORM
  5601. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  5602. C                       ACCURACY (NO ERROR).
  5603. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  5604. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  5605. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  5606. C                       NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
  5607. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  5608. C                       TABLE. NDIM SHOULD BE INCREASED.
  5609. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  5610. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  5611. C
  5612. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5613. C          NONE
  5614. C
  5615. C       METHOD
  5616. C          INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED-
  5617. C          DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED
  5618. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  5619. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  5620. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  5621. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406.
  5622. C
  5623. C    ..................................................................
  5624. C
  5625.     SUBROUTINE DACFI(X,ARG,VAL,Y,NDIM,EPS,IER)
  5626. C
  5627. C
  5628.     DIMENSION ARG(1),VAL(1)
  5629.     DOUBLE PRECISION ARG,VAL,X,Y,Z,P1,P2,P3,Q1,Q2,Q3,AUX,H
  5630.     IER=2
  5631.     IF(NDIM)20,20,1
  5632. 1    Y=VAL(1)
  5633.     DELT2=0.
  5634.     IF(NDIM-1)20,20,2
  5635. C
  5636. C    PREPARATIONS FOR INTERPOLATION LOOP
  5637. 2    P2=1.D0
  5638.     P3=Y
  5639.     Q2=0.D0
  5640.     Q3=1.D0
  5641. C
  5642. C
  5643. C    START INTERPOLATION LOOP
  5644.     DO 16 I=2,NDIM
  5645.     II=0
  5646.     P1=P2
  5647.     P2=P3
  5648.     Q1=Q2
  5649.     Q2=Q3
  5650.     Z=Y
  5651.     DELT1=DELT2
  5652.     JEND=I-1
  5653. C
  5654. C    COMPUTATION OF INVERTED DIFFERENCES
  5655. 3    AUX=VAL(I)
  5656.     DO 10 J=1,JEND
  5657.     H=VAL(I)-VAL(J)
  5658.     IF(DABS(H)-1.D-13*DABS(VAL(I)))4,4,9
  5659. 4    IF(ARG(I)-ARG(J))5,17,5
  5660. 5    IF(J-JEND)8,6,6
  5661. C
  5662. C    INTERCHANGE ROW I WITH ROW I+II
  5663. 6    II=II+1
  5664.     III=I+II
  5665.     IF(III-NDIM)7,7,19
  5666. 7    VAL(I)=VAL(III)
  5667.     VAL(III)=AUX
  5668.     AUX=ARG(I)
  5669.     ARG(I)=ARG(III)
  5670.     ARG(III)=AUX
  5671.     GOTO 3
  5672. C
  5673. C    COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1
  5674. 8    VAL(I)=1.7D38                                                             0
  5675.     GOTO 10
  5676. C
  5677. C    COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J)
  5678. 9    VAL(I)=(ARG(I)-ARG(J))/H
  5679. 10    CONTINUE
  5680. C    INVERTED DIFFERENCES ARE COMPUTED
  5681. C
  5682. C    COMPUTATION OF NEW Y
  5683.     P3=VAL(I)*P2+(X-ARG(I-1))*P1
  5684.     Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1
  5685.     IF(Q3)11,12,11
  5686. 11    Y=P3/Q3
  5687.     GOTO 13
  5688. 12    Y=1.7D38                                                                  0
  5689. 13    DELT2=DABS(Z-Y)
  5690.     IF(DELT2-EPS)19,19,14
  5691. 14    IF(I-10)16,15,15
  5692. 15    IF(DELT2-DELT1)16,18,18
  5693. 16    CONTINUE
  5694. C    END OF INTERPOLATION LOOP
  5695. C
  5696. C
  5697.     RETURN
  5698. C
  5699. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  5700. 17    IER=3
  5701.     RETURN
  5702. C
  5703. C    TEST VALUE DELT2 STARTS OSCILLATING
  5704. 18    Y=Z
  5705.     IER=1
  5706.     RETURN
  5707. C
  5708. C    THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS
  5709. 19    IER=0
  5710. 20    RETURN
  5711.     END
  5712. C
  5713. C    ..................................................................
  5714. C
  5715. C       SUBROUTINE DAHI
  5716. C
  5717. C       PURPOSE
  5718. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  5719. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND
  5720. C          DERIVATIVE VALUES.
  5721. C
  5722. C       USAGE
  5723. C          CALL DAHI (X,ARG,VAL,Y,NDIM,EPS,IER)
  5724. C
  5725. C       DESCRIPTION OF PARAMETERS
  5726. C          X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
  5727. C          ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
  5728. C                   ARGUMENT VALUES OF THE TABLE (NOT DESTROYED).
  5729. C          VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION 2*NDIM) OF
  5730. C                   FUNCTION AND DERIVATIVE VALUES OF THE TABLE (DES-
  5731. C                   TROYED). FUNCTION AND DERIVATIVE VALUES MUST BE
  5732. C                   STORED IN PAIRS, THAT MEANS BEGINNING WITH FUNCTION
  5733. C                   VALUE AT POINT ARG(1) EVERY FUNCTION VALUE MUST BE
  5734. C                   FOLLOWED BY THE DERIVATIVE VALUE AT THE SAME POINT.
  5735. C          Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
  5736. C                   VALUE.
  5737. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  5738. C                   POINTS IN TABLE (ARG,VAL).
  5739. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  5740. C                   UPPER BOUND FOR THE ABSOLUTE ERROR.
  5741. C          IER    - A RESULTING ERROR PARAMETER.
  5742. C
  5743. C       REMARKS
  5744. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  5745. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  5746. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  5747. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  5748. C              SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
  5749. C              PREVIOUS STAGE.
  5750. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  5751. C              THAN 1.
  5752. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  5753. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  5754. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  5755. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  5756. C              (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE
  5757. C              PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
  5758. C              WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
  5759. C              ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
  5760. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  5761. C                       ACCURACY (NO ERROR).
  5762. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  5763. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  5764. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  5765. C                       NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
  5766. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  5767. C                       TABLE. NDIM SHOULD BE INCREASED.
  5768. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  5769. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  5770. C
  5771. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5772. C          NONE
  5773. C
  5774. C       METHOD
  5775. C          INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
  5776. C          HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
  5777. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  5778. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  5779. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  5780. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND
  5781. C          GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION,
  5782. C          JACM, VOL.11, ISS.3 (1964), PP.352-356.
  5783. C
  5784. C    ..................................................................
  5785. C
  5786.     SUBROUTINE DAHI(X,ARG,VAL,Y,NDIM,EPS,IER)
  5787. C
  5788. C
  5789.     DIMENSION ARG(1),VAL(1)
  5790.     DOUBLE PRECISION ARG,VAL,X,Y,H,H1,H2
  5791.     IER=2
  5792.     H2=X-ARG(1)
  5793.     IF(NDIM-1)2,1,3
  5794. 1    Y=VAL(1)+VAL(2)*H2
  5795. 2    RETURN
  5796. C
  5797. C    VECTOR ARG HAS MORE THAN 1 ELEMENT.
  5798. C    THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE
  5799. C    USED.
  5800. 3    I=1
  5801.     DO 5 J=2,NDIM
  5802.     H1=H2
  5803.     H2=X-ARG(J)
  5804.     Y=VAL(I)
  5805.     VAL(I)=Y+VAL(I+1)*H1
  5806.     H=H1-H2
  5807.     IF(H)4,13,4
  5808. 4    VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H
  5809. 5    I=I+2
  5810.     VAL(I)=VAL(I)+VAL(I+1)*H2
  5811. C    END OF FIRST STEP
  5812. C
  5813. C    PREPARE AITKEN SCHEME
  5814.     DELT2=0.
  5815.     IEND=I-1
  5816. C
  5817. C    START AITKEN-LOOP
  5818.     DO 9 I=1,IEND
  5819.     DELT1=DELT2
  5820.     Y=VAL(1)
  5821.     M=(I+3)/2
  5822.     H1=ARG(M)
  5823.     DO 6 J=1,I
  5824.     K=I+1-J
  5825.     L=(K+1)/2
  5826.     H=ARG(L)-H1
  5827.     IF(H)6,14,6
  5828. 6    VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H
  5829.     DELT2=DABS(Y-VAL(1))
  5830.     IF(DELT2-EPS)11,11,7
  5831. 7    IF(I-8)9,8,8
  5832. 8    IF(DELT2-DELT1)9,12,12
  5833. 9    CONTINUE
  5834. C    END OF AITKEN-LOOP
  5835. C
  5836. 10    Y=VAL(1)
  5837.     RETURN
  5838. C
  5839. C    THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS
  5840. 11    IER=0
  5841.     GOTO 10
  5842. C
  5843. C    TEST VALUE DELT2 STARTS OSCILLATING
  5844. 12    IER=1
  5845.     RETURN
  5846. C
  5847. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  5848. 13    Y=VAL(1)
  5849. 14    IER=3
  5850.     RETURN
  5851.     END
  5852. C
  5853. C    ..................................................................
  5854. C
  5855. C       SUBROUTINE DALI
  5856. C
  5857. C       PURPOSE
  5858. C          TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
  5859. C          X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
  5860. C          VALUES.
  5861. C
  5862. C       USAGE
  5863. C          CALL DALI (X,ARG,VAL,Y,NDIM,EPS,IER)
  5864. C
  5865. C       DESCRIPTION OF PARAMETERS
  5866. C          X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
  5867. C          ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
  5868. C                   ARGUMENT VALUES OF THE TABLE (NOT DESTROYED).
  5869. C          VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
  5870. C                   FUNCTION VALUES OF THE TABLE (DESTROYED).
  5871. C          Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
  5872. C                   VALUE.
  5873. C          NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
  5874. C                   POINTS IN TABLE (ARG,VAL).
  5875. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  5876. C                   UPPER BOUND FOR THE ABSOLUTE ERROR.
  5877. C                   FOR THE ABSOLUTE ERROR.
  5878. C          IER    - A RESULTING ERROR PARAMETER.
  5879. C
  5880. C       REMARKS
  5881. C          (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
  5882. C              FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
  5883. C              DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
  5884. C              SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
  5885. C              SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
  5886. C              PREVIOUS STAGE.
  5887. C          (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
  5888. C              THAN 1.
  5889. C          (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
  5890. C              BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
  5891. C              ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
  5892. C              VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
  5893. C              (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE
  5894. C              PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
  5895. C              WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
  5896. C              ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
  5897. C               IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
  5898. C                       ACCURACY (NO ERROR).
  5899. C               IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
  5900. C                       ACCURACY BECAUSE OF ROUNDING ERRORS.
  5901. C               IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
  5902. C                       NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY
  5903. C                       COULD NOT BE REACHED BY MEANS OF THE GIVEN
  5904. C                       TABLE. NDIM SHOULD BE INCREASED.
  5905. C               IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
  5906. C                       IN VECTOR ARG WHICH ARE IDENTICAL.
  5907. C
  5908. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  5909. C          NONE
  5910. C
  5911. C       METHOD
  5912. C          INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
  5913. C          LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
  5914. C          FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
  5915. C          (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
  5916. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  5917. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50.
  5918. C
  5919. C    ..................................................................
  5920. C
  5921.     SUBROUTINE DALI(X,ARG,VAL,Y,NDIM,EPS,IER)
  5922. C
  5923. C
  5924.     DIMENSION ARG(1),VAL(1)
  5925.     DOUBLE PRECISION ARG,VAL,X,Y,H
  5926.     IER=2
  5927.     DELT2=0.
  5928.     IF(NDIM-1)9,7,1
  5929. C
  5930. C    START OF AITKEN-LOOP
  5931. 1    DO 6 J=2,NDIM
  5932.     DELT1=DELT2
  5933.     IEND=J-1
  5934.     DO 2 I=1,IEND
  5935.     H=ARG(I)-ARG(J)
  5936.     IF(H)2,13,2
  5937. 2    VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H
  5938.     DELT2=DABS(VAL(J)-VAL(IEND))
  5939.     IF(J-2)6,6,3
  5940. 3    IF(DELT2-EPS)10,10,4
  5941. 4    IF(J-8)6,5,5
  5942. 5    IF(DELT2-DELT1)6,11,11
  5943. 6    CONTINUE
  5944. C    END OF AITKEN-LOOP
  5945. C
  5946. 7    J=NDIM
  5947. 8    Y=VAL(J)
  5948. 9    RETURN
  5949. C
  5950. C    THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS
  5951. 10    IER=0
  5952.     GOTO 8
  5953. C
  5954. C    TEST VALUE DELT2 STARTS OSCILLATING
  5955. 11    IER=1
  5956. 12    J=IEND
  5957.     GOTO 8
  5958. C
  5959. C    THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
  5960. 13    IER=3
  5961.     GOTO 12
  5962.     END
  5963. C
  5964. C    ..................................................................
  5965. C
  5966. C       SUBROUTINE DAPCH
  5967. C
  5968. C       PURPOSE
  5969. C          SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF
  5970. C          CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION
  5971. C
  5972. C       USAGE
  5973. C          CALL DAPCH(DATI,N,IP,XD,X0,WORK,IER)
  5974. C
  5975. C       DESCRIPTION OF PARAMETERS
  5976. C          DATI  - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1)
  5977. C                  CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE
  5978. C                  FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT
  5979. C                  VALUES. THE CONTENT OF VECTOR DATI REMAINS
  5980. C                  UNCHANGED.
  5981. C                  DATI MUST BE OF DOUBLE PRECISION
  5982. C          N     - NUMBER OF GIVEN POINTS
  5983. C          IP    - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF
  5984. C                  CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS
  5985. C                  IP SHOULD NOT EXCEED N
  5986. C          XD    - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR
  5987. C                  TRANSFORMATION OF ARGUMENT RANGE
  5988. C                  XD MUST BE DOUBLE PRECISION
  5989. C          X0    - RESULTANT ADDITIVE CONSTANT FOR LINEAR
  5990. C                  TRANSFORMATION OF ARGUMENT RANGE
  5991. C                  X0 MUST BE DOUBLE PRECISION
  5992. C          WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2
  5993. C                  ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
  5994. C                  MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM
  5995. C                  FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE
  5996. C                  AND SQUARE SUM OF FUNCTION VALUES
  5997. C                  WORK MUST BE OF DOUBLE PRECISION
  5998. C          IER   - RESULTING ERROR PARAMETER
  5999. C                  IER =-1 MEANS FORMAL ERRORS IN DIMENSION
  6000. C                  IER = 0 MEANS NO ERRORS
  6001. C                  IER = 1 MEANS COINCIDING ARGUMENTS
  6002. C
  6003. C       REMARKS
  6004. C          NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS
  6005. C          NOT POSITIVE.
  6006. C          EXECUTION OF SUBROUTINE DAPCH IS A PREPARATORY STEP FOR
  6007. C          CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS
  6008. C          IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS
  6009. C
  6010. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  6011. C          NONE
  6012. C
  6013. C       METHOD
  6014. C          THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV
  6015. C          POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM.
  6016. C          THE METHOD IS DISCUSSED IN THE ARTICLE
  6017. C          A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED
  6018. C          DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227.
  6019. C
  6020. C    ..................................................................
  6021. C
  6022.     SUBROUTINE DAPCH(DATI,N,IP,XD,X0,WORK,IER)
  6023. C
  6024. C
  6025. C      DIMENSIONED DUMMY VARIABLES
  6026.     DIMENSION DATI(1),WORK(1)
  6027.     DOUBLE PRECISION DATI,WORK,XD,X0,XA,XE,XM,DF,T,SUM
  6028. C
  6029. C       CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
  6030.     IF(N-1)19,20,1
  6031. 1    IF(IP)19,19,2
  6032. C
  6033. C       SEARCH SMALLEST AND LARGEST ARGUMENT
  6034. 2    IF(IP-N)3,3,19
  6035. 3    XA=DATI(1)
  6036.     X0=XA
  6037.     XE=0.D0
  6038.     DO 7 I=1,N
  6039.     XM=DATI(I)
  6040.     IF(XA-XM)5,5,4
  6041. 4    XA=XM
  6042. 5    IF(X0-XM)6,7,7
  6043. 6    X0=XM
  6044. 7    CONTINUE
  6045. C
  6046. C       INITIALIZE CALCULATION OF NORMAL EQUATIONS
  6047.     XD=X0-XA
  6048.     M=(IP*(IP+1))/2
  6049.     IEND=M+IP+1
  6050.     MT2=IP+IP
  6051.     MT2M=MT2-1
  6052. C
  6053. C       SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
  6054.     DO 8 I=1,IP
  6055.     J=MT2-I
  6056.     WORK(J)=0.D0
  6057.     WORK(I)=0.D0
  6058.     K=M+I
  6059. 8    WORK(K)=0.D0
  6060. C
  6061. C       CHECK FOR DEGENERATE ARGUMENT RANGE
  6062.     IF(XD)20,20,9
  6063. C
  6064. C       CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS
  6065. 9    X0=-(X0+XA)/XD
  6066.     XD=2.D0/XD
  6067.     SUM=0.D0
  6068. C
  6069. C       START GREAT LOOP OVER ALL GIVEN POINTS
  6070.     DO 15 I=1,N
  6071.     T=DATI(I)*XD+X0
  6072.     J=I+N
  6073.     DF=DATI(J)
  6074. C
  6075. C       CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS
  6076. C       FOR ARGUMENT T
  6077.     XA=1.D0
  6078.     XM=T
  6079.     IF(DATI(2*N+1))11,11,10
  6080. 10    J=J+N
  6081.     XA=DATI(J)
  6082.     XM=T*XA
  6083. 11    T=T+T
  6084.     SUM=SUM+DF*DF*XA
  6085.     DF=DF+DF
  6086.     J=1
  6087. 12    K=M+J
  6088.     WORK(K)=WORK(K)+DF*XA
  6089. 13    WORK(J)=WORK(J)+XA
  6090.     IF(J-MT2M)14,15,15
  6091. 14    J=J+1
  6092.     XE=T*XM-XA
  6093.     XA=XM
  6094.     XM=XE
  6095.     IF(J-IP)12,12,13
  6096. 15    CONTINUE
  6097.     WORK(IEND)=SUM+SUM
  6098. C
  6099. C       CALCULATE MATRIX OF NORMAL EQUATIONS
  6100.     LL=M
  6101.     KK=MT2M
  6102.     JJ=1
  6103.     K=KK
  6104.     DO 18 J=1,M
  6105.     WORK(LL)=WORK(K)+WORK(JJ)
  6106.     LL=LL-1
  6107.     IF(K-JJ)16,16,17
  6108. 16    KK=KK-2
  6109.     K=KK
  6110.     JJ=1
  6111.     GOTO 18
  6112. 17    JJ=JJ+1
  6113.     K=K-1
  6114. 18    CONTINUE
  6115.     IER=0
  6116.     RETURN
  6117. C
  6118. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  6119. 19    IER=-1
  6120.     RETURN
  6121. C
  6122. C       ERROR RETURN IN CASE OF COINCIDING ARGUMENTS
  6123. 20    IER=1
  6124.     RETURN
  6125.     END
  6126. C
  6127. C    ..................................................................
  6128. C
  6129. C       SUBROUTINE DAPFS
  6130. C
  6131. C       PURPOSE
  6132. C          PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL
  6133. C          EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT
  6134. C          OPTIONALLY
  6135. C
  6136. C       USAGE
  6137. C          CALL DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
  6138. C
  6139. C       DESCRIPTION OF PARAMETERS
  6140. C          WORK  - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED
  6141. C                  COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE.
  6142. C                  THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP
  6143. C                  LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK
  6144. C                  CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0
  6145. C                  THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G.
  6146. C                  BY SUBROUTINE APLL.
  6147. C                  THE GIVEN MATRIX IS FACTORED IN THE FORM
  6148. C                  TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS
  6149. C                  DIVIDED BY TRANSPOSE(T).
  6150. C                  THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF
  6151. C                  IOP EQUALS ZERO.
  6152. C                  IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE
  6153. C                  STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF
  6154. C                  CORRESPONDING DIMENSION AND E0  IS REPLACED BY THE
  6155. C                  SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES.
  6156. C                  THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2
  6157. C                  WORK MUST BE OF DOUBLE PRECISION
  6158. C          IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
  6159. C                  SQUARES FIT
  6160. C          IRES  - DIMENSION OF CALCULATED LEAST SQUARES FIT.
  6161. C                  LET N1, N2, DENOTE THE FOLLOWING NUMBERS
  6162. C                  N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF
  6163. C                       SIGNIFICANCE WAS INDICATED DURING FACTORIZATION
  6164. C                  N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF
  6165. C                       THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ)
  6166. C                  THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE
  6167. C                  AND  IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE
  6168. C          IOP   - INPUT PARAMETER FOR SELECTION OF OPERATION
  6169. C                  IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF
  6170. C                          THE RIGHT HAND SIDE BY TRANSPOSE(T) AND
  6171. C                          CALCULATION OF THE SQUARE SUM OF ERRORS IS
  6172. C                          PERFORMED ONLY
  6173. C                  IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES
  6174. C                          IS CALCULATED ADDITIONALLY
  6175. C                  IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE
  6176. C                          UP TO IRES ARE CALCULATED ADDITIONALLY
  6177. C          EPS   - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
  6178. C                  A SENSIBLE VALUE IS BETWEEN 1.E-10 AND 1.E-15
  6179. C          ETA   - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF
  6180. C                  ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-15
  6181. C          IER   - RESULTANT ERROR PARAMETER
  6182. C                  IER =-1 MEANS NONPOSITIVE IP
  6183. C                  IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED
  6184. C                          AND SPECIFIED TOLERANCE OF ERRORS REACHED
  6185. C                  IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR
  6186. C                          SPECIFIED TOLERANCE OF ERRORS NOT REACHED
  6187. C
  6188. C       REMARKS
  6189. C          THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF
  6190. C          SIGNIFICANCE IS TOL=ABS(EPS*SNGL(WORK(1))).
  6191. C          THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF
  6192. C          ERRORS IS ABS(ETA*SNGL(FSQ)).
  6193. C          IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2.
  6194. C          IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2.
  6195. C          IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN
  6196. C          ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE
  6197. C
  6198. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  6199. C          NONE
  6200. C
  6201. C       METHOD
  6202. C          CALCULATION OF THE LEAST SQUARES FITS IS DONE USING
  6203. C          CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION.
  6204. C          THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH
  6205. C          RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE
  6206. C          TOLERANCE TOL.
  6207. C          IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A
  6208. C          SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED.
  6209. C          IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS
  6210. C          TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE
  6211. C          ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION
  6212. C          FOR LOSS OF SIGNIFICANCE
  6213. C
  6214. C    ..................................................................
  6215. C
  6216.     SUBROUTINE DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
  6217. C
  6218. C
  6219. C       DIMENSIONED DUMMY VARIABLES
  6220.     DIMENSION WORK(1)
  6221.     DOUBLE PRECISION WORK,SUM,PIV
  6222.     IRES=0
  6223. C
  6224. C       TEST OF SPECIFIED DIMENSION
  6225.     IF(IP)1,1,2
  6226. C
  6227. C       ERROR RETURN IN CASE OF ILLEGAL DIMENSION
  6228. 1    IER=-1
  6229.     RETURN
  6230. C
  6231. C       INITIALIZE FACTORIZATION PROCESS
  6232. 2    IPIV=0
  6233.     IPP1=IP+1
  6234.     IER=1
  6235.     ITE=IP*IPP1/2
  6236.     IEND=ITE+IPP1
  6237.     TOL=ABS(EPS*SNGL(WORK(1)))
  6238.     TEST=ABS(ETA*SNGL(WORK(IEND)))
  6239. C
  6240. C       START LOOP OVER ALL ROWS OF WORK
  6241.     DO 11 I=1,IP
  6242.     IPIV=IPIV+I
  6243.     JA=IPIV-IRES
  6244.     JE=IPIV-1
  6245. C
  6246. C       FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS
  6247.     JK=IPIV
  6248.     DO 9 K=I,IPP1
  6249.     SUM=0.D0
  6250.     IF(IRES)5,5,3
  6251. 3    JK=JK-IRES
  6252.     DO 4 J=JA,JE
  6253.     SUM=SUM+WORK(J)*WORK(JK)
  6254. 4    JK=JK+1
  6255. 5    IF(JK-IPIV)6,6,8
  6256. C
  6257. C       TEST FOR LOSS OF SIGNIFICANCE
  6258. 6    SUM=WORK(IPIV)-SUM
  6259.     IF(SNGL(SUM)-TOL)12,12,7
  6260. 7    SUM=DSQRT(SUM)
  6261.     WORK(IPIV)=SUM
  6262.     PIV=1.D0/SUM
  6263.     GOTO 9
  6264. C
  6265. C       UPDATE OFF-DIAGONAL TERMS
  6266. 8    SUM=(WORK(JK)-SUM)*PIV
  6267.     WORK(JK)=SUM
  6268. 9    JK=JK+K
  6269. C
  6270. C       UPDATE SQUARE SUM OF ERRORS
  6271.     WORK(IEND)=WORK(IEND)-SUM*SUM
  6272. C
  6273. C       RECORD ADDRESS OF LAST PIVOT ELEMENT
  6274.     IRES=IRES+1
  6275.     IADR=IPIV
  6276. C
  6277. C       TEST FOR TOLERABLE ERROR IF SPECIFIED
  6278.     IF(IOP)10,11,11
  6279. 10    IF(SNGL(WORK(IEND))-TEST)13,13,11
  6280. 11    CONTINUE
  6281.     IF(IOP)12,22,12
  6282. C
  6283. C       PERFORM BACK SUBSTITUTION IF SPECIFIED
  6284. 12    IF(IOP)14,23,14
  6285. 13    IER=0
  6286. 14    IPIV=IRES
  6287. 15    IF(IPIV)23,23,16
  6288. 16    SUM=0.D0
  6289.     JA=ITE+IPIV
  6290.     JJ=IADR
  6291.     JK=IADR
  6292.     K=IPIV
  6293.     DO 19 I=1,IPIV
  6294.     WORK(JK)=(WORK(JA)-SUM)/WORK(JJ)
  6295.     IF(K-1)20,20,17
  6296. 17    JE=JJ-1
  6297.     SUM=0.D0
  6298.     DO 18 J=K,IPIV
  6299.     SUM=SUM+WORK(JK)*WORK(JE)
  6300.     JK=JK+1
  6301. 18    JE=JE+J
  6302.     JK=JE-IPIV
  6303.     JA=JA-1
  6304.     JJ=JJ-K
  6305. 19    K=K-1
  6306. 20    IF(IOP/2)21,23,21
  6307. 21    IADR=IADR-IPIV
  6308.     IPIV=IPIV-1
  6309.     GOTO 15
  6310. C
  6311. C       NORMAL RETURN
  6312. 22    IER=0
  6313. 23    RETURN
  6314.     END
  6315. C
  6316. C    ..................................................................
  6317. C
  6318. C       SUBROUTINE DAPLL
  6319. C       PURPOSE
  6320. C          SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT
  6321. C          TO A GIVEN DISCRETE FUNCTION
  6322. C
  6323. C       USAGE
  6324. C          CALL DAPLL(FFCT,N,IP,P,WORK,DATI,IER)
  6325. C          SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT
  6326. C
  6327. C       DESCRIPTION OF PARAMETERS
  6328. C          FFCT  - USER CODED SUBROUTINE WHICH MUST BE DECLARED
  6329. C                  EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED
  6330. C                  CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS
  6331. C                  THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR
  6332. C                  THE I-TH ARGUMENT IN P(1) UP TO P(IP)
  6333. C                  FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1)
  6334. C                  N IS THE NUMBER OF ALL POINTS
  6335. C                  P,DATI,WGT MUST BE OF DOUBLE PRECISION.
  6336. C                  DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY
  6337. C                  NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI
  6338. C                  WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT
  6339. C                  IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT
  6340. C          N     - NUMBER OF GIVEN POINTS
  6341. C          IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
  6342. C                  SQUARES FIT
  6343. C                  IP SHOULD NOT EXCEED N
  6344. C          P     - WORKING STORAGE OF DIMENSION IP+1, WHICH
  6345. C                  IS USED AS INTERFACE BETWEEN APLL AND THE USER
  6346. C                  CODED SUBROUTINE FFCT
  6347. C                  P MUST BE OF DOUBLE PRECISION.
  6348. C          WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2.
  6349. C                  ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
  6350. C                  MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM,
  6351. C                  I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE.
  6352. C                  THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT
  6353. C                  HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS
  6354. C                  THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES
  6355. C                  WORK MUST BE OF DOUBLE PRECISION.
  6356. C          DATI  - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN
  6357. C                  MAIN LINE AND SUBROUTINE FFCT.
  6358. C                  DATI MUST BE OF DOUBLE PRECISION.
  6359. C          IER   - RESULTING ERROR PARAMETER
  6360. C                  IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS
  6361. C                  IER = 0 MEANS NO ERRORS
  6362. C                  IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT
  6363. C
  6364. C       REMARKS
  6365. C          TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES
  6366. C          BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR
  6367. C          PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN
  6368. C          SUBROUTINE DAPLL. ADDITIONAL COMPONENTS OF IER MAY BE
  6369. C          INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH.
  6370. C          IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A
  6371. C          VECTOR IN HIS MAINLINE.
  6372. C          EXECUTION OF SUBROUTINE DAPLL IS A PREPARATORY STEP FOR
  6373. C          CALCULATION OF THE LINEAR LEAST SQUARES FIT.
  6374. C          NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS
  6375. C
  6376. C      SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  6377. C          THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER
  6378. C
  6379. C       METHOD
  6380. C          HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES
  6381. C          AND WEIGHTS) IS COMPLETELY LEFT TO THE USER
  6382. C          ESSENTIALLY HE HAS THREE CHOICES
  6383. C          (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  6384. C              ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I.
  6385. C          (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  6386. C              ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS
  6387. C              REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI
  6388. C              (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1
  6389. C              LOCATIONS).
  6390. C              ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE
  6391. C              BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE
  6392. C              STORAGE FOR THE DATA SET IN COMMON.
  6393. C          (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
  6394. C              ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY
  6395. C              ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM
  6396. C              ONE UP TO N WITHIN APLL
  6397. C
  6398. C    ..................................................................
  6399. C
  6400.     SUBROUTINE DAPLL(FFCT,N,IP,P,WORK,DATI,IER)
  6401. C
  6402. C
  6403. C       DIMENSIONED DUMMY VARIABLES
  6404.     DIMENSION P(1),WORK(1),DATI(1),IER(1)
  6405.     DOUBLE PRECISION P,WORK,DATI,WGT,AUX
  6406. C
  6407. C       CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
  6408.     IF(N)10,10,1
  6409. 1    IF(IP)10,10,2
  6410. 2    IF(N-IP)10,3,3
  6411. C
  6412. C       SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
  6413. 3    IPP1=IP+1
  6414.     M=IPP1*(IP+2)/2
  6415.     IER(1)=0
  6416.     DO 4 I=1,M
  6417. 4    WORK(I)=0.D0
  6418. C
  6419. C       START GREAT LOOP OVER ALL GIVEN POINTS
  6420.     DO 8 I=1,N
  6421.     CALL FFCT(I,N,IP,P,DATI,WGT,IER)
  6422.     IF(IER(1))9,5,9
  6423. 5    J=0
  6424.     DO 7 K=1,IPP1
  6425.     AUX=P(K)*WGT
  6426.     DO 6 L=1,K
  6427.     J=J+1
  6428. 6    WORK(J)=WORK(J)+P(L)*AUX
  6429. 7    CONTINUE
  6430. 8    CONTINUE
  6431. C
  6432. C       NORMAL RETURN
  6433. 9    RETURN
  6434. C
  6435. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  6436. 10    IER(1)=-1
  6437.     RETURN
  6438.     END
  6439. C
  6440. C    ..................................................................
  6441. C
  6442. C       SUBROUTINE DAPMM
  6443. C
  6444. C       PURPOSE
  6445. C          APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR
  6446. C          COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE
  6447. C          OF CHEBYSHEV.
  6448. C
  6449. C       USAGE
  6450. C          CALL DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
  6451. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE
  6452. C          CALLING PROGRAM.
  6453. C
  6454. C       DESCRIPTION OF PARAMETERS
  6455. C          FCT    - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER.
  6456. C                   IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR
  6457. C                   ARGUMENT VALUE X.
  6458. C                   USAGE
  6459. C                      CALL FCT(Y,X,K)
  6460. C                   DESCRIPTION OF PARAMETERS
  6461. C                      Y   - DOUBLE PRECISION RESULT VECTOR OF DIMEN-
  6462. C                            SION M CONTAINING THE VALUES OF GIVEN
  6463. C                            CONTINUOUS FUNCTIONS FOR GIVEN ARGUMENT X
  6464. C                      X   - DOUBLE PRECISON ARGUMENT VALUE
  6465. C                      K   - AN INTEGER VALUE WHICH IS EQUAL TO M-1
  6466. C                   REMARKS
  6467. C                      IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED
  6468. C                      CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO-
  6469. C                      MIALS IS DESIRED SUBROUTINES DCNP,DCSP,DLEP,
  6470. C                      DLAP,DHEP, RESPECTIVELY FROM SSP COULD BE USED.
  6471. C          N      - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH
  6472. C                   IS TO BE APPROXIMATED
  6473. C          M      - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH
  6474. C                   THE APPROXIMATING FUNCTION IS CONSTRUCTED.
  6475. C          TOP    - DOUBLE PRECISION VECTOR OF DIMENSION 3*N.
  6476. C                   ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N)
  6477. C                   THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP
  6478. C                   TO TOP(2*N) THE CORRESPONDING NODES
  6479. C                   ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N)
  6480. C                   THE ERRORS AT THOSE N NODES.
  6481. C                   OTHER VALUES OF TOP ARE SCRATCH.
  6482. C          IHE    - INTEGER VECTOR OF DIMENSION 3*M+4*N+6
  6483. C          PIV    - DOUBLE PRECISION VECTOR OF DIMENSION 3*M+6.
  6484. C                   ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE
  6485. C                   RESULTING COEFFICIENTS OF LINEAR APPROXIMATION.
  6486. C          T      - DOUBLE PRECISION AUXILIARY VECTOR OF DIMENSION
  6487. C                   (M+2)*(M+2)
  6488. C          ITER   - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF
  6489. C                   ITERATIONS NEEDED
  6490. C          IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
  6491. C                   FORM
  6492. C                    IER=0  - NO ERROR
  6493. C                    IER=1  - THE NUMBER OF ITERATIONS HAS REACHED
  6494. C                             THE INTERNAL MAXIMUM N+M
  6495. C                    IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA-
  6496. C                             METER M OR N OR SINCE AT SOME ITERATION
  6497. C                             NO SUITABLE PIVOT COULD BE FOUND
  6498. C
  6499. C       REMARKS
  6500. C          NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR
  6501. C          N LESS THAN 2.
  6502. C
  6503. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  6504. C          THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER.
  6505. C
  6506. C       METHOD
  6507. C          THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY
  6508. C          LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF
  6509. C          CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS-
  6510. C          FORMED INTO A LINEAR PROGRAMMING PROBLEM. DAPMM USES A
  6511. C          REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL
  6512. C          PROBLEM. FOR REFERENCE, SEE
  6513. C          I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND
  6514. C          L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET,
  6515. C          NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306.
  6516. C
  6517. C    ..................................................................
  6518. C
  6519.     SUBROUTINE DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
  6520. C
  6521. C
  6522.     DIMENSION TOP(1),IHE(1),PIV(1),T(1)
  6523.     DOUBLE PRECISION DSUM,TOP,PIV,T,SAVE,HELP,REPI,TOL
  6524. C
  6525. C       TEST ON WRONG INPUT PARAMETERS N AND M
  6526.     IER=-1
  6527.     IF (N-1) 81,81,1
  6528. 1    IF(M) 81,81,2
  6529. C
  6530. C       INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU
  6531. 2    IER=0
  6532. C
  6533. C       PREPARE TOP-ROW TOP
  6534.     DO 3 I=1,N
  6535.     K=I+N
  6536.     J=K+N
  6537.     TOP(J)=TOP(K)
  6538. 3    TOP(K)=-TOP(I)
  6539. C
  6540. C       PREPARE INVERSE TRANSFORMATION MATRIX T
  6541.     L=M+2
  6542.     LL=L*L
  6543.     DO 4 I=1,LL
  6544. 4    T(I)=0.D0
  6545.     K=1
  6546.     J=L+1
  6547.     DO 5 I=1,L
  6548.     T(K)=1.D0
  6549. 5    K=K+J
  6550. C
  6551. C       PREPARE INDEX-VECTOR IHE
  6552.     DO 6 I=1,L
  6553.     K=I+L
  6554.     J=K+L
  6555.     IHE(I)=0
  6556.     IHE(K)=I
  6557. 6    IHE(J)=1-I
  6558.     NAN=N+N
  6559.     K=L+L+L
  6560.     J=K+NAN
  6561.     DO 7 I=1,NAN
  6562.     K=K+1
  6563.     IHE(K)=I
  6564.     J=J+1
  6565. 7    IHE(J)=I
  6566. C
  6567. C       SET COUNTER ITER FOR ITERATION-STEPS
  6568.     ITER=-1
  6569. 8    ITER=ITER+1
  6570. C
  6571. C       TEST FOR MAXIMUM ITERATION-STEPS
  6572.     IF(N+M-ITER) 9,9,10
  6573. 9    IER=1
  6574.     GO TO 69
  6575. C
  6576. C       DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP
  6577. 10    ISE=0
  6578.     IPIV=0
  6579.     K=L+L+L
  6580.     SAVE=0.D0
  6581. C
  6582. C       START TOP-LOOP
  6583.     DO 14 I=1,NAN
  6584.     IDO=K+I
  6585.     HELP=TOP(I)
  6586.     IF(HELP-SAVE) 12,12,11
  6587. 11    SAVE=HELP
  6588.     IPIV=I
  6589. 12    IF(IHE(IDO)) 14,13,14
  6590. 13    ISE=I
  6591. 14    CONTINUE
  6592. C       END OF TOP-LOOP
  6593. C
  6594. C       IS OPTIMAL TABLEAU REACHED
  6595.     IF(IPIV) 69,69,15
  6596. C
  6597. C       DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE
  6598. 15    ILAB=1
  6599.     IND=0
  6600.     J=ISE
  6601.     IF(J) 21,21,34
  6602. C
  6603. C       TRANSFER K-TH COLUMN FROM T TO PIV
  6604. 16    K=(K-1)*L
  6605.     DO 17 I=1,L
  6606.     J=L+I
  6607.     K=K+1
  6608. 17    PIV(J)=T(K)
  6609. C
  6610. C       IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT
  6611. 18    IF(ISE) 22,22,19
  6612. 19    ISE=-ISE
  6613. C
  6614. C       TRANSFER COLUMNS IN PIV
  6615.     J=L+1
  6616.     IDO=L+L
  6617.     DO 20 I=J,IDO
  6618.     K=I+L
  6619. 20    PIV(K)=PIV(I)
  6620. 21    J=IPIV
  6621.     GO TO 34
  6622. C
  6623. C       SEARCH PIVOT-ELEMENT PIV(IND)
  6624. 22    SAVE=1.D38
  6625.     IDO=0
  6626.     K=L+1
  6627.     LL=L+L
  6628.     IND=0
  6629. C
  6630. C       START PIVOT-LOOP
  6631.     DO 29 I=K,LL
  6632.     J=I+L
  6633.     HELP=PIV(I)
  6634.     IF(HELP) 29,29,23
  6635. 23    HELP=-HELP
  6636.     IF(ISE) 26,24,26
  6637. 24    IF(IHE(J)) 27,25,27
  6638. 25    IDO=I
  6639.     GO TO 29
  6640. 26    HELP=-PIV(J)/HELP
  6641. 27    IF(HELP-SAVE) 28,29,29
  6642. 28    SAVE=HELP
  6643.     IND=I
  6644. 29    CONTINUE
  6645. C       END OF PIVOT-LOOP
  6646. C
  6647. C       TEST FOR SUITABLE PIVOT-ELEMENT
  6648.     IF(IND) 30,30,32
  6649. 30    IF(IDO) 68,68,31
  6650. 31    IND=IDO
  6651. C       PIVOT-ELEMENT IS STORED IN PIV(IND)
  6652. C
  6653. C       COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI
  6654. 32    REPI=1.D0/PIV(IND)
  6655.     IND=IND-L
  6656. C
  6657. C       UPDATE THE TOP-ROW TOP OF THE TABLEAU
  6658.     ILAB=0
  6659.     SAVE=-TOP(IPIV)*REPI
  6660.     TOP(IPIV)=SAVE
  6661. C
  6662. C       INITIALIZE J AS COUNTER FOR TOP-LOOP
  6663.     J=NAN
  6664. 33    IF(J-IPIV) 34,53,34
  6665. 34    K=0
  6666. C
  6667. C       SEARCH COLUMN IN TRANSFORMATION-MATRIX T
  6668.     DO 36 I=1,L
  6669.     IF(IHE(I)-J) 36,35,36
  6670. 35    K=I
  6671.     IF(ILAB) 50,50,16
  6672. 36    CONTINUE
  6673. C
  6674. C       GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX
  6675.     I=L+L+L+NAN+J
  6676.     I=IHE(I)-N
  6677.     IF(I) 37,37,38
  6678. 37    I=I+N
  6679.     K=1
  6680. 38    I=I+NAN
  6681. C
  6682. C       CALL SUBROUTINE FCT
  6683.     CALL FCT(PIV,TOP(I),M-1)
  6684. C
  6685. C       PREPARE THE CALLED VECTOR PIV
  6686.     DSUM=0.D0
  6687.     IDO=M
  6688.     DO 41 I=1,M
  6689.     HELP=PIV(IDO)
  6690.     IF(K) 39,39,40
  6691. 39    HELP=-HELP
  6692. 40    DSUM=DSUM+HELP
  6693.     PIV(IDO+1)=HELP
  6694. 41    IDO=IDO-1
  6695.     PIV(L)=-DSUM
  6696.     PIV(1)=1.D0
  6697. C
  6698. C       TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T
  6699.     IDO=IND
  6700.     IF(ILAB) 44,44,42
  6701. 42    K=1
  6702. 43    IDO=K
  6703. 44    DSUM=0.D0
  6704.     HELP=0.D0
  6705. C
  6706. C       START MULTIPLICATION-LOOP
  6707.     DO 46 I=1,L
  6708.     DSUM=DSUM+PIV(I)*T(IDO)
  6709.     TOL=DABS(DSUM)
  6710.     IF(TOL-HELP) 46,46,45
  6711. 45    HELP=TOL
  6712. 46    IDO=IDO+L
  6713. C       END OF MULTIPLICATION-LOOP
  6714. C
  6715.     TOL=1.D-14*HELP
  6716.     IF(DABS(DSUM)-TOL) 47,47,48
  6717. 47    DSUM=0.D0
  6718. 48    IF(ILAB) 51,51,49
  6719. 49    I=K+L
  6720.     PIV(I)=DSUM
  6721. C
  6722. C       TEST FOR LAST COLUMN-TERM
  6723.     K=K+1
  6724.     IF(K-L) 43,43,18
  6725. 50    I=(K-1)*L+IND
  6726.     DSUM=T(I)
  6727. C
  6728. C       COMPUTE NEW TOP-ELEMENT
  6729. 51    DSUM=DSUM*SAVE
  6730.     TOL=1.D-14*DABS(DSUM)
  6731.     TOP(J)=TOP(J)+DSUM
  6732.     IF(DABS(TOP(J))-TOL) 52,52,53
  6733. 52    TOP(J)=0.D0
  6734. C
  6735. C       TEST FOR LAST TOP-TERM
  6736. 53    J=J-1
  6737.     IF(J) 54,54,33
  6738. C       END OF TOP-LOOP
  6739. C
  6740. C       TRANSFORM PIVOT-COLUMN
  6741. 54    I=IND+L
  6742.     PIV(I)=-1.D0
  6743.     DO 55 I=1,L
  6744.     J=I+L
  6745. 55    PIV(I)=-PIV(J)*REPI
  6746. C
  6747. C       UPDATE TRANSFORMATION-MATRIX T
  6748.     J=0
  6749.     DO 57 I=1,L
  6750.     IDO=J+IND
  6751.     SAVE=T(IDO)
  6752.     T(IDO)=0.D0
  6753.     DO 56 K=1,L
  6754.     ISE=K+J
  6755. 56    T(ISE)=T(ISE)+SAVE*PIV(K)
  6756. 57    J=J+L
  6757. C
  6758. C       UPDATE INDEX-VECTOR IHE
  6759. C       INITIALIZE CHARACTERISTICS
  6760.     J=0
  6761.     K=0
  6762.     ISE=0
  6763.     IDO=0
  6764. C
  6765. C       START QUESTION-LOOP
  6766.     DO 61 I=1,L
  6767.     LL=I+L
  6768.     ILAB=IHE(LL)
  6769.     IF(IHE(I)-IPIV) 59,58,59
  6770. 58    ISE=I
  6771.     J=ILAB
  6772. 59    IF(ILAB-IND) 61,60,61
  6773. 60    IDO=I
  6774.     K=IHE(I)
  6775. 61    CONTINUE
  6776. C       END OF QUESTION-LOOP
  6777. C
  6778. C       START MODIFICATION
  6779.     IF(K) 62,62,63
  6780. 62    IHE(IDO)=IPIV
  6781.     IF(ISE) 67,67,65
  6782. 63    IF(IND-J) 64,66,64
  6783. 64    LL=L+L+L+NAN
  6784.     K=K+LL
  6785.     I=IPIV+LL
  6786.     ILAB=IHE(K)
  6787.     IHE(K)=IHE(I)
  6788.     IHE(I)=ILAB
  6789.     IF(ISE) 67,67,65
  6790. 65    IDO=IDO+L
  6791.     I=ISE+L
  6792.     IHE(IDO)=J
  6793.     IHE(I)=IND
  6794. 66    IHE(ISE)=0
  6795. 67    LL=L+L
  6796.     J=LL+IND
  6797.     I=LL+L+IPIV
  6798.     ILAB=IHE(I)
  6799.     IHE(I)=IHE(J)
  6800.     IHE(J)=ILAB
  6801. C       END OF MODIFICATION
  6802. C
  6803.     GO TO 8
  6804. C
  6805. C       SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND
  6806. 68    IER=-1
  6807. C
  6808. C       EVALUATE FINAL TABLEAU
  6809. C       COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND
  6810. C       HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS
  6811. 69    SAVE=0.D0
  6812.     HELP=0.D0
  6813.     K=L+L+L
  6814.     DO 73 I=1,NAN
  6815.     IDO=K+I
  6816.     J=IHE(IDO)
  6817.     IF(J) 71,70,73
  6818. 70    SAVE=-TOP(I)
  6819. 71    IF(M+J+1) 73,72,73
  6820. 72    HELP=TOP(I)
  6821. 73    CONTINUE
  6822. C
  6823. C       PREPARE T,TOP,PIV
  6824.     T(1)=SAVE
  6825.     IDO=NAN+1
  6826.     J=NAN+N
  6827.     DO 74 I=IDO,J
  6828. 74    TOP(I)=SAVE
  6829.     DO 75 I=1,M
  6830. 75    PIV(I)=HELP
  6831. C
  6832. C       COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI
  6833. C       AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N)
  6834.     DO 79 I=1,NAN
  6835.     IDO=K+I
  6836.     J=IHE(IDO)
  6837.     IF(J) 76,79,77
  6838. 76    J=-J
  6839.     PIV(J)=HELP-TOP(I)
  6840.     GO TO 79
  6841. 77    IF(J-N) 78,78,79
  6842. 78    J=J+NAN
  6843.     TOP(J)=SAVE+TOP(I)
  6844. 79    CONTINUE
  6845.     DO 80 I=1,N
  6846.     IDO=NAN+I
  6847. 80    TOP(I)=TOP(IDO)
  6848. 81    RETURN
  6849.     END
  6850. C
  6851. C    ..................................................................
  6852. C
  6853. C       SUBROUTINE DARAT
  6854. C
  6855. C       PURPOSE
  6856. C          CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE
  6857. C          FUNCTION IN THE LEAST SQUARES SENSE
  6858. C
  6859. C       USAGE
  6860. C          CALL DARAT(DATI,N,WORK,P,IP,IQ,IER)
  6861. C
  6862. C       DESCRIPTION OF PARAMETERS
  6863. C          DATI  - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS
  6864. C                  THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS,
  6865. C                  THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND
  6866. C                  THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY.
  6867. C                  IF NO WEIGHTS ARE TO BE USED THEN THE THIRD
  6868. C                  COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT
  6869. C                  WHICH MUST CONTAIN A NONPOSITIVE VALUE
  6870. C                  DATI MUST BE OF DOUBLE PRECISION
  6871. C          N     - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION
  6872. C          WORK  - WORKING STORAGE WHICH IS OF DIMENSION
  6873. C                  (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST.
  6874. C                  ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED
  6875. C                  IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF
  6876. C                  THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO
  6877. C                  WORK(3*N)
  6878. C                  WORK MUST BE OF DOUBLE PRECISION
  6879. C          P     - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND
  6880. C                  NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ
  6881. C                  LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP
  6882. C                  LOCATIONS.
  6883. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH.
  6884. C                  P MUST BE OF DOUBLE PRECISION
  6885. C          IP    - DIMENSION OF THE NUMERATOR   (INPUT VALUE)
  6886. C          IQ    - DIMENSION OF THE DENOMINATOR (INPUT VALUE)
  6887. C          IER   - RESULTANT ERROR PARAMETER
  6888. C                  IER =-1 MEANS FORMAL ERRORS
  6889. C                  IER = 0 MEANS NO ERRORS
  6890. C                  IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION
  6891. C                  IER IS ALSO USED AS INPUT VALUE
  6892. C                  A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN
  6893. C                  INITIAL APPROXIMATION STORED IN P
  6894. C
  6895. C       REMARKS
  6896. C          THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR
  6897. C          OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P
  6898. C          STARTING WITH LOW POWERS (DENOMINATOR FIRST).
  6899. C          IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE.
  6900. C          SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL
  6901. C          FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL
  6902. C          (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR
  6903. C          TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS.
  6904. C          IF A FIT IN OTHER FUNCTIONS IS REQUIRED, DCNP AND DCNPS MUST
  6905. C          BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN.
  6906. C
  6907. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  6908. C          DAPLL, DAPFS, DFRAT, DCNPS, DCNP
  6909. C          DCNP IS REQUIRED WITHIN DFRAT
  6910. C
  6911. C       METHOD
  6912. C          THE ITERATIVE SCHEME USED FOR CALCULATION OF THE
  6913. C          APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS
  6914. C          WHICH ARE OBTAINED BY LINEARIZATION.
  6915. C          A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH
  6916. C          IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF
  6917. C          ZEROES WITHIN THE APPROXIMATION INTERVAL.
  6918. C          FOR REFERENCE SEE
  6919. C          D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN,
  6920. C          COMPUTING(1966), VOL.1, ED.3, PP.264-272.
  6921. C          D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION
  6922. C          OF NONLINEAR PARAMETERS,
  6923. C          JSIAM(1963), VOL.11, ED.2, PP.431-441.
  6924. C
  6925. C    ..................................................................
  6926. C
  6927.     SUBROUTINE DARAT(DATI,N,WORK,P,IP,IQ,IER)
  6928. C
  6929. C
  6930.     EXTERNAL DFRAT
  6931. C
  6932. C       DIMENSIONED LOCAL VARIABLE
  6933.     DIMENSION IERV(3)
  6934. C
  6935. C       DIMENSIONED DUMMY VARIABLES
  6936.     DIMENSION DATI(1),WORK(1),P(1)
  6937.     DOUBLE PRECISION DATI,WORK,P,T,OSUM,DIAG,RELAX,SUM,SSOE,SAVE
  6938. C
  6939. C       INITIALIZE TESTVALUES
  6940.     LIMIT=20
  6941.     ETA=1.E-29
  6942.     EPS=1.E-14
  6943. C
  6944. C       CHECK FOR FORMAL ERRORS
  6945.     IF(N)4,4,1
  6946. 1    IF(IP)4,4,2
  6947. 2    IF(IQ)4,4,3
  6948. 3    IPQ=IP+IQ
  6949.     IF(N-IPQ)4,5,5
  6950. C
  6951. C       ERROR RETURN IN CASE OF FORMAL ERRORS
  6952. 4    IER=-1
  6953.     RETURN
  6954. C
  6955. C       INITIALIZE ITERATION PROCESS
  6956. 5    KOUNT=0
  6957.     IERV(2)=IP
  6958.     IERV(3)=IQ
  6959.     NDP=N+N+1
  6960.     NNE=NDP+NDP
  6961.     IX=IPQ-1
  6962.     IQP1=IQ+1
  6963.     IRHS=NNE+IPQ*IX/2
  6964.     IEND=IRHS+IX
  6965. C
  6966. C       TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION
  6967.     IF(IER)8,6,8
  6968. C
  6969. C       INITIALIZE NUMERATOR AND DENOMINATOR
  6970. 6    DO 7 I=2,IPQ
  6971. 7    P(I)=0.D0
  6972.     P(1)=1.D0
  6973. C
  6974. C       CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL
  6975. C       APPROXIMATION
  6976. 8    DO 9 J=1,N
  6977.     T=DATI(J)
  6978.     I=J+N
  6979.     CALL DCNPS(WORK(I),T,P(IQP1),IP)
  6980.     K=I+N
  6981. 9    CALL DCNPS(WORK(K),T,P,IQ)
  6982. C
  6983. C       SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION)
  6984. 10    CALL DAPLL(DFRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV)
  6985. C
  6986. C       CHECK FOR ZERO DENOMINATOR
  6987.     IF(IERV(1))4,11,4
  6988. 11    INCR=0
  6989.     RELAX=2.D0
  6990. C
  6991. C       RESTORE MATRIX IN WORKING STORAGE
  6992. 12    J=IEND
  6993.     DO 13 I=NNE,IEND
  6994.     J=J+1
  6995. 13    WORK(I)=WORK(J)
  6996.     IF(KOUNT)14,14,15
  6997. C
  6998. C       SAVE SQUARE SUM OF ERRORS
  6999. 14    OSUM=WORK(IEND)
  7000.     DIAG=OSUM*EPS
  7001.     K=IQ
  7002. C
  7003. C       ADD CONSTANT TO DIAGONAL
  7004.     IF(WORK(NNE))17,17,19
  7005. 15    IF(INCR)19,19,16
  7006. 16    K=IPQ
  7007. 17    J=NNE-1
  7008.     DO 18 I=1,K
  7009.     WORK(J)=WORK(J)+DIAG
  7010. 18    J=J+I
  7011. C
  7012. C       SOLVE NORMAL EQUATIONS
  7013. 19    CALL DAPFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER)
  7014. C
  7015. C       CHECK FOR FAILURE OF EQUATION SOLVER
  7016.     IF(IRES)4,4,20
  7017. C
  7018. C       TEST FOR DEFECTIVE NORMALEQUATIONS
  7019. 20    IF(IRES-IX)21,24,24
  7020. 21    IF(INCR)22,22,23
  7021. 22    DIAG=DIAG*0.125D0
  7022. 23    DIAG=DIAG+DIAG
  7023.     INCR=INCR+1
  7024. C
  7025. C       START WITH OVER RELAXATION
  7026.     RELAX=8.D0
  7027.     IF(INCR-LIMIT)12,45,45
  7028. C
  7029. C       CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR
  7030. 24    L=NDP
  7031.     J=NNE+IRES*(IRES-1)/2-1
  7032.     K=J+IQ
  7033.     WORK(J)=0.D0
  7034.     IRQ=IQ
  7035.     IRP=IRES-IQ+1
  7036.     IF(IRP)25,26,26
  7037. 25    IRQ=IRES+1
  7038. 26    DO 29 I=1,N
  7039.     T=DATI(I)
  7040.     WORK(I)=0.D0
  7041.     CALL DCNPS(WORK(I),T,WORK(K),IRP)
  7042.     M=L+N
  7043.     CALL DCNPS(WORK(M),T,WORK(J),IRQ)
  7044.     IF(WORK(M)*WORK(L))27,29,29
  7045. 27    SUM=WORK(L)/WORK(M)
  7046.     IF(RELAX+SUM)29,29,28
  7047. 28    RELAX=-SUM
  7048. 29    L=L+1
  7049. C
  7050. C       MODIFY RELAXATION FACTOR IF NECESSARY
  7051.     SSOE=OSUM
  7052.     ITER=LIMIT
  7053. 30    SUM=0.D0
  7054.     RELAX=RELAX*0.5D0
  7055.     DO 32 I=1,N
  7056.     M=I+N
  7057.     K=M+N
  7058.     L=K+N
  7059.     SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L))
  7060.     SAVE=SAVE*SAVE
  7061.     IF(DATI(NDP))32,32,31
  7062. 31    SAVE=SAVE*DATI(K)
  7063. 32    SUM=SUM+SAVE
  7064.     IF(ITER)45,33,33
  7065. 33    ITER=ITER-1
  7066.     IF(SUM-OSUM)34,37,35
  7067. 34    OSUM=SUM
  7068.     GOTO 30
  7069. C
  7070. C       TEST FOR IMPROVEMENT
  7071. 35    IF(OSUM-SSOE)36,30,30
  7072. 36    RELAX=RELAX+RELAX
  7073. 37    T=0.
  7074.     SAVE=0.D0
  7075.     K=IRES+1
  7076.     DO 38 I=2,K
  7077.     J=J+1
  7078.     T=T+DABS(P(I))
  7079.     P(I)=P(I)+RELAX*WORK(J)
  7080. 38    SAVE=SAVE+DABS(P(I))
  7081. C
  7082. C       UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR
  7083.     DO 39 I=1,N
  7084.     J=I+N
  7085.     K=J+N
  7086.     L=K+N
  7087.     WORK(J)=WORK(J)+RELAX*WORK(I)
  7088. 39    WORK(K)=WORK(K)+RELAX*WORK(L)
  7089. C
  7090. C       TEST FOR CONVERGENCE
  7091.     IF(INCR)40,40,42
  7092. 40    IF(SSOE-OSUM-RELAX*OSUM*DBLE(EPS))46,46,41
  7093. 41    IF(DABS(T-SAVE)-RELAX*SAVE*DBLE(EPS))46,46,42
  7094. 42    IF(OSUM-SAVE*DBLE(ETA))46,46,43
  7095. 43    KOUNT=KOUNT+1
  7096.     IF(KOUNT-LIMIT)10,44,44
  7097. C
  7098. C       ERROR RETURN IN CASE OF POOR CONVERGENCE
  7099. 44    IER=2
  7100.     RETURN
  7101. 45    IER=1
  7102.     RETURN
  7103. C
  7104. C       NORMAL RETURN
  7105. 46    IER=0
  7106.     RETURN
  7107.     END
  7108. C
  7109. C    ..................................................................
  7110. C
  7111. C       SAMPLE MAIN PROGRAM FOR DATA SCREENING - DASCR
  7112. C
  7113. C       PURPOSE
  7114. C          PERFORM DATA SCREENING CALCULATIONS ON A SET OF OBSERVATIONS
  7115. C
  7116. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7117. C          SUBST
  7118. C          TAB1
  7119. C          LOC
  7120. C          BOOL
  7121. C          HIST
  7122. C          MATIN
  7123. C
  7124. C       METHOD
  7125. C          DERIVE A SUBSET OF OBSERVATIONS SATISFYING CERTAIN
  7126. C          CONDITIONS ON THE VARIABLES. FOR THIS SUBSET, THE FREQUENCY
  7127. C          OF A SELECTED VARIABLE OVER GIVEN CLASS INTERVALS IS
  7128. C          OBTAINED. THIS IS PLOTTED IN THE FORM OF A HISTOGRAM.
  7129. C          TOTAL, AVERAGE, STANDARD DEVIATION, MINIMUM, AND MAXIMUM
  7130. C          ARE ALSO CALCULATED.
  7131. C
  7132. C    ..................................................................
  7133. cC
  7134. c    DIMENSION A(1000),C(63),UBO(3),S(200),R(21),FREQ(20),
  7135. c     1PCT(20),STATS(5)
  7136. c    EXTERNAL BOOL
  7137. c10    FORMAT(1H1,22HDATA SCREENING PROBLEM,I3)
  7138. c11    FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4)
  7139. c12    FORMAT(1H0,20HEXECUTION TERMINATED)
  7140. c13    FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4)
  7141. c14    FORMAT(1H0,18HGO ON TO NEXT CASE)
  7142. c15    FORMAT(1H0,11HEND OF CASE)
  7143. c16    FORMAT(7(F2.0,F1.0,F7.0))
  7144. c17    FORMAT(3F10.0)
  7145. c18    FORMAT(1H0,13HSUBSET VECTOR,///)
  7146. c19    FORMAT(1H ,I3,F5.0)
  7147. c20    FORMAT(1H1,32HSUMMARY STATISTICS FOR VARIABLE ,I3)
  7148. c21    FORMAT(1H0,7HTOTAL =,F10.3,2X,9HAVERAGE =,F10.3,2X,20HSTANDARD DEV
  7149. c     1IATION =,F10.3,2X,9HMINIMUM =,F10.3,2X,9HMAXIMUM =,F10.3)
  7150. c22    FORMAT(2I2)
  7151. cC    DOUBLE PRECISION TMPFIL,FILE
  7152. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  7153. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  7154. cC    FILE = TMPFIL('SSP')
  7155. cC    OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
  7156. cC    1    DISPOSE='DELETE')
  7157. cC
  7158. c    KC=0
  7159. c24    KC=KC+1
  7160. c    CALL MATIN(ICOD,A,1000,NO,NV,MS,IER)
  7161. c    IF(NO) 25,50,25
  7162. c25    IF(IER-1) 40,30,35
  7163. c30    WRITE(6,11) ICOD
  7164. c    WRITE(6,14)
  7165. c    GO TO 24
  7166. c35    WRITE(6,13)
  7167. c    WRITE(6,12)
  7168. c    GO TO 50
  7169. c40    READ(5,22)NC,NOVAR
  7170. c    JC=NC*3
  7171. c    READ(5,16)(C(I),I=1,JC)
  7172. c    READ(5,17)(UBO(I),I=1,3)
  7173. c    CALL SUBST(A,C,R,BOOL,S,NO,NV,NC)
  7174. c    WRITE(6,10)KC
  7175. c    WRITE(6,18)
  7176. c    WRITE(6,19) (I,S(I),I=1,NO)
  7177. c    CALL TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV)
  7178. c    WRITE(6,20) NOVAR
  7179. c    WRITE(6,21)(STATS(I),I=1,5)
  7180. c    JZ=UBO(2)
  7181. c    CALL HIST(KC,FREQ,JZ)
  7182. c    WRITE(6,15)
  7183. c    GO TO 24
  7184. c   50    CONTINUE
  7185. c    END
  7186. C
  7187. C    ..................................................................
  7188. C
  7189. C       SAMPLE INPUT SUBROUTINE - DATA
  7190. C
  7191. C       PURPOSE
  7192. C          READ AN OBSERVATION (M DATA VALUES) FROM INPUT DEVICE.
  7193. C          THIS SUBROUTINE IS CALLED BY THE SUBROUTINE CORRE AND MUST
  7194. C          BE PROVIDED BY THE USER.  IF SIZE AND LOCATION OF DATA
  7195. C          FIELDS ARE DIFFERENT FROM PROBLEM TO PROBLEM, THIS SUB-
  7196. C          ROUTINE MUST BE RECOMPILED WITH A PROPER FORMAT STATEMENT.
  7197. C
  7198. C       USAGE
  7199. C          CALL DATA (M,D)
  7200. C
  7201. C       DESCRIPTION OF PARAMETERS
  7202. C          M - THE NUMBER OF VARIABLES IN AN OBSERVATION.
  7203. C          D - OUTPUT VECTOR OF LENGTH M CONTAINING THE OBSERVATION
  7204. C              DATA.
  7205. C
  7206. C       REMARKS
  7207. C          THE TYPE OF CONVERSION SPECIFIED IN THE FORMAT MUST BE
  7208. C          EITHER F OR E.
  7209. C
  7210. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7211. C          NONE
  7212. C    ..................................................................
  7213. C
  7214.     SUBROUTINE DATA (M,D)
  7215. C
  7216.     DIMENSION D(1)
  7217. C
  7218. 1    FORMAT(12F6.0)
  7219. C
  7220. C    READ AN OBSERVATION FROM INPUT DEVICE.
  7221. C
  7222.     READ (5,1) (D(I),I=1,M)
  7223. C
  7224. C    INPUT DATA ARE WRITTEN ON LOGICAL TAPE 9 FOR THE RESIDUAL ANALY-
  7225. C    SIS PERFORMED IN THE SAMPLE MULTIPLE REGRESSION PROGRAM.
  7226. C
  7227.     WRITE (9) (D(I),I=1,M)
  7228.     RETURN
  7229.     END
  7230. C
  7231. C    ..................................................................
  7232. C
  7233. C       SUBROUTINE DATSE
  7234. C
  7235. C       PURPOSE
  7236. C          NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE
  7237. C          SELECTED AND ORDERED SUCH THAT
  7238. C          ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  7239. C
  7240. C       USAGE
  7241. C          CALL DATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
  7242. C
  7243. C       DESCRIPTION OF PARAMETERS
  7244. C          X      - DOUBLE PRECISION SEARCH ARGUMENT.
  7245. C          ZS     - DOUBLE PRECISION STARTING VALUE OF ARGUMENTS.
  7246. C          DZ     - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
  7247. C          F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
  7248. C                   OF FUNCTION VALUES (DIMENSION IROW).
  7249. C                   IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
  7250. C                   MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
  7251. C                   TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
  7252. C          IROW   - THE DIMENSION OF EACH COLUMN IN MATRIX F.
  7253. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  7254. C          ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
  7255. C                   ORDERED ARGUMENT VALUES (DIMENSION NDIM).
  7256. C          VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
  7257. C                   FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
  7258. C                   IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
  7259. C                   OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
  7260. C                   2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
  7261. C                   TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
  7262. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  7263. C                   THE GIVEN TABLE.
  7264. C
  7265. C       REMARKS
  7266. C          NO ACTION IN CASE IROW LESS THAN 1.
  7267. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  7268. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  7269. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  7270. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  7271. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  7272. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  7273. C          SUBROUTINE DATSE.
  7274. C          SUBROUTINE DATSE ESPECIALLY CAN BE USED FOR GENERATING THE
  7275. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
  7276. C
  7277. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7278. C          NONE
  7279. C
  7280. C       METHOD
  7281. C          SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT
  7282. C          ARGUMENT, WHICH IS NEXT TO X.
  7283. C          AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
  7284. C          SELECTED IN THE ABOVE SENSE.
  7285. C
  7286. C    ..................................................................
  7287. C
  7288.     SUBROUTINE DATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
  7289. C
  7290. C
  7291.     DIMENSION F(1),ARG(1),VAL(1)
  7292.     DOUBLE PRECISION X,ZS,DZ,F,ARG,VAL
  7293.     IF(IROW-1)19,17,1
  7294. C
  7295. C    CASE DZ=0 IS CHECKED OUT
  7296. 1    IF(DZ)2,17,2
  7297. 2    N=NDIM
  7298. C
  7299. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  7300.     IF(N-IROW)4,4,3
  7301. 3    N=IROW
  7302. C
  7303. C    COMPUTATION OF STARTING SUBSCRIPT J.
  7304. 4    J=(X-ZS)/DZ+1.5D0
  7305.     IF(J)5,5,6
  7306. 5    J=1
  7307. 6    IF(J-IROW)8,8,7
  7308. 7    J=IROW
  7309. C
  7310. C    GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0.
  7311. 8    II=J
  7312.     JL=0
  7313.     JR=0
  7314.     DO 16 I=1,N
  7315.     ARG(I)=ZS+DFLOAT(II-1)*DZ
  7316.     IF(ICOL-2)9,10,10
  7317. 9    VAL(I)=F(II)
  7318.     GOTO 11
  7319. 10    VAL(2*I-1)=F(II)
  7320.     III=II+IROW
  7321.     VAL(2*I)=F(III)
  7322. 11    IF(J+JR-IROW)12,15,12
  7323. 12    IF(J-JL-1)13,14,13
  7324. 13    IF((ARG(I)-X)*DZ)14,15,15
  7325. 14    JR=JR+1
  7326.     II=J+JR
  7327.     GOTO 16
  7328. 15    JL=JL+1
  7329.     II=J-JL
  7330. 16    CONTINUE
  7331.     RETURN
  7332. C
  7333. C    CASE DZ=0
  7334. 17    ARG(1)=ZS
  7335.     VAL(1)=F(1)
  7336.     IF(ICOL-2)19,19,18
  7337. 18    VAL(2)=F(2)
  7338. 19    RETURN
  7339.     END
  7340. C
  7341. C    ..................................................................
  7342. C
  7343. C       SUBROUTINE DATSG
  7344. C
  7345. C       PURPOSE
  7346. C          NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND
  7347. C          ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  7348. C
  7349. C       USAGE
  7350. C          CALL DATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
  7351. C
  7352. C       DESCRIPTION OF PARAMETERS
  7353. C          X      - DOUBLE PRECISION SEARCH ARGUMENT.
  7354. C          Z      - DOUBLE PRECISION VECTOR OD ARGUMENT VALUES
  7355. C                   (DIMENSION IROW).
  7356. C          F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
  7357. C                   OF FUNCTION VALUES (DIMENSION IROW).
  7358. C                   IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
  7359. C                   MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
  7360. C                   TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
  7361. C          WORK   - DOUBLE PRECISION WORKING STORAGE (DIMENSION IROW).
  7362. C          IROW   - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH
  7363. C                   COLUMN IN MATRIX F.
  7364. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  7365. C          ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
  7366. C                   ORDERED ARGUMENT VALUES (DIMENSION NDIM).
  7367. C          VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
  7368. C                   FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
  7369. C                   IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
  7370. C                   OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
  7371. C                   2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
  7372. C                   TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
  7373. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  7374. C                   THE GIVEN TABLE (Z,F).
  7375. C
  7376. C       REMARKS
  7377. C          NO ACTION IN CASE IROW LESS THAN 1.
  7378. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  7379. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  7380. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  7381. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  7382. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  7383. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  7384. C          SUBROUTINE DATSG.
  7385. C          SUBROUTINE DATSG ESPECIALLY CAN BE USED FOR GENERATING THE
  7386. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
  7387. C
  7388. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7389. C          NONE
  7390. C
  7391. C       METHOD
  7392. C          SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH
  7393. C          COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS
  7394. C          (OR IROW STEPS IF NDIM IS GREATER THAN IROW)
  7395. C          SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH
  7396. C          IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN
  7397. C          MAX(WORK(I)).
  7398. C
  7399. C    ..................................................................
  7400. C
  7401.     SUBROUTINE DATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
  7402. C
  7403. C
  7404.     DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1)
  7405.     DOUBLE PRECISION X,Z,F,WORK,ARG,VAL,B,DELTA
  7406.     IF(IROW)11,11,1
  7407. 1    N=NDIM
  7408. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  7409.     IF(N-IROW)3,3,2
  7410. 2    N=IROW
  7411. C
  7412. C    GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT.
  7413. 3    B=0.D0
  7414.     DO 5 I=1,IROW
  7415.     DELTA=DABS(Z(I)-X)
  7416.     IF(DELTA-B)5,5,4
  7417. 4    B=DELTA
  7418. 5    WORK(I)=DELTA
  7419. C
  7420. C    GENERATION OF TABLE (ARG,VAL)
  7421.     B=B+1.D0
  7422.     DO 10 J=1,N
  7423.     DELTA=B
  7424.     DO 7 I=1,IROW
  7425.     IF(WORK(I)-DELTA)6,7,7
  7426. 6    II=I
  7427.     DELTA=WORK(I)
  7428. 7    CONTINUE
  7429.     ARG(J)=Z(II)
  7430.     IF(ICOL-1)8,9,8
  7431. 8    VAL(2*J-1)=F(II)
  7432.     III=II+IROW
  7433.     VAL(2*J)=F(III)
  7434.     GOTO 10
  7435. 9    VAL(J)=F(II)
  7436. 10    WORK(II)=B
  7437. 11    RETURN
  7438.     END
  7439. C
  7440. C    ..................................................................
  7441. C
  7442. C       SUBROUTINE DATSM
  7443. C
  7444. C       PURPOSE
  7445. C          NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE
  7446. C          SELECTED AND ORDERED SUCH THAT
  7447. C          ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
  7448. C
  7449. C       USAGE
  7450. C          CALL DATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  7451. C
  7452. C       DESCRIPTION OF PARAMETERS
  7453. C          X      - DOUBLE PRECISION SEARCH ARGUMENT.
  7454. C          Z      - DOUBLE PRECISION VECTOR OF ARGUMENT VALUES (DIMEN-
  7455. C                   SION IROW). THE ARGUMENT VALUES MUST BE STORED IN
  7456. C                   INCREASING OR DECREASING SEQUENCE.
  7457. C          F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
  7458. C                   OF FUNCTION VALUES (DIMENSION IROW).
  7459. C                   IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
  7460. C                   MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
  7461. C                  TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
  7462. C          IROW   - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN
  7463. C                   IN MATRIX F.
  7464. C          ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
  7465. C          ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
  7466. C                   ORDERED ARGUMENT VALUES (DIMENSION NDIM).
  7467. C          VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
  7468. C                   FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
  7469. C                   IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
  7470. C                   OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
  7471. C                   2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
  7472. C                   TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
  7473. C          NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
  7474. C                   THE GIVEN TABLE (Z,F).
  7475. C
  7476. C       REMARKS
  7477. C          NO ACTION IN CASE IROW LESS THAN 1.
  7478. C          IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
  7479. C          SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
  7480. C          USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
  7481. C          AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
  7482. C          TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
  7483. C          THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
  7484. C          SUBROUTINE DATSM.
  7485. C          SUBROUTINE DATSM ESPECIALLY CAN BE USED FOR GENERATING THE
  7486. C          TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
  7487. C
  7488. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7489. C          NONE
  7490. C
  7491. C       METHOD
  7492. C          SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT
  7493. C          ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH).
  7494. C          AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
  7495. C          SELECTED IN THE ABOVE SENSE.
  7496. C
  7497. C    ..................................................................
  7498. C
  7499.     SUBROUTINE DATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
  7500. C
  7501. C
  7502.     DIMENSION Z(1),F(1),ARG(1),VAL(1)
  7503.     DOUBLE PRECISION X,Z,F,ARG,VAL
  7504. C
  7505. C    CASE IROW=1 IS CHECKED OUT
  7506.     IF(IROW-1)23,21,1
  7507. 1    N=NDIM
  7508. C
  7509. C    IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
  7510.     IF(N-IROW)3,3,2
  7511. 2    N=IROW
  7512. C
  7513. C    CASE IROW.GE.2
  7514. C    SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X.
  7515. 3    IF(Z(IROW)-Z(1))5,4,4
  7516. 4    J=IROW
  7517.     I=1
  7518.     GOTO 6
  7519. 5    I=IROW
  7520.     J=1
  7521. 6    K=(J+I)/2
  7522.     IF(X-Z(K))7,7,8
  7523. 7    J=K
  7524.     GOTO 9
  7525. 8    I=K
  7526. 9    IF(IABS(J-I)-1)10,10,6
  7527. 10    IF(DABS(Z(J)-X)-DABS(Z(I)-X))12,12,11
  7528. 11    J=I
  7529. C
  7530. C    TABLE SELECTION
  7531. 12    K=J
  7532.     JL=0
  7533.     JR=0
  7534.     DO 20 I=1,N
  7535.     ARG(I)=Z(K)
  7536.     IF(ICOL-1)14,14,13
  7537. 13    VAL(2*I-1)=F(K)
  7538.     KK=K+IROW
  7539.     VAL(2*I)=F(KK)
  7540.     GOTO 15
  7541. 14    VAL(I)=F(K)
  7542. 15    JJR=J+JR
  7543.     IF(JJR-IROW)16,18,18
  7544. 16    JJL=J-JL
  7545.     IF(JJL-1)19,19,17
  7546. 17    IF(DABS(Z(JJR+1)-X)-DABS(Z(JJL-1)-X))19,19,18
  7547. 18    JL=JL+1
  7548.     K=J-JL
  7549.     GOTO 20
  7550. 19    JR=JR+1
  7551.     K=J+JR
  7552. 20    CONTINUE
  7553.     RETURN
  7554. C
  7555. C    CASE IROW=1
  7556. 21    ARG(1)=Z(1)
  7557.     VAL(1)=F(1)
  7558.     IF(ICOL-2)23,22,23
  7559. 22    VAL(2)=F(2)
  7560. 23    RETURN
  7561.     END
  7562. C
  7563. C    ..................................................................
  7564. C
  7565. C    SUBROUTINE DBAR
  7566. C
  7567. C    PURPOSE
  7568. C       TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
  7569. C       DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
  7570. C       TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL -
  7571. C       THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING
  7572. C       FUNCTION VALUES ONLY ON THAT INTERVAL.
  7573. C
  7574. C     USAGE
  7575. C       CALL DBAR(X,H,IH,FCT,Z)
  7576. C       PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  7577. C
  7578. C    DESCRIPTION OF PARAMETERS
  7579. C       X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
  7580. C       H   - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END-
  7581. C             POINTS ARE X AND X+H (SEE PURPOSE)
  7582. C       IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
  7583. C             IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
  7584. C                           VALUE HH
  7585. C             IH    =   0 - THE INTERNAL VALUE HH IS SET TO H
  7586. C       FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL
  7587. C             GENERATE THE NECESSARY FUNCTION VALUES
  7588. C       Z   - RESULTING DERIVATIVE VALUE
  7589. C
  7590. C    REMARKS
  7591. C       (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
  7592. C       (2)  THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER-
  7593. C            MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN
  7594. C            THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE
  7595. C            METHOD.)  IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES
  7596. C            HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN-
  7597. C            CATION ERROR.  HH ALWAYS HAS THE SAME SIGN AS H AND IT IS
  7598. C            ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB-
  7599. C            SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED
  7600. C            INTERVAL DETERMINED BY H.
  7601. C
  7602. C    SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7603. C       THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
  7604. C       THE USER.
  7605. C
  7606. C    METHOD
  7607. C       THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
  7608. C       EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED
  7609. C       DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
  7610. C       (X,X+(K*HH)/10)K=1,...,10.  (SEE FILLIPI, S. AND ENGELS, H.,
  7611. C       ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE
  7612. C       DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
  7613. C
  7614. C    ..................................................................
  7615. C
  7616.     SUBROUTINE DBAR(X,H,IH,FCT,Z)
  7617. C
  7618. C
  7619.     DIMENSION AUX(10)
  7620. C
  7621. C       NO ACTION IN CASE OF ZERO INTERVAL LENGTH
  7622.     IF(H)1,17,1
  7623. C
  7624. C       GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
  7625. 1    C=ABS(H)
  7626.     B=H
  7627.     D=X
  7628.     D=FCT(D)
  7629.     IF(IH)2,9,2
  7630. 2    HH=.5
  7631.     IF(C-HH)3,4,4
  7632. 3    HH=B
  7633. 4    HH=SIGN(HH,B)
  7634.     Z=ABS((FCT(X+HH)-D)/HH)
  7635.     A=ABS(D)
  7636.     HH=1.
  7637.     IF(A-1.)6,6,5
  7638. 5    HH=HH*A
  7639. 6    IF(Z-1.)8,8,7
  7640. 7    HH=HH/Z
  7641. 8    IF(HH-C)10,10,9
  7642. 9    HH=B
  7643. 10    HH=SIGN(HH,B)
  7644. C
  7645. C       INITIALIZE DIFFERENTIATION LOOP
  7646.     Z=(FCT(X+HH)-D)/HH
  7647.     J=10
  7648.     JJ=J-1
  7649.     AUX(J)=Z
  7650.     DH=HH/FLOAT(J)
  7651.     DZ=1.7E38                                                                 0
  7652. C
  7653. C       START DIFFERENTIATION LOOP
  7654. 11    J=J-1
  7655.     C=J
  7656.     HH=C*DH
  7657.     AUX(J)=(FCT(X+HH)-D)/HH
  7658. C
  7659. C       INITIALIZE EXTRAPOLATION LOOP
  7660.     D2=1.7E38                                                                 0
  7661.     B=0.
  7662.     A=1./C
  7663. C
  7664. C       START EXTRAPOLATION LOOP
  7665.     DO 12 I=J,JJ
  7666.     D1=D2
  7667.     B=B+A
  7668.     HH=(AUX(I)-AUX(I+1))/B
  7669.     AUX(I+1)=AUX(I)+HH
  7670. C
  7671. C       TEST ON OSCILLATING INCREMENTS
  7672.     D2=ABS(HH)
  7673.     IF(D2-D1)12,13,13
  7674. 12    CONTINUE
  7675. C       END OF EXTRAPOLATION LOOP
  7676. C
  7677. C       UPDATE RESULT VALUE Z
  7678.     I=JJ+1
  7679.     GO TO 14
  7680. 13    D2=D1
  7681.     JJ=I
  7682. 14    IF(D2-DZ)15,16,16
  7683. 15    DZ=D2
  7684.     Z=AUX(I)
  7685. 16    IF(J-1)17,17,11
  7686. C       END OF DIFFERENTIATION LOOP
  7687. C
  7688. 17    RETURN
  7689.     END
  7690. C
  7691. C    ..................................................................
  7692. C
  7693. C       SUBROUTINE DCAR
  7694. C
  7695. C    PURPOSE
  7696. C       TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
  7697. C       DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
  7698. C       TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED
  7699. C       SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION
  7700. C       VALUES ONLY ON THAT CLOSED INTERVAL.
  7701. C
  7702. C    USAGE
  7703. C          CALL DCAR (X,H,IH,FCT,Z)
  7704. C       PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  7705. C
  7706. C    DESCRIPTION OF PARAMETERS
  7707. C       X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
  7708. C       H   - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED,
  7709. C             SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE)
  7710. C       IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
  7711. C             IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
  7712. C                           VALUE HH
  7713. C             IH    =   0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H
  7714. C       FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL
  7715. C             GENERATE THE NECESSARY FUNCTION VALUES
  7716. C       Z   - RESULTING DERIVATIVE VALUE
  7717. C
  7718. C    REMARKS
  7719. C       (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
  7720. C       (2)  THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO
  7721. C            IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF
  7722. C            THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.)  IF IH IS
  7723. C            NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO
  7724. C            CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR.  HH
  7725. C            IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE
  7726. C            VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS
  7727. C            ABSOLUTE H OF X.
  7728. C
  7729. C    SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7730. C       THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
  7731. C       THE USER.
  7732. C
  7733. C    METHOD
  7734. C       THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
  7735. C       EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL
  7736. C       DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
  7737. C       (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5.  (SEE FILLIPI, S. AND
  7738. C       ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION,
  7739. C       ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
  7740. C
  7741. C    ..................................................................
  7742. C
  7743.     SUBROUTINE DCAR(X,H,IH,FCT,Z)
  7744. C
  7745. C
  7746.     DIMENSION AUX(5)
  7747. C
  7748. C       NO ACTION IN CASE OF ZERO INTERVAL LENGTH
  7749.     IF(H)1,17,1
  7750. C
  7751. C       GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
  7752. 1    C=ABS(H)
  7753.     IF(IH)2,9,2
  7754. 2    HH=.5
  7755.     IF(C-HH)3,4,4
  7756. 3    HH=C
  7757. 4    A=FCT(X+HH)
  7758.     B=FCT(X-HH)
  7759.     Z=ABS((A-B)/(HH+HH))
  7760.     A=.5*ABS(A+B)
  7761.     HH=.5
  7762.     IF(A-1.)6,6,5
  7763. 5    HH=HH*A
  7764. 6    IF(Z-1.)8,8,7
  7765. 7    HH=HH/Z
  7766. 8    IF(HH-C)10,10,9
  7767. 9    HH=C
  7768. C
  7769. C       INITIALIZE DIFFERENTIATION LOOP
  7770. 10    Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
  7771.     J=5
  7772.     JJ=J-1
  7773.     AUX(J)=Z
  7774.     DH=HH/FLOAT(J)
  7775.     DZ=1.7E38                                                                 0
  7776. C
  7777. C       START DIFFERENTIATION LOOP
  7778. 11    J=J-1
  7779.     C=J
  7780.     HH=C*DH
  7781.     AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
  7782. C
  7783. C       INITIALIZE EXTRAPOLATION LOOP
  7784.     D2=1.7E38                                                                 0
  7785.     B=0.
  7786.     A=1./C
  7787. C
  7788. C       START EXTRAPOLATION LOOP
  7789.     DO 12 I=J,JJ
  7790.     D1=D2
  7791.     B=B+A
  7792.     HH=(AUX(I)-AUX(I+1))/(B*(2.+B))
  7793.     AUX(I+1)=AUX(I)+HH
  7794. C
  7795. C       TEST ON OSCILLATING INCREMENTS
  7796.     D2=ABS(HH)
  7797.     IF(D2-D1)12,13,13
  7798. 12    CONTINUE
  7799. C       END OF EXTRAPOLATION LOOP
  7800. C
  7801. C       UPDATE RESULT VALUE Z
  7802.     I=JJ+1
  7803.     GO TO 14
  7804. 13    D2=D1
  7805.     JJ=I
  7806. 14    IF(D2-DZ)15,16,16
  7807. 15    DZ=D2
  7808.     Z=AUX(I)
  7809. 16    IF(J-1)17,17,11
  7810. C       END OF DIFFERENTIATION LOOP
  7811. C
  7812. 17    RETURN
  7813.     END
  7814. C
  7815. C    ..................................................................
  7816. C
  7817. C       SUBROUTINE DCEL1
  7818. C
  7819. C       PURPOSE
  7820. C          CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND
  7821. C
  7822. C       USAGE
  7823. C          CALL DCEL1(RES,AK,IER)
  7824. C
  7825. C       DESCRIPTION OF PARAMETERS
  7826. C          RES   - RESULT VALUE IN DOUBLE PRECISION
  7827. C          AK    - MODULUS (INPUT) IN DOUBLE PRECISION
  7828. C          IER   - RESULTANT ERROR CODE WHERE
  7829. C                  IER=0  NO ERROR
  7830. C                  IER=1  AK NOT IN RANGE -1 TO +1
  7831. C
  7832. C       REMARKS
  7833. C          THE RESULT IS SET TO 1.E75 IF ABS(AK) GE 1
  7834. C          FOR MODULUS AK AND COMPLEMENTARY MODULUS CK,
  7835. C          EQUATION AK*AK+CK*CK=1.D0 IS USED.
  7836. C          AK MUST BE IN THE RANGE -1 TO +1
  7837. C
  7838. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7839. C          NONE
  7840. C
  7841. C       METHOD
  7842. C          DEFINITION
  7843. C          CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
  7844. C          OVER T FROM 0 TO INFINITY).
  7845. C          EQUIVALENT ARE THE DEFINITIONS
  7846. C          CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED
  7847. C          OVER T FROM 0 TO PI/2),
  7848. C          CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T
  7849. C          FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK).
  7850. C          EVALUATION
  7851. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  7852. C          REFERENCE
  7853. C          R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
  7854. C          AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
  7855. C          NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  7856. C
  7857. C    ..................................................................
  7858. C
  7859.     SUBROUTINE DCEL1(RES,AK,IER)
  7860.     DOUBLE PRECISION RES,AK,GEO,ARI,AARI
  7861.     IER=0
  7862.     ARI=2.D0
  7863.     GEO=(0.5D0-AK)+0.5D0
  7864.     GEO=GEO+GEO*AK
  7865.     RES=0.5D0
  7866.     IF(GEO)1,2,4
  7867. 1    IER=1
  7868. 2    RES=1.7D38                                                                0
  7869.     RETURN
  7870. 3    GEO=GEO*AARI
  7871. 4    GEO=DSQRT(GEO)
  7872.     GEO=GEO+GEO
  7873.     AARI=ARI
  7874.     ARI=ARI+GEO
  7875.     RES=RES+RES
  7876.     IF(GEO/AARI-0.999999995D0)3,5,5
  7877. 5    RES=RES/ARI*6.2831853071795865D0
  7878.     RETURN
  7879.     END
  7880. C
  7881. C    ..................................................................
  7882. C
  7883. C       SUBROUTINE DCEL2
  7884. C
  7885. C       PURPOSE
  7886. C          COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF
  7887. C          SECOND KIND.
  7888. C
  7889. C       USAGE
  7890. C          CALL DCEL2(RES,AK,A,B,IER)
  7891. C
  7892. C       DESCRIPTION OF PARAMETERS
  7893. C          RES   - RESULT VALUE IN DOUBLE PRECISION
  7894. C          AK    - MODULUS (INPUT) IN DOUBLE PRECISION
  7895. C          A     - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR
  7896. C          B     - DOUBLE PRECISION FACTOR OF QUADRATIC TERM
  7897. C                  IN NUMERATOR
  7898. C          IER   - RESULTANT ERROR CODE WHERE
  7899. C                  IER=0  NO ERROR
  7900. C                  IER=1  AK NOT IN RANGE -1 TO +1
  7901. C
  7902. C       REMARKS
  7903. C          FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.E75 IF B IS
  7904. C          POSITIVE, TO -1.7D38 IF B IS NEGATIVE.                              0
  7905. C          SPECIAL CASES ARE
  7906. C          K(K) OBTAINED WITH A = 1, B = 1
  7907. C          E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS
  7908. C          COMPLEMENTARY MODULUS.
  7909. C          B(K) OBTAINED WITH A = 1, B = 0
  7910. C          D(K) OBTAINED WITH A = 0, B = 1
  7911. C          WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED
  7912. C          COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL
  7913. C          NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS
  7914. C          THE MODULUS.
  7915. C
  7916. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7917. C          NONE
  7918. C
  7919. C       METHOD
  7920. C          DEFINITION
  7921. C          RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T))
  7922. C          SUMMED OVER T FROM 0 TO INFINITY).
  7923. C          EVALUATION
  7924. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  7925. C          REFERENCE
  7926. C          R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
  7927. C          AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
  7928. C          NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  7929. C
  7930. C    ..................................................................
  7931. C
  7932.     SUBROUTINE DCEL2(RES,AK,A,B,IER)
  7933.     DOUBLE PRECISION RES,AK,A,B,GEO,ARI,AARI,B0,A1
  7934.     IER=0
  7935.     ARI=2.D0
  7936.     GEO=(0.5D0-AK)+0.5D0
  7937.     GEO=GEO+GEO*AK
  7938.     RES=A
  7939.     A1=A+B
  7940.     B0=B+B
  7941.     IF(GEO)1,2,6
  7942. 1    IER=1
  7943. 2    IF(B)3,8,4
  7944. 3    RES=-1.7D38                                                               0
  7945.     RETURN
  7946. 4    RES=1.7D38                                                                0
  7947.     RETURN
  7948. 5    GEO=GEO*AARI
  7949. 6    GEO=DSQRT(GEO)
  7950.     GEO=GEO+GEO
  7951.     AARI=ARI
  7952.     ARI=ARI+GEO
  7953.     B0=B0+RES*GEO
  7954.     RES=A1
  7955.     B0=B0+B0
  7956.     A1=B0/ARI+A1
  7957.     IF(GEO/AARI-0.999999995D0)5,7,7
  7958. 7    RES=A1/ARI
  7959.     RES=RES+0.57079632679489662D0*RES
  7960. 8    RETURN
  7961.     END
  7962. C
  7963. C    ..................................................................
  7964. C
  7965. C       SUBROUTINE DCLA
  7966. C
  7967. C       PURPOSE
  7968. C          SET EACH DIAGONAL ELEMENT OF A MATRIX EQUAL TO A SCALAR
  7969. C
  7970. C       USAGE
  7971. C          CALL DCLA (A,C,N,MS)
  7972. C
  7973. C       DESCRIPTION OF PARAMETERS
  7974. C          A - NAME OF INPUT MATRIX
  7975. C          C - SCALAR
  7976. C          N - NUMBER OF ROWS AND COLUMNS IN MATRIX A
  7977. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  7978. C                 0 - GENERAL
  7979. C                 1 - SYMMETRIC
  7980. C                 2 - DIAGONAL
  7981. C
  7982. C       REMARKS
  7983. C          INPUT MATRIX MUST BE A SQUARE MATRIX
  7984. C
  7985. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  7986. C          LOC
  7987. C
  7988. C       METHOD
  7989. C          EACH ELEMENT ON DIAGONAL OF MATRIX IS REPLACED BY SCALAR C
  7990. C
  7991. C    ..................................................................
  7992. C
  7993.     SUBROUTINE DCLA(A,C,N,MS)
  7994.     DIMENSION A(1)
  7995. C
  7996.     DO 3 I=1,N
  7997. C
  7998. C       LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE
  7999. C
  8000.     CALL LOC(I,I,ID,N,N,MS)
  8001. C
  8002. C       REPLACE DIAGONAL ELEMENTS
  8003. C
  8004. 3    A(ID)=C
  8005.     RETURN
  8006.     END
  8007. C
  8008. C    ..................................................................
  8009. C
  8010. C       SUBROUTINE DCNP
  8011. C
  8012. C       PURPOSE
  8013. C          COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X)
  8014. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  8015. C
  8016. C       USAGE
  8017. C          CALL DCNP,Y,X,N)
  8018. C
  8019. C       DESCRIPTION OF PARAMETERS
  8020. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  8021. C                  OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
  8022. C                  FOR GIVEN ARGUMENT X.
  8023. C                  DOUBLE PRECISION VECTOR.
  8024. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  8025. C          Y     - RESULT VALUE
  8026. C                  DOUBLE PRECISION VARIABLE.
  8027. C          X     - ARGUMENT OF CHEBYSHEV POLYNOMIAL
  8028. C          N     - ORDER OF CHEBYSHEV POLYNOMIAL
  8029. C
  8030. C       REMARKS
  8031. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  8032. C
  8033. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8034. C          NONE
  8035. C
  8036. C       METHOD
  8037. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  8038. C          CHEBYSHEV POLYNOMIALS T(N,X)
  8039. C          T(N+1,X)=2*X*T(N,X)-T(N-1,X),
  8040. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  8041. C          THE SECOND IS THE ARGUMENT.
  8042. C          STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
  8043. C
  8044. C    ..................................................................
  8045. C
  8046.     SUBROUTINE DCNP(Y,X,N)
  8047. C
  8048.     DIMENSION Y(1)
  8049.     DOUBLE PRECISION Y,X,F
  8050. C
  8051.     Y(1)=1.D0
  8052.     IF(N)1,1,2
  8053. 1    RETURN
  8054. C
  8055. 2    Y(2)=X
  8056.     IF(N-1)1,1,3
  8057. C
  8058. C       INITIALIZATION
  8059. 3    F=X+X
  8060. C
  8061.     DO 4 I=2,N
  8062. 4    Y(I+1)=F*Y(I)-Y(I-1)
  8063.     RETURN
  8064.     END
  8065. C
  8066. C    ..................................................................
  8067. C
  8068. C       SUBROUTINE DCNPS
  8069. C
  8070. C       PURPOSE
  8071. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV
  8072. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  8073. C
  8074. C       USAGE
  8075. C          CALL DCNPS(Y,X,C,N)
  8076. C
  8077. C       DESCRIPTION OF PARAMETERS
  8078. C          Y     - RESULT VALUE
  8079. C                  DOUBLE PRECISION VARIABLE
  8080. C          X     - ARGUMENT VALUE
  8081. C                  DOUBLE PRECISION VARIABLE
  8082. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  8083. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  8084. C                  DOUBLE PRECISION VECTOR
  8085. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  8086. C
  8087. C       REMARKS
  8088. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  8089. C
  8090. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8091. C          NONE
  8092. C
  8093. C       METHOD
  8094. C          DEFINITION
  8095. C          Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
  8096. C          EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
  8097. C          USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS
  8098. C          T(N+1,X)=2*X*T(N,X)-T(N-1,X).
  8099. C
  8100. C    ..................................................................
  8101. C
  8102.     SUBROUTINE DCNPS(Y,X,C,N)
  8103. C
  8104.     DIMENSION C(1)
  8105.     DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG
  8106. C
  8107. C       TEST OF DIMENSION
  8108.     IF(N)1,1,2
  8109. 1    RETURN
  8110. C
  8111. 2    IF(N-2)3,4,4
  8112. 3    Y=C(1)
  8113.     RETURN
  8114. C
  8115. C       INITIALIZATION
  8116. 4    ARG=X+X
  8117.     H1=0.D0
  8118.     H0=0.D0
  8119. C
  8120.     DO 5 I=1,N
  8121.     K=N-I
  8122.     H2=H1
  8123.     H1=H0
  8124. 5    H0=ARG*H1-H2+C(K+1)
  8125.     Y=0.5D0*(C(1)-H2+H0)
  8126.     RETURN
  8127.     END
  8128. C
  8129. C    ..................................................................
  8130. C
  8131. C       SUBROUTINE DCPY
  8132. C
  8133. C       PURPOSE
  8134. C          COPY DIAGONAL ELEMENTS OF A MATRIX INTO A VECTOR
  8135. C
  8136. C       USAGE
  8137. C          CALL DCPY (A,R,N,MS)
  8138. C
  8139. C       DESCRIPTION OF PARAMETERS
  8140. C          A - NAME OF INPUT MATRIX
  8141. C          R - NAME OF OUTPUT VECTOR OF LENGTH N
  8142. C          N - NUMBER OF ROWS AND COLUMNS IN MATRIX A
  8143. C          MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
  8144. C                 0 - GENERAL
  8145. C                 1 - SYMMETRIC
  8146. C                 2 - DIAGONAL
  8147. C
  8148. C       REMARKS
  8149. C          INPUT MATRIX MUST BE A SQUARE MATRIX
  8150. C
  8151. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8152. C          LOC
  8153. C
  8154. C       METHOD
  8155. C          ELEMENTS ON DIAGONAL OF MATRIX ARE MOVED TO CORRESPONDING
  8156. C          POSITIONS OF VECTOR R
  8157. C
  8158. C    ..................................................................
  8159. C
  8160.     SUBROUTINE DCPY(A,R,N,MS)
  8161.     DIMENSION A(1),R(1)
  8162. C
  8163.     DO 3 J=1,N
  8164. C
  8165. C       LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE
  8166. C
  8167.     CALL LOC(J,J,IJ,N,N,MS)
  8168. C
  8169. C       MOVE DIAGONAL ELEMENT TO VECTOR R
  8170. C
  8171. 3    R(J)=A(IJ)
  8172.     RETURN
  8173.     END
  8174. C
  8175. C    ..................................................................
  8176. C
  8177. C       SUBROUTINE DCSP
  8178. C
  8179. C       PURPOSE
  8180. C          COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS
  8181. C          TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N.
  8182. C
  8183. C       USAGE
  8184. C          CALL DCSP(Y,X,N)
  8185. C
  8186. C       DESCRIPTION OF PARAMETERS
  8187. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  8188. C                  OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
  8189. C                  FOR GIVEN ARGUMENT X.
  8190. C                  DOUBLE PRECISION VECTOR.
  8191. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  8192. C          X     - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL
  8193. C                  DOUBLE PRECISION VARIABLE.
  8194. C          N     - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL
  8195. C
  8196. C       REMARKS
  8197. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  8198. C
  8199. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8200. C          NONE
  8201. C
  8202. C       METHOD
  8203. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  8204. C          SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
  8205. C          TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
  8206. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  8207. C          THE SECOND IS THE ARGUMENT.
  8208. C          STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
  8209. C
  8210. C    ..................................................................
  8211. C
  8212.     SUBROUTINE DCSP(Y,X,N)
  8213. C
  8214.     DIMENSION Y(1)
  8215.     DOUBLE PRECISION Y,X,F
  8216. C
  8217. C       TEST OF ORDER
  8218.     Y(1)=1.D0
  8219.     IF(N)1,1,2
  8220. 1    RETURN
  8221. C
  8222. 2    Y(2)=X+X-1.D0
  8223.     IF(N-1)1,1,3
  8224. C
  8225. C       INITIALIZATION
  8226. 3    F=Y(2)+Y(2)
  8227. C
  8228.     DO 4 I=2,N
  8229. 4    Y(I+1)=F*Y(I)-Y(I-1)
  8230.     RETURN
  8231.     END
  8232. C
  8233. C    ..................................................................
  8234. C
  8235. C       SUBROUTINE DCSPS
  8236. C
  8237. C       PURPOSE
  8238. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED
  8239. C          CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C
  8240. C          FOR ARGUMENT VALUE X.
  8241. C
  8242. C       USAGE
  8243. C          CALL DCSPS(Y,X,C,N)
  8244. C
  8245. C       DESCRIPTION OF PARAMETERS
  8246. C          Y     - RESULT VALUE
  8247. C                  DOUBLE PRECISION VARIABLE
  8248. C          X     - ARGUMENT VALUE
  8249. C                  DOUBLE PRECISION VARIABLE
  8250. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  8251. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  8252. C                  DOUBLE PRECISION VECTOR
  8253. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  8254. C
  8255. C       REMARKS
  8256. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  8257. C
  8258. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8259. C          NONE
  8260. C
  8261. C       METHOD
  8262. C          DEFINITION
  8263. C          Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
  8264. C          EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
  8265. C          USING THE RECURRENCE EQUATION FOR SHIFTED
  8266. C          CHEBYSHEV POLYNOMIALS
  8267. C          TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X).
  8268. C
  8269. C    ..................................................................
  8270. C
  8271.     SUBROUTINE DCSPS(Y,X,C,N)
  8272. C
  8273.     DIMENSION C(1)
  8274.     DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG
  8275. C
  8276. C       TEST OF DIMENSION
  8277.     IF(N)1,1,2
  8278. 1    RETURN
  8279. C
  8280. 2    IF(N-2)3,4,4
  8281. 3    Y=C(1)
  8282.     RETURN
  8283. C
  8284. C       INITIALIZATION
  8285. 4    ARG=X+X-1.D0
  8286.     ARG=ARG+ARG
  8287.     H1=0.D0
  8288.     H0=0.D0
  8289.     DO 5 I=1,N
  8290.     K=N-I
  8291.     H2=H1
  8292.     H1=H0
  8293. 5    H0=ARG*H1-H2+C(K+1)
  8294.     Y=0.5D0*(C(1)-H2+H0)
  8295.     RETURN
  8296.     END
  8297. C
  8298. C    ..................................................................
  8299. C
  8300. C    SUBROUTINE DDBAR
  8301. C
  8302. C    PURPOSE
  8303. C       TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
  8304. C       DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
  8305. C       TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL -
  8306. C       THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING
  8307. C       FUNCTION VALUES ONLY ON THAT INTERVAL.
  8308. C
  8309. C     USAGE
  8310. C       CALL DDBAR(X,H,IH,FCT,Z,)
  8311. C       PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  8312. C
  8313. C    DESCRIPTION OF PARAMETERS
  8314. C       X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
  8315. C             X IS IN DOUBLE PRECISION
  8316. C       H   - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END-
  8317. C             POINTS ARE X AND X+H (SEE PURPOSE)
  8318. C             H IS IN SINGLE PRECISION
  8319. C       IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
  8320. C             IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
  8321. C                           VALUE HH
  8322. C             IH    =   0 - THE INTERNAL VALUE HH IS SET TO H
  8323. C       FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
  8324. C             SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION
  8325. C             VALUES.
  8326. C       Z   - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION
  8327. C
  8328. C    REMARKS
  8329. C       (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
  8330. C       (2)  THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER-
  8331. C            MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN
  8332. C            THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE
  8333. C            METHOD.)  IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES
  8334. C            HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN-
  8335. C            CATION ERROR.  HH ALWAYS HAS THE SAME SIGN AS H AND IT IS
  8336. C            ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB-
  8337. C            SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED
  8338. C            INTERVAL DETERMINED BY H.
  8339. C
  8340. C    SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8341. C       THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
  8342. C       THE USER. FCT(T) IS IN DOUBLE PRECISION
  8343. C
  8344. C    METHOD
  8345. C       THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
  8346. C       EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED
  8347. C       DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
  8348. C       (X,X+(K*HH)/10)K=1,...,10.  (SEE FILLIPI, S. AND ENGELS, H.,
  8349. C       ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE
  8350. C       DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
  8351. C
  8352. C    ..................................................................
  8353. C
  8354.     SUBROUTINE DDBAR(X,H,IH,FCT,Z)
  8355. C
  8356. C
  8357.     DIMENSION AUX(10)
  8358.     DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,D,DH,HH
  8359. C
  8360. C       NO ACTION IN CASE OF ZERO INTERVAL LENGTH
  8361.     IF(H)1,17,1
  8362. C
  8363. C       GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
  8364. 1    C=ABS(H)
  8365.     B=H
  8366.     D=X
  8367.     D=FCT(D)
  8368.     IF(IH)2,9,2
  8369. 2    HH=.5D-2
  8370.     IF(C-HH)3,4,4
  8371. 3    HH=B
  8372. 4    HH=DSIGN(HH,B)
  8373.     Z=DABS((FCT(X+HH)-D)/HH)
  8374.     A=DABS(D)
  8375.     HH=1.D-2
  8376.     IF(A-1.D0)6,6,5
  8377. 5    HH=HH*A
  8378. 6    IF(Z-1.D0)8,8,7
  8379. 7    HH=HH/Z
  8380. 8    IF(HH-C)10,10,9
  8381. 9    HH=B
  8382. 10    HH=DSIGN(HH,B)
  8383. C
  8384. C       INITIALIZE DIFFERENTIATION LOOP
  8385.     Z=(FCT(X+HH)-D)/HH
  8386.     J=10
  8387.     JJ=J-1
  8388.     AUX(J)=Z
  8389.     DH=HH/DFLOAT(J)
  8390.     DZ=1.7E38                                                                 0
  8391. C
  8392. C       START DIFFERENTIATION LOOP
  8393. 11    J=J-1
  8394.     C=J
  8395.     HH=C*DH
  8396.     AUX(J)=(FCT(X+HH)-D)/HH
  8397. C
  8398. C       INITIALIZE EXTRAPOLATION LOOP
  8399.     D2=1.7E38                                                                 0
  8400.     B=0.D0
  8401.     A=1.D0/C
  8402. C
  8403. C       START EXTRAPOLATION LOOP
  8404.     DO 12 I=J,JJ
  8405.     D1=D2
  8406.     B=B+A
  8407.     HH=(AUX(I)-AUX(I+1))/B
  8408.     AUX(I+1)=AUX(I)+HH
  8409. C
  8410. C       TEST ON OSCILLATING INCREMENTS
  8411.     D2=DABS(HH)
  8412.     IF(D2-D1)12,13,13
  8413. 12    CONTINUE
  8414. C       END OF EXTRAPOLATION LOOP
  8415. C
  8416. C       UPDATE RESULT VALUE Z
  8417.     I=JJ+1
  8418.     GO TO 14
  8419. 13    D2=D1
  8420.     JJ=I
  8421. 14    IF(D2-DZ)15,16,16
  8422. 15    DZ=D2
  8423.     Z=AUX(I)
  8424. 16    IF(J-1)17,17,11
  8425. C       END OF DIFFERENTIATION LOOP
  8426. C
  8427. 17    RETURN
  8428.     END
  8429. C
  8430. C    ..................................................................
  8431. C
  8432. C    SUBROUTINE DDCAR
  8433. C
  8434. C    PURPOSE
  8435. C       TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
  8436. C       DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
  8437. C       TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED
  8438. C       SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION
  8439. C       VALUES ONLY ON THAT CLOSED INTERVAL.
  8440. C
  8441. C    USAGE
  8442. C       CALL DDCAR(X,H,IH,FCT,Z)
  8443. C       PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  8444. C
  8445. C    DESCRIPTION OF PARAMETERS
  8446. C       X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
  8447. C             X IS IN DOUBLE PRECISION.
  8448. C       H   - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED,
  8449. C             SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE)
  8450. C             H IS IN SINGLE PRECISION
  8451. C       IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
  8452. C             IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
  8453. C                           VALUE HH
  8454. C             IH    =   0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H
  8455. C       FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
  8456. C             SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION
  8457. C             VALUES.
  8458. C       Z   - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION
  8459. C
  8460. C    REMARKS
  8461. C       (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
  8462. C       (2)  THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO
  8463. C            IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF
  8464. C            THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.)  IF IH IS
  8465. C            NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO
  8466. C            CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR.  HH
  8467. C            IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE
  8468. C            VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS
  8469. C            ABSOLUTE H OF X.
  8470. C
  8471. C    SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8472. C       THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
  8473. C       THE USER. FCT(T) IS IN DOUBLE PRECISION
  8474. C
  8475. C    METHOD
  8476. C       THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
  8477. C       EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL
  8478. C       DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
  8479. C       (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5.  (SEE FILLIPI, S. AND
  8480. C       ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION,
  8481. C       ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
  8482. C
  8483. C    ..................................................................
  8484. C
  8485.     SUBROUTINE DDCAR(X,H,IH,FCT,Z)
  8486. C
  8487. C
  8488.     DIMENSION AUX(5)
  8489.     DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,DH,HH
  8490. C
  8491. C       NO ACTION IN CASE OF ZERO INTERVAL LENGTH
  8492.     IF(H)1,17,1
  8493. C
  8494. C       GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
  8495. 1    C=ABS(H)
  8496.     IF(IH)2,9,2
  8497. 2    HH=.5D-2
  8498.     IF(C-HH)3,4,4
  8499. 3    HH=C
  8500. 4    A=FCT(X+HH)
  8501.     B=FCT(X-HH)
  8502.     Z=DABS((A-B)/(HH+HH))
  8503.     A=.5D0*DABS(A+B)
  8504.     HH=.5D-2
  8505.     IF(A-1.D0)6,6,5
  8506. 5    HH=HH*A
  8507. 6    IF(Z-1.D0)8,8,7
  8508. 7    HH=HH/Z
  8509. 8    IF(HH-C)10,10,9
  8510. 9    HH=C
  8511. C
  8512. C       INITIALIZE DIFFERENTIATION LOOP
  8513. 10    Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
  8514.     J=5
  8515.     JJ=J-1
  8516.     AUX(J)=Z
  8517.     DH=HH/DFLOAT(J)
  8518.     DZ=1.7E38                                                                 0
  8519. C
  8520. C       START DIFFERENTIATION LOOP
  8521. 11    J=J-1
  8522.     C=J
  8523.     HH=C*DH
  8524.     AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
  8525. C
  8526. C       INITIALIZE EXTRAPOLATION LOOP
  8527.     D2=1.7E38                                                                 0
  8528.     B=0.D0
  8529.     A=1.D0/C
  8530. C
  8531. C       START EXTRAPOLATION LOOP
  8532.     DO 12 I=J,JJ
  8533.     D1=D2
  8534.     B=B+A
  8535.     HH=(AUX(I)-AUX(I+1))/(B*(2.D0+B))
  8536.     AUX(I+1)=AUX(I)+HH
  8537. C
  8538. C       TEST ON OSCILLATING INCREMENTS
  8539.     D2=DABS(HH)
  8540.     IF(D2-D1)12,13,13
  8541. 12    CONTINUE
  8542. C       END OF EXTRAPOLATION LOOP
  8543. C
  8544. C       UPDATE RESULT VALUE Z
  8545.     I=JJ+1
  8546.     GO TO 14
  8547. 13    D2=D1
  8548.     JJ=I
  8549. 14    IF(D2-DZ)15,16,16
  8550. 15    DZ=D2
  8551.     Z=AUX(I)
  8552. 16    IF(J-1)17,17,11
  8553. C       END OF DIFFERENTIATION LOOP
  8554. C
  8555. 17    RETURN
  8556.     END
  8557. C
  8558. C    ..................................................................
  8559. C
  8560. C       SUBROUTINE DDET3
  8561. C
  8562. C       PURPOSE
  8563. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
  8564. C          FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
  8565. C          SPACED ARGUMENT VALUES.
  8566. C
  8567. C       USAGE
  8568. C          CALL DDET3(H,Y,Z,NDIM,IER)
  8569. C
  8570. C       DESCRIPTION OF PARAMETERS
  8571. C          H     -  DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN
  8572. C                   SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE
  8573. C                   ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE)
  8574. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  8575. C                   (DIMENSION NDIM)
  8576. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
  8577. C                   VALUES (DIMENSION NDIM)
  8578. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  8579. C          IER   -  RESULTING ERROR PARAMETER
  8580. C                   IER = -1  - NDIM IS LESS THAN 3
  8581. C                   IER =  0  - NO ERROR
  8582. C                   IER =  1  - H = 0
  8583. C
  8584. C       REMARKS
  8585. C          (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
  8586. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS
  8587. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  8588. C
  8589. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8590. C          NONE
  8591. C
  8592. C       METHOD
  8593. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  8594. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
  8595. C          DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  8596. C          POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
  8597. C          (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
  8598. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/
  8599. C          TORONTO/LONDON, 1956, PP.82-84.)
  8600. C
  8601. C    ..................................................................
  8602. C
  8603.     SUBROUTINE DDET3(H,Y,Z,NDIM,IER)
  8604. C
  8605. C
  8606.     DIMENSION Y(1),Z(1)
  8607.     DOUBLE PRECISION H,Y,Z,HH,YY,A,B
  8608. C
  8609. C       TEST OF DIMENSION
  8610.     IF(NDIM-3)4,1,1
  8611. C
  8612. C       TEST OF STEPSIZE
  8613. 1    IF(H)2,5,2
  8614. C
  8615. C       PREPARE DIFFERENTIATION LOOP
  8616. 2    HH=.5D0/H
  8617.     YY=Y(NDIM-2)
  8618.     B=Y(2)+Y(2)
  8619.     B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1))
  8620. C
  8621. C       START DIFFERENTIATION LOOP
  8622.     DO 3 I=3,NDIM
  8623.     A=B
  8624.     B=HH*(Y(I)-Y(I-2))
  8625. 3    Z(I-2)=A
  8626. C       END OF DIFFERENTIATION LOOP
  8627. C
  8628. C       NORMAL EXIT
  8629.     IER=0
  8630.     A=Y(NDIM-1)+Y(NDIM-1)
  8631.     Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY)
  8632.     Z(NDIM-1)=B
  8633.     RETURN
  8634. C
  8635. C       ERROR EXIT IN CASE NDIM IS LESS THAN 3
  8636. 4    IER=-1
  8637.     RETURN
  8638. C
  8639. C       ERROR EXIT IN CASE OF ZERO STEPSIZE
  8640. 5    IER=1
  8641.     RETURN
  8642.     END
  8643. C
  8644. C    ..................................................................
  8645. C
  8646. C       SUBROUTINE DDET5
  8647. C
  8648. C       PURPOSE
  8649. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
  8650. C          FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
  8651. C          SPACED ARGUMENT VALUES.
  8652. C
  8653. C       USAGE
  8654. C          CALL DDET5(H,Y,Z,NDIM,IER)
  8655. C
  8656. C       DESCRIPTION OF PARAMETERS
  8657. C          H     -  DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN
  8658. C                   SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE
  8659. C                   ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE)
  8660. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  8661. C                   (DIMENSION NDIM)
  8662. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
  8663. C                   VALUES (DIMENSION NDIM)
  8664. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  8665. C          IER   -  RESULTING ERROR PARAMETER
  8666. C                   IER = -1  - NDIM IS LESS THAN 5
  8667. C                   IER =  0  - NO ERROR
  8668. C                   IER =  1  - H = 0
  8669. C
  8670. C       REMARKS
  8671. C          (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
  8672. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
  8673. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  8674. C
  8675. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8676. C          NONE
  8677. C
  8678. C       METHOD
  8679. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  8680. C          EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I)
  8681. C          IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  8682. C          POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS
  8683. C          (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE HILDEBRAND, F.B.,
  8684. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  8685. C          TORONTO/LONDON, 1956, PP. 82-84.)
  8686. C
  8687. C    ..................................................................
  8688. C
  8689.     SUBROUTINE DDET5(H,Y,Z,NDIM,IER)
  8690. C
  8691. C
  8692.     DIMENSION Y(1),Z(1)
  8693.     DOUBLE PRECISION H,Y,Z,HH,YY,A,B,C
  8694. C
  8695. C       TEST OF DIMENSION
  8696.     IF(NDIM-5)4,1,1
  8697. C
  8698. C       TEST OF STEPSIZE
  8699. 1    IF(H)2,5,2
  8700. C
  8701. C       PREPARE DIFFERENTIATION LOOP
  8702. 2    HH=.08333333333333333D0/H
  8703.     YY=Y(NDIM-4)
  8704.     B=HH*(-25.D0*Y(1)+48.D0*Y(2)-36.D0*Y(3)+16.D0*Y(4)-3.D0*Y(5))
  8705.     C=HH*(-3.D0*Y(1)-10.D0*Y(2)+18.D0*Y(3)-6.D0*Y(4)+Y(5))
  8706. C
  8707. C       START DIFFERENTIATION LOOP
  8708.     DO 3 I=5,NDIM
  8709.     A=B
  8710.     B=C
  8711.     C=HH*(Y(I-4)-Y(I)+8.D0*(Y(I-1)-Y(I-3)))
  8712. 3    Z(I-4)=A
  8713. C       END OF DIFFERENTIATION LOOP
  8714. C
  8715. C       NORMAL EXIT
  8716.     IER=0
  8717.     A=HH*(-YY+6.D0*Y(NDIM-3)-18.D0*Y(NDIM-2)+10.D0*Y(NDIM-1)
  8718.      1      +3.D0*Y(NDIM))
  8719.     Z(NDIM)=HH*(3.D0*YY-16.D0*Y(NDIM-3)+36.D0*Y(NDIM-2)
  8720.      1            -48.D0*Y(NDIM-1)+25.D0*Y(NDIM))
  8721.     Z(NDIM-1)=A
  8722.     Z(NDIM-2)=C
  8723.     Z(NDIM-3)=B
  8724.     RETURN
  8725. C
  8726. C       ERROR EXIT IN CASE NDIM IS LESS THAN 5
  8727. 4    IER=-1
  8728.     RETURN
  8729. C
  8730. C       ERROR EXIT IN CASE OF ZERO STEPSIZE
  8731. 5    IER=1
  8732.     RETURN
  8733.     END
  8734. C
  8735. C    ..................................................................
  8736. C
  8737. C       SUBROUTINE DDGT3
  8738. C
  8739. C       PURPOSE
  8740. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF
  8741. C          ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES.
  8742. C
  8743. C       USAGE
  8744. C          CALL DDGT3(X,Y,Z,NDIM,IER)
  8745. C
  8746. C       DESCRIPTION OF PARAMETERS
  8747. C          X     -  GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES
  8748. C                   (DIMENSION NDIM)
  8749. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  8750. C                   CORRESPONDING TO X (DIMENSION NDIM)
  8751. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
  8752. C                   VALUES (DIMENSION NDIM)
  8753. C          NDIM  -  DIMENSION OF VECTORS X,Y AND Z
  8754. C          IER   -  RESULTING ERROR PARAMETER
  8755. C                   IER  = -1  - NDIM IS LESS THAN 3
  8756. C                   IER  =  0  - NO ERROR
  8757. C                   IER POSITIVE  - X(IER) = X(IER-1) OR X(IER) =
  8758. C                                   X(IER-2)
  8759. C
  8760. C       REMARKS
  8761. C          (1)   IF IER = -1,2,3, THEN THERE IS NO COMPUTATION.
  8762. C          (2)   IF IER =  4,...,N, THEN THE DERIVATIVE VALUES Z(1)
  8763. C                ,..., Z(IER-1) HAVE BEEN COMPUTED.
  8764. C          (3)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
  8765. C                X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  8766. C
  8767. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8768. C          NONE
  8769. C
  8770. C       METHOD
  8771. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
  8772. C          DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  8773. C          POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
  8774. C          (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B.,
  8775. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  8776. C          TORONTO/LONDON, 1956, PP. 64-68.)
  8777. C
  8778. C    ..................................................................
  8779. C
  8780.     SUBROUTINE DDGT3(X,Y,Z,NDIM,IER)
  8781. C
  8782. C
  8783.     DIMENSION X(1),Y(1),Z(1)
  8784.     DOUBLE PRECISION X,Y,Z,DY1,DY2,DY3,A,B
  8785. C
  8786. C       TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3
  8787.     IER=-1
  8788.     IF(NDIM-3)8,1,1
  8789. C
  8790. C       PREPARE DIFFERENTIATION LOOP
  8791. 1    A=X(1)
  8792.     B=Y(1)
  8793.     I=2
  8794.     DY2=X(2)-A
  8795.     IF(DY2)2,9,2
  8796. 2    DY2=(Y(2)-B)/DY2
  8797. C
  8798. C       START DIFFERENTIATION LOOP
  8799.     DO 6 I=3,NDIM
  8800.     A=X(I)-A
  8801.     IF(A)3,9,3
  8802. 3    A=(Y(I)-B)/A
  8803.     B=X(I)-X(I-1)
  8804.     IF(B)4,9,4
  8805. 4    DY1=DY2
  8806.     DY2=(Y(I)-Y(I-1))/B
  8807.     DY3=A
  8808.     A=X(I-1)
  8809.     B=Y(I-1)
  8810.     IF(I-3)5,5,6
  8811. 5    Z(1)=DY1+DY3-DY2
  8812. 6    Z(I-1)=DY1+DY2-DY3
  8813. C       END OF DIFFERENTIATION LOOP
  8814. C
  8815. C       NORMAL EXIT
  8816.     IER=0
  8817.     I=NDIM
  8818. 7    Z(I)=DY2+DY3-DY1
  8819. 8    RETURN
  8820. C
  8821. C       ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS
  8822. 9    IER=I
  8823.     I=I-1
  8824.     IF(I-2)8,8,7
  8825.     END
  8826. C
  8827. C    ..................................................................
  8828. C
  8829. C       SUBROUTINE DELI1
  8830. C
  8831. C       PURPOSE
  8832. C          COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND
  8833. C
  8834. C       USAGE
  8835. C          CALL DELI1(RES,X,CK)
  8836. C
  8837. C       DESCRIPTION OF PARAMETERS
  8838. C          RES   - RESULT VALUE IN DOUBLE PRECISION
  8839. C          X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
  8840. C                  INTEGRAL OF FIRST KIND) IN DOUBLE PRECISION
  8841. C          CK    - COMPLEMENTARY MODULUS IN DOUBLE PRECISION
  8842. C
  8843. C       REMARKS
  8844. C          DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK).
  8845. C
  8846. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8847. C          NONE
  8848. C
  8849. C       METHOD
  8850. C          DEFINITION
  8851. C          RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
  8852. C          OVER T FROM 0 TO X).
  8853. C          EQUIVALENT ARE THE DEFINITIONS
  8854. C          RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED
  8855. C          OVER T FROM 0 TO ATAN(X)),
  8856. C          RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER
  8857. C          T FROM 0 TO ATAN(X)).
  8858. C          EVALUATION
  8859. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  8860. C          REFERENCE
  8861. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  8862. C                 ELLIPTIC FUNCTIONS.
  8863. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  8864. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  8865. C
  8866. C    ..................................................................
  8867. C
  8868.     SUBROUTINE DELI1(RES,X,CK)
  8869. C
  8870.     DOUBLE PRECISION RES,X,CK,ANGLE,GEO,ARI,PIM,SQGEO,AARI,TEST
  8871. C
  8872.     IF(X)2,1,2
  8873. 1    RES=0.D0
  8874.     RETURN
  8875. C
  8876. 2    IF(CK)4,3,4
  8877. 3    RES=DLOG(DABS(X)+DSQRT(1.D0+X*X))
  8878.     GOTO 13
  8879. C
  8880. 4    ANGLE=DABS(1.D0/X)
  8881.     GEO=DABS(CK)
  8882.     ARI=1.D0
  8883.     PIM=0.D0
  8884. 5    SQGEO=ARI*GEO
  8885.     AARI=ARI
  8886.     ARI=GEO+ARI
  8887.     ANGLE=-SQGEO/ANGLE+ANGLE
  8888.     SQGEO=DSQRT(SQGEO)
  8889.     IF(ANGLE)7,6,7
  8890. C
  8891. C       REPLACE 0 BY SMALL VALUE
  8892. C
  8893. 6    ANGLE=SQGEO*1.D-17
  8894. 7    TEST=AARI*1.D-9
  8895.     IF(DABS(AARI-GEO)-TEST)10,10,8
  8896. 8    GEO=SQGEO+SQGEO
  8897.     PIM=PIM+PIM
  8898.     IF(ANGLE)9,5,5
  8899. 9    PIM=PIM+3.1415926535897932
  8900.     GOTO 5
  8901. 10    IF(ANGLE)11,12,12
  8902. 11    PIM=PIM+3.1415926535897932
  8903. 12    RES=(DATAN(ARI/ANGLE)+PIM)/ARI
  8904. 13    IF(X)14,15,15
  8905. 14    RES=-RES
  8906. 15    RETURN
  8907.     END
  8908. C
  8909. C    ..................................................................
  8910. C
  8911. C       SUBROUTINE DELI2
  8912. C
  8913. C       PURPOSE
  8914. C          COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND
  8915. C
  8916. C       USAGE
  8917. C          CALL DELI2(R,X,CK,A,B)
  8918. C
  8919. C       DESCRIPTION OF PARAMETERS
  8920. C          R     - RESULT VALUE IN DOUBLE PRECISION
  8921. C          X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
  8922. C                  INTEGRAL OF SECOND KIND) IN DOUBLE PRECISION
  8923. C          CK    - COMPLEMENTARY MODULUS IN DOUBLE PRECISION
  8924. C          A     - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR
  8925. C          B     - DOUBLE PRECISION QUATRATIC TERM IN NUMERATOR
  8926. C
  8927. C       REMARKS
  8928. C          DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK).
  8929. C          SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF
  8930. C          SECOND KIND ARE
  8931. C          F(DATAN(X),K) OBTAINED WITH A=1.D0, B=1.D0
  8932. C          E(DATAN(X),K) OBTAINED WITH A=1.D0, B=CK*CK
  8933. C          B(DATAN(X),K) OBTAINED WITH A=1.D0, B=0.D0
  8934. C          D(DATAN(X),K) OBTAINED WITH A=0.D0, B=1.D0.
  8935. C
  8936. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  8937. C          NONE
  8938. C
  8939. C       METHOD
  8940. C          DEFINITION
  8941. C          R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)),
  8942. C                 SUMMED OVER T FROM 0 TO X).
  8943. C          EQUIVALENT IS THE DEFINITION
  8944. C          R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2),
  8945. C                 SUMMED OVER T FROM 0 TO ATAN(X)).
  8946. C          EVALUATION
  8947. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  8948. C          REFERENCE
  8949. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  8950. C                 ELLIPTIC FUNCTIONS
  8951. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  8952. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  8953. C
  8954. C    ..................................................................
  8955. C
  8956.     SUBROUTINE DELI2(R,X,CK,A,B)
  8957. C
  8958.     DOUBLE PRECISION R,X,A,B,AN,AA,ANG,AANG,PIM,PIMA,ARI,AARI
  8959.     DOUBLE PRECISION GEO,SGEO,C,D,P,CK
  8960. C
  8961. C       TEST ARGUMENT
  8962. C
  8963.     IF(X)2,1,2
  8964. 1    R=0.D0
  8965.     RETURN
  8966. C
  8967. C       TEST MODULUS
  8968. C
  8969. 2    C=0.D0
  8970.     D=0.5D0
  8971.     IF(CK)7,3,7
  8972. 3    R=DSQRT(1.D0+X*X)
  8973.     R=(A-B)*DABS(X)/R+B*DLOG(DABS(X)+R)
  8974. 4    R=R+C*(A-B)
  8975. C
  8976. C       TEST SIGN OF ARGUMENT
  8977. C
  8978.     IF(X)5,6,6
  8979. 5    R=-R
  8980. 6    RETURN
  8981. C
  8982. C       INITIALIZATION
  8983. C
  8984. 7    AN=(B+A)*0.5D0
  8985.     AA=A
  8986.     R=B
  8987.     ANG=DABS(1.D0/X)
  8988.     PIM=0.D0
  8989.     ISI=0
  8990.     ARI=1.D0
  8991.     GEO=DABS(CK)
  8992. C
  8993. C       LANDEN TRANSFORMATION
  8994. C
  8995. 8    R=AA*GEO+R
  8996.     SGEO=ARI*GEO
  8997.     AA=AN
  8998.     AARI=ARI
  8999. C
  9000. C       ARITHMETIC MEAN
  9001. C
  9002.     ARI=GEO+ARI
  9003. C
  9004. C       SUM OF SINE VALUES
  9005. C
  9006.     AN=(R/ARI+AA)*0.5D0
  9007.     AANG=DABS(ANG)
  9008.     ANG=-SGEO/ANG+ANG
  9009.     PIMA=PIM
  9010.     IF(ANG)10,9,11
  9011. C
  9012. C       REPLACE 0 BY SMALL VALUE
  9013. C
  9014. 9    ANG=-1.D-17*AANG
  9015. 10    PIM=PIM+3.1415926535897932
  9016.     ISI=ISI+1
  9017. 11    AANG=ARI*ARI+ANG*ANG
  9018.     P=D/DSQRT(AANG)
  9019.     IF(ISI-4)13,12,12
  9020. 12    ISI=ISI-4
  9021. 13    IF(ISI-2)15,14,14
  9022. 14    P=-P
  9023. 15    C=C+P
  9024.     D=D*(AARI-GEO)*0.5D0/ARI
  9025.     IF(DABS(AARI-GEO)-1.D-9*AARI)17,17,16
  9026. 16    SGEO=DSQRT(SGEO)
  9027. C
  9028. C       GEOMETRIC MEAN
  9029. C
  9030.     GEO=SGEO+SGEO
  9031.     PIM=PIM+PIMA
  9032.     ISI=ISI+ISI
  9033.     GOTO 8
  9034. C
  9035. C       ACCURACY WAS SUFFICIENT
  9036. C
  9037. 17    R=(DATAN(ARI/ANG)+PIM)*AN/ARI
  9038.     C=C+D*ANG/AANG
  9039.     GOTO 4
  9040.     END
  9041. C
  9042. C    ..................................................................
  9043. C
  9044. C       SUBROUTINE DET3
  9045. C
  9046. C       PURPOSE
  9047. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
  9048. C          FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
  9049. C          SPACED ARGUMENT VALUES.
  9050. C
  9051. C       USAGE
  9052. C          CALL DET3(H,Y,Z,NDIM,IER)
  9053. C
  9054. C       DESCRIPTION OF PARAMETERS
  9055. C          H     -  CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT
  9056. C                   VALUES (H IS POSITIVE IF THE ARGUMENT VALUES
  9057. C                   INCREASE AND NEGATIVE OTHERWISE)
  9058. C          Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
  9059. C          Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
  9060. C                   NDIM)
  9061. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  9062. C          IER   -  RESULTING ERROR PARAMETER
  9063. C                   IER = -1  - NDIM IS LESS THAN 3
  9064. C                   IER =  0  - NO ERROR
  9065. C                   IER =  1  - H = 0
  9066. C
  9067. C       REMARKS
  9068. C          (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
  9069. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS
  9070. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  9071. C
  9072. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9073. C          NONE
  9074. C
  9075. C       METHOD
  9076. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  9077. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
  9078. C          DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  9079. C          POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
  9080. C          (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
  9081. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/
  9082. C          TORONTO/LONDON, 1956, PP.82-84.)
  9083. C
  9084. C    ..................................................................
  9085. C
  9086.     SUBROUTINE DET3(H,Y,Z,NDIM,IER)
  9087. C
  9088. C
  9089.     DIMENSION Y(1),Z(1)
  9090. C
  9091. C       TEST OF DIMENSION
  9092.     IF(NDIM-3)4,1,1
  9093. C
  9094. C       TEST OF STEPSIZE
  9095. 1    IF(H)2,5,2
  9096. C
  9097. C       PREPARE DIFFERENTIATION LOOP
  9098. 2    HH=.5/H
  9099.     YY=Y(NDIM-2)
  9100.     B=Y(2)+Y(2)
  9101.     B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1))
  9102. C
  9103. C       START DIFFERENTIATION LOOP
  9104.     DO 3 I=3,NDIM
  9105.     A=B
  9106.     B=HH*(Y(I)-Y(I-2))
  9107. 3    Z(I-2)=A
  9108. C       END OF DIFFERENTIATION LOOP
  9109. C
  9110. C       NORMAL EXIT
  9111.     IER=0
  9112.     A=Y(NDIM-1)+Y(NDIM-1)
  9113.     Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY)
  9114.     Z(NDIM-1)=B
  9115.     RETURN
  9116. C
  9117. C       ERROR EXIT IN CASE NDIM IS LESS THAN 3
  9118. 4    IER=-1
  9119.     RETURN
  9120. C
  9121. C       ERROR EXIT IN CASE OF ZERO STEPSIZE
  9122. 5    IER=1
  9123.     RETURN
  9124.     END
  9125. C
  9126. C    ..................................................................
  9127. C
  9128. C       SUBROUTINE DET5
  9129. C
  9130. C       PURPOSE
  9131. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
  9132. C          FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
  9133. C          SPACED ARGUMENT VALUES.
  9134. C
  9135. C       USAGE
  9136. C          CALL DET5(H,Y,Z,NDIM,IER)
  9137. C
  9138. C       DESCRIPTION OF PARAMETERS
  9139. C          H     -  CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT
  9140. C                   VALUES (H IS POSITIVE IF THE ARGUMENT VALUES
  9141. C                   INCREASE AND NEGATIVE OTHERWISE)
  9142. C          Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
  9143. C          Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
  9144. C                   NDIM)
  9145. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  9146. C          IER   -  RESULTING ERROR PARAMETER
  9147. C                   IER = -1  - NDIM IS LESS THAN 5
  9148. C                   IER =  0  - NO ERROR
  9149. C                   IER =  1  - H = 0
  9150. C
  9151. C       REMARKS
  9152. C          (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
  9153. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
  9154. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  9155. C
  9156. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9157. C          NONE
  9158. C
  9159. C       METHOD
  9160. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  9161. C          EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I)
  9162. C          IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  9163. C          POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS
  9164. C          (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE HILDEBRAND, F.B.,
  9165. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  9166. C          TORONTO/LONDON, 1956, PP. 82-84.)
  9167. C
  9168. C    ..................................................................
  9169. C
  9170.     SUBROUTINE DET5(H,Y,Z,NDIM,IER)
  9171. C
  9172. C
  9173.     DIMENSION Y(1),Z(1)
  9174. C
  9175. C       TEST OF DIMENSION
  9176.     IF(NDIM-5)4,1,1
  9177. C
  9178. C       TEST OF STEPSIZE
  9179. 1    IF(H)2,5,2
  9180. C
  9181. C       PREPARE DIFFERENTIATION LOOP
  9182. 2    HH=.08333333/H
  9183.     YY=Y(NDIM-4)
  9184.     B=HH*(-25.*Y(1)+48.*Y(2)-36.*Y(3)+16.*Y(4)-3.*Y(5))
  9185.     C=HH*(-3.*Y(1)-10.*Y(2)+18.*Y(3)-6.*Y(4)+Y(5))
  9186. C
  9187. C       START DIFFERENTIATION LOOP
  9188.     DO 3 I=5,NDIM
  9189.     A=B
  9190.     B=C
  9191.     C=HH*(Y(I-4)-Y(I)+8.*(Y(I-1)-Y(I-3)))
  9192. 3    Z(I-4)=A
  9193. C       END OF DIFFERENTIATION LOOP
  9194. C
  9195. C       NORMAL EXIT
  9196.     IER=0
  9197.     A=HH*(-YY+6.*Y(NDIM-3)-18.*Y(NDIM-2)+10.*Y(NDIM-1)+3.*Y(NDIM))
  9198.     Z(NDIM)=HH*(3.*YY-16.*Y(NDIM-3)+36.*Y(NDIM-2)-48.*Y(NDIM-1)
  9199.      1            +25.*Y(NDIM))
  9200.     Z(NDIM-1)=A
  9201.     Z(NDIM-2)=C
  9202.     Z(NDIM-3)=B
  9203.     RETURN
  9204. C
  9205. C       ERROR EXIT IN CASE NDIM IS LESS THAN 5
  9206. 4    IER=-1
  9207.     RETURN
  9208. C
  9209. C       ERROR EXIT IN CASE OF ZERO STEPSIZE
  9210. 5    IER=1
  9211.     RETURN
  9212.     END
  9213. C
  9214. C    ..................................................................
  9215. C
  9216. C       SUBROUTINE DFMCG
  9217. C
  9218. C       PURPOSE
  9219. C          TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
  9220. C          BY THE METHOD OF CONJUGATE GRADIENTS
  9221. C
  9222. C       USAGE
  9223. C          CALL DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  9224. C
  9225. C       DESCRIPTION OF PARAMETERS
  9226. C          FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
  9227. C                   BE MINIMIZED. IT MUST BE OF THE FORM
  9228. C                   SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
  9229. C                   AND MUST SERVE THE FOLLOWING PURPOSE
  9230. C                   FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
  9231. C                   FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
  9232. C                   AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
  9233. C                   ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION.
  9234. C          N      - NUMBER OF VARIABLES
  9235. C          X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
  9236. C                   ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
  9237. C                   X HOLDS THE ARGUMENT CORRESPONDING TO THE
  9238. C                   COMPUTED MINIMUM FUNCTION VALUE
  9239. C                   DOUBLE PRECISION VECTOR.
  9240. C          F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
  9241. C                   VALUE ON RETURN, I.E. F=F(X).
  9242. C                   DOUBLE PRECISION VARIABLE.
  9243. C          G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
  9244. C                   VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
  9245. C                   I.E. G=G(X).
  9246. C                   DOUBLE PRECISION VECTOR.
  9247. C          EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
  9248. C                   SINGLE PRECISION VARIABLE.
  9249. C          EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
  9250. C                   A REASONABLE CHOICE IS 10**(-16), I.E.
  9251. C                   SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
  9252. C                   NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
  9253. C                   REPRESENTATION.
  9254. C                   SINGLE PRECISION VARIABLE.
  9255. C          LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
  9256. C          IER    - ERROR PARAMETER
  9257. C                   IER = 0 MEANS CONVERGENCE WAS OBTAINED
  9258. C                   IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
  9259. C                   IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
  9260. C                   IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
  9261. C                   IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
  9262. C          H      - WORKING STORAGE OF DIMENSION 2*N.
  9263. C                   DOUBLE PRECISION ARRAY.
  9264. C
  9265. C       REMARKS
  9266. C           I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
  9267. C              MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
  9268. C          II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
  9269. C              DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
  9270. C              A TOLERABLE RANGE OF ARGUMENT.
  9271. C              IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
  9272. C              INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
  9273. C              RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
  9274. C              MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
  9275. C              TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
  9276. C              IS FOUND WHERE THE FUNCTION INCREASES.
  9277. C
  9278. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9279. C          FUNCT
  9280. C
  9281. C       METHOD
  9282. C          THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
  9283. C          R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY
  9284. C          CONJUGATE GRADIENTS,
  9285. C          COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154.
  9286. C
  9287. C    ..................................................................
  9288. C
  9289.     SUBROUTINE DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  9290. C
  9291. C       DIMENSIONED DUMMY VARIABLES
  9292.     DIMENSION X(1),G(1),H(1)
  9293.     DOUBLE PRECISION X,G,GNRM,H,HNRM,F,FX,FY,OLDF,OLDG,SNRM,AMBDA,
  9294.      1ALFA,DALFA,T,Z,W,DX,DY
  9295. C
  9296. C       COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
  9297.     CALL FUNCT(N,X,F,G)
  9298. C
  9299. C       RESET ITERATION COUNTER
  9300.     KOUNT=0
  9301.     IER=0
  9302.     N1=N+1
  9303. C
  9304. C       START ITERATION CYCLE FOR EVERY N+1 ITERATIONS
  9305. 1    DO 43 II=1,N1
  9306. C
  9307. C       STEP ITERATION COUNTER AND SAVE FUNCTION VALUE
  9308.     KOUNT=KOUNT+1
  9309.     OLDF=F
  9310. C
  9311. C       COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO
  9312.     GNRM=0.D0
  9313.     DO 2 J=1,N
  9314. 2    GNRM=GNRM+G(J)*G(J)
  9315.     IF(GNRM)46,46,3
  9316. C
  9317. C       EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL
  9318. C       BE IN DIRECTION OF STEEPEST DESCENT
  9319. 3    IF(II-1)4,4,6
  9320. 4    DO 5 J=1,N
  9321. 5    H(J)=-G(J)
  9322.     GO TO 8
  9323. C
  9324. C       FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING
  9325. C       TO THE CONJUGATE GRADIENT METHOD
  9326. 6    AMBDA=GNRM/OLDG
  9327.     DO 7 J=1,N
  9328. 7    H(J)=AMBDA*H(J)-G(J)
  9329. C
  9330. C       COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL
  9331. C       DERIVATIVE
  9332. 8    DY=0.D0
  9333.     HNRM=0.D0
  9334.     DO 9 J=1,N
  9335.     K=J+N
  9336. C
  9337. C       SAVE ARGUMENT VECTOR
  9338.     H(K)=X(J)
  9339.     HNRM=HNRM+DABS(H(J))
  9340. 9    DY=DY+H(J)*G(J)
  9341. C
  9342. C       CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND
  9343. C       SKIP LINEAR SEARCH ROUTINE IF NOT
  9344.     IF(DY)10,42,42
  9345. C
  9346. C       COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE
  9347. 10    SNRM=1.D0/HNRM
  9348. C
  9349. C       SEARCH MINIMUM ALONG DIRECTION H
  9350. C
  9351. C       SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
  9352.     FY=F
  9353.     ALFA=2.D0*(EST-F)/DY
  9354.     AMBDA=SNRM
  9355. C
  9356. C       USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
  9357. C       SNRM. OTHERWISE TAKE SNRM AS STEPSIZE.
  9358.     IF(ALFA)13,13,11
  9359. 11    IF(ALFA-AMBDA)12,13,13
  9360. 12    AMBDA=ALFA
  9361. 13    ALFA=0.D0
  9362. C
  9363. C       SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
  9364. 14    FX=FY
  9365.     DX=DY
  9366. C
  9367. C       STEP ARGUMENT ALONG H
  9368.     DO 15 I=1,N
  9369. 15    X(I)=X(I)+AMBDA*H(I)
  9370. C
  9371. C       COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
  9372.     CALL FUNCT(N,X,F,G)
  9373.     FY=F
  9374. C
  9375. C       COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
  9376. C       SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
  9377.     DY=0.D0
  9378.     DO 16 I=1,N
  9379. 16    DY=DY+G(I)*H(I)
  9380.     IF(DY)17,38,20
  9381. C
  9382. C       TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
  9383. C       A MINIMUM HAS BEEN PASSED
  9384. 17    IF(FY-FX)18,20,20
  9385. C
  9386. C       REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
  9387. 18    AMBDA=AMBDA+ALFA
  9388.     ALFA=AMBDA
  9389. C
  9390. C       TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
  9391.     IF(HNRM*AMBDA-1.D10)14,14,19
  9392. C
  9393. C       LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
  9394. 19    IER=2
  9395. C
  9396. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  9397.     F=OLDF
  9398.     DO 100 J=1,N
  9399.     G(J)=H(J)
  9400.     K=N+J
  9401. 100    X(J)=H(K)
  9402.     RETURN
  9403. C       END OF SEARCH LOOP
  9404. C
  9405. C       INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
  9406. C       ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
  9407. C       POLYNOMIAL IS MINIMIZED
  9408. C
  9409. 20    T=0.
  9410. 21    IF(AMBDA)22,38,22
  9411. 22    Z=3.D0*(FX-FY)/AMBDA+DX+DY
  9412.     ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY))
  9413.     DALFA=Z/ALFA
  9414.     DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
  9415.     IF(DALFA)23,27,27
  9416. C
  9417. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  9418. 23    DO 24 J=1,N
  9419.     K=N+J
  9420. 24    X(J)=H(K)
  9421.     CALL FUNCT(N,X,F,G)
  9422. C
  9423. C       TEST FOR REPEATED FAILURE OF ITERATION
  9424. 25    IF(IER)47,26,47
  9425. 26    IER=-1
  9426.     GOTO 1
  9427. 27    W=ALFA*DSQRT(DALFA)
  9428.     ALFA=DY-DX+W+W
  9429.     IF(ALFA)270,271,270
  9430. 270    ALFA=(DY-Z+W)/ALFA
  9431.     GO TO 272
  9432. 271    ALFA=(Z+DY-W)/(Z+DX+Z+DY)
  9433. 272    ALFA=ALFA*AMBDA
  9434.     DO 28 I=1,N
  9435. 28    X(I)=X(I)+(T-ALFA)*H(I)
  9436. C
  9437. C       TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
  9438. C       THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
  9439. C       THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
  9440. C       THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
  9441. C       VALUE OF THE FUNCTION AND ITS GRADIENT AT X
  9442. C
  9443.     CALL FUNCT(N,X,F,G)
  9444.     IF(F-FX)29,29,30
  9445. 29    IF(F-FY)38,38,30
  9446. C
  9447. C       COMPUTE DIRECTIONAL DERIVATIVE
  9448. 30    DALFA=0.D0
  9449.     DO 31 I=1,N
  9450. 31    DALFA=DALFA+G(I)*H(I)
  9451.     IF(DALFA)32,35,35
  9452. 32    IF(F-FX)34,33,35
  9453. 33    IF(DX-DALFA)34,38,34
  9454. 34    FX=F
  9455.     DX=DALFA
  9456.     T=ALFA
  9457.     AMBDA=ALFA
  9458.     GO TO 21
  9459. 35    IF(FY-F)37,36,37
  9460. 36    IF(DY-DALFA)37,38,37
  9461. 37    FY=F
  9462.     DY=DALFA
  9463.     AMBDA=AMBDA-ALFA
  9464.     GO TO 20
  9465. C
  9466. C       TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
  9467. C       OTHERWISE SAVE GRADIENT NORM
  9468. 38    IF(OLDF-F+EPS)19,25,39
  9469. 39    OLDG=GNRM
  9470. C
  9471. C       COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR
  9472.     T=0.D0
  9473.     DO 40 J=1,N
  9474.     K=J+N
  9475.     H(K)=X(J)-H(K)
  9476. 40    T=T+DABS(H(K))
  9477. C
  9478. C       TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS
  9479. C       HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS
  9480.     IF(KOUNT-N1)42,41,41
  9481. 41    IF(T-EPS)45,45,42
  9482. C
  9483. C       TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
  9484. 42    IF(KOUNT-LIMIT)43,44,44
  9485. 43    IER=0
  9486. C       END OF ITERATION CYCLE
  9487. C
  9488. C       START NEXT ITERATION CYCLE
  9489.     GO TO 1
  9490. C
  9491. C       NO CONVERGENCE AFTER  LIMIT  ITERATIONS
  9492. 44    IER=1
  9493.     IF(GNRM-EPS)46,46,47
  9494. C
  9495. C       TEST FOR SUFFICIENTLY SMALL GRADIENT
  9496. 45    IF(GNRM-EPS)46,46,25
  9497. 46    IER=0
  9498. 47    RETURN
  9499.     END
  9500. C
  9501. C    ..................................................................
  9502. C
  9503. C       SUBROUTINE DFMFP
  9504. C
  9505. C       PURPOSE
  9506. C          TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
  9507. C          BY THE METHOD OF FLETCHER AND POWELL
  9508. C
  9509. C       USAGE
  9510. C          CALL DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  9511. C
  9512. C       DESCRIPTION OF PARAMETERS
  9513. C          FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
  9514. C                   BE MINIMIZED. IT MUST BE OF THE FORM
  9515. C                   SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
  9516. C                   AND MUST SERVE THE FOLLOWING PURPOSE
  9517. C                   FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
  9518. C                   FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
  9519. C                   AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
  9520. C                   ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION.
  9521. C          N      - NUMBER OF VARIABLES
  9522. C          X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
  9523. C                   ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
  9524. C                   X HOLDS THE ARGUMENT CORRESPONDING TO THE
  9525. C                   COMPUTED MINIMUM FUNCTION VALUE
  9526. C                   DOUBLE PRECISION VECTOR.
  9527. C          F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
  9528. C                   VALUE ON RETURN, I.E. F=F(X).
  9529. C                   DOUBLE PRECISION VARIABLE.
  9530. C          G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
  9531. C                   VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
  9532. C                   I.E. G=G(X).
  9533. C                   DOUBLE PRECISION VECTOR.
  9534. C          EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
  9535. C                   SINGLE PRECISION VARIABLE.
  9536. C          EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
  9537. C                   A REASONABLE CHOICE IS 10**(-16), I.E.
  9538. C                   SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
  9539. C                   NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
  9540. C                   REPRESENTATION.
  9541. C                   SINGLE PRECISION VARIABLE.
  9542. C          LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
  9543. C          IER    - ERROR PARAMETER
  9544. C                   IER = 0 MEANS CONVERGENCE WAS OBTAINED
  9545. C                   IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
  9546. C                   IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
  9547. C                   IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
  9548. C                   IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
  9549. C          H      - WORKING STORAGE OF DIMENSION N*(N+7)/2.
  9550. C                   DOUBLE PRECISION ARRAY.
  9551. C
  9552. C       REMARKS
  9553. C           I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
  9554. C              MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
  9555. C          II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
  9556. C              DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
  9557. C              A TOLERABLE RANGE OF ARGUMENT.
  9558. C              IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
  9559. C              INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
  9560. C              RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
  9561. C              MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
  9562. C              TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
  9563. C              IS FOUND WHERE THE FUNCTION INCREASES.
  9564. C
  9565. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9566. C          FUNCT
  9567. C
  9568. C       METHOD
  9569. C          THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
  9570. C          R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR
  9571. C          MINIMIZATION,
  9572. C          COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168.
  9573. C
  9574. C    ..................................................................
  9575. C
  9576.     SUBROUTINE DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  9577. C
  9578. C       DIMENSIONED DUMMY VARIABLES
  9579.     DIMENSION H(1),X(1),G(1)
  9580.     DOUBLE PRECISION X,F,FX,FY,OLDF,HNRM,GNRM,H,G,DX,DY,ALFA,DALFA,
  9581.      1AMBDA,T,Z,W
  9582. C
  9583. C       COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
  9584.     CALL FUNCT(N,X,F,G)
  9585. C
  9586. C       RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX
  9587.     IER=0
  9588.     KOUNT=0
  9589.     N2=N+N
  9590.     N3=N2+N
  9591.     N31=N3+1
  9592. 1    K=N31
  9593.     DO 4 J=1,N
  9594.     H(K)=1.D0
  9595.     NJ=N-J
  9596.     IF(NJ)5,5,2
  9597. 2    DO 3 L=1,NJ
  9598.     KL=K+L
  9599. 3    H(KL)=0.D0
  9600. 4    K=KL+1
  9601. C
  9602. C       START ITERATION LOOP
  9603. 5    KOUNT=KOUNT +1
  9604. C
  9605. C       SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR
  9606.     OLDF=F
  9607.     DO 9 J=1,N
  9608.     K=N+J
  9609.     H(K)=G(J)
  9610.     K=K+N
  9611.     H(K)=X(J)
  9612. C
  9613. C       DETERMINE DIRECTION VECTOR H
  9614.     K=J+N3
  9615.     T=0.D0
  9616.     DO 8 L=1,N
  9617.     T=T-G(L)*H(K)
  9618.     IF(L-J)6,7,7
  9619. 6    K=K+N-L
  9620.     GO TO 8
  9621. 7    K=K+1
  9622. 8    CONTINUE
  9623. 9    H(J)=T
  9624. C
  9625. C       CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H.
  9626.     DY=0.D0
  9627.     HNRM=0.D0
  9628.     GNRM=0.D0
  9629. C
  9630. C       CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION
  9631. C       VECTOR H AND GRADIENT VECTOR G.
  9632.     DO 10 J=1,N
  9633.     HNRM=HNRM+DABS(H(J))
  9634.     GNRM=GNRM+DABS(G(J))
  9635. 10    DY=DY+H(J)*G(J)
  9636. C
  9637. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL
  9638. C       DERIVATIVE APPEARS TO BE POSITIVE OR ZERO.
  9639.     IF(DY)11,51,51
  9640. C
  9641. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION
  9642. C       VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G.
  9643. 11    IF(HNRM/GNRM-EPS)51,51,12
  9644. C
  9645. C       SEARCH MINIMUM ALONG DIRECTION H
  9646. C
  9647. C       SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
  9648. 12    FY=F
  9649.     ALFA=2.D0*(EST-F)/DY
  9650.     AMBDA=1.D0
  9651. C
  9652. C       USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
  9653. C       1. OTHERWISE TAKE 1. AS STEPSIZE
  9654.     IF(ALFA)15,15,13
  9655. 13    IF(ALFA-AMBDA)14,15,15
  9656. 14    AMBDA=ALFA
  9657. 15    ALFA=0.D0
  9658. C
  9659. C       SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
  9660. 16    FX=FY
  9661.     DX=DY
  9662. C
  9663. C       STEP ARGUMENT ALONG H
  9664.     DO 17 I=1,N
  9665. 17    X(I)=X(I)+AMBDA*H(I)
  9666. C
  9667. C       COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
  9668.     CALL FUNCT(N,X,F,G)
  9669.     FY=F
  9670. C
  9671. C       COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
  9672. C       SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
  9673.     DY=0.D0
  9674.     DO 18 I=1,N
  9675. 18    DY=DY+G(I)*H(I)
  9676.     IF(DY)19,36,22
  9677. C
  9678. C       TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
  9679. C       A MINIMUM HAS BEEN PASSED
  9680. 19    IF(FY-FX)20,22,22
  9681. C
  9682. C       REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
  9683. 20    AMBDA=AMBDA+ALFA
  9684.     ALFA=AMBDA
  9685. C       END OF SEARCH LOOP
  9686. C
  9687. C       TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
  9688.     IF(HNRM*AMBDA-1.D10)16,16,21
  9689. C
  9690. C       LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
  9691. 21    IER=2
  9692.     RETURN
  9693. C
  9694. C       INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
  9695. C       ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
  9696. C       POLYNOMIAL IS MINIMIZED
  9697. 22    T=0.D0
  9698. 23    IF(AMBDA)24,36,24
  9699. 24    Z=3.D0*(FX-FY)/AMBDA+DX+DY
  9700.     ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY))
  9701.     DALFA=Z/ALFA
  9702.     DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
  9703.     IF(DALFA)51,25,25
  9704. 25    W=ALFA*DSQRT(DALFA)
  9705.     ALFA=DY-DX+W+W
  9706.     IF(ALFA) 250,251,250
  9707. 250    ALFA=(DY-Z+W)/ALFA
  9708.     GO TO 252
  9709. 251    ALFA=(Z+DY-W)/(Z+DX+Z+DY)
  9710. 252    ALFA=ALFA*AMBDA
  9711.     DO 26 I=1,N
  9712. 26    X(I)=X(I)+(T-ALFA)*H(I)
  9713. C
  9714. C       TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
  9715. C       THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
  9716. C       THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
  9717. C       THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
  9718. C       VALUE OF THE FUNCTION AND ITS GRADIENT AT X
  9719. C
  9720.     CALL FUNCT(N,X,F,G)
  9721.     IF(F-FX)27,27,28
  9722. 27    IF(F-FY)36,36,28
  9723. 28    DALFA=0.D0
  9724.     DO 29 I=1,N
  9725. 29    DALFA=DALFA+G(I)*H(I)
  9726.     IF(DALFA)30,33,33
  9727. 30    IF(F-FX)32,31,33
  9728. 31    IF(DX-DALFA)32,36,32
  9729. 32    FX=F
  9730.     DX=DALFA
  9731.     T=ALFA
  9732.     AMBDA=ALFA
  9733.     GO TO 23
  9734. 33    IF(FY-F)35,34,35
  9735. 34    IF(DY-DALFA)35,36,35
  9736. 35    FY=F
  9737.     DY=DALFA
  9738.     AMBDA=AMBDA-ALFA
  9739.     GO TO 22
  9740. C
  9741. C       TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
  9742. 36    IF(OLDF-F+EPS)51,38,38
  9743. C
  9744. C       COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM
  9745. C       TWO CONSECUTIVE ITERATIONS
  9746. 38    DO 37 J=1,N
  9747.     K=N+J
  9748.     H(K)=G(J)-H(K)
  9749.     K=N+K
  9750. 37    H(K)=X(J)-H(K)
  9751. C
  9752. C       TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR
  9753. C       IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF
  9754. C       BOTH ARE LESS THAN  EPS
  9755.     IER=0
  9756.     IF(KOUNT-N)42,39,39
  9757. 39    T=0.D0
  9758.     Z=0.D0
  9759.     DO 40 J=1,N
  9760.     K=N+J
  9761.     W=H(K)
  9762.     K=K+N
  9763.     T=T+DABS(H(K))
  9764. 40    Z=Z+W*H(K)
  9765.     IF(HNRM-EPS)41,41,42
  9766. 41    IF(T-EPS)56,56,42
  9767. C
  9768. C       TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
  9769. 42    IF(KOUNT-LIMIT)43,50,50
  9770. C
  9771. C       PREPARE UPDATING OF MATRIX H
  9772. 43    ALFA=0.D0
  9773.     DO 47 J=1,N
  9774.     K=J+N3
  9775.     W=0.D0
  9776.     DO 46 L=1,N
  9777.     KL=N+L
  9778.     W=W+H(KL)*H(K)
  9779.     IF(L-J)44,45,45
  9780. 44    K=K+N-L
  9781.     GO TO 46
  9782. 45    K=K+1
  9783. 46    CONTINUE
  9784.     K=N+J
  9785.     ALFA=ALFA+W*H(K)
  9786. 47    H(J)=W
  9787. C
  9788. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS
  9789. C       ARE NOT SATISFACTORY
  9790.     IF(Z*ALFA)48,1,48
  9791. C
  9792. C       UPDATE MATRIX H
  9793. 48    K=N31
  9794.     DO 49 L=1,N
  9795.     KL=N2+L
  9796.     DO 49 J=L,N
  9797.     NJ=N2+J
  9798.     H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA
  9799. 49    K=K+1
  9800.     GO TO 5
  9801. C       END OF ITERATION LOOP
  9802. C
  9803. C       NO CONVERGENCE AFTER  LIMIT  ITERATIONS
  9804. 50    IER=1
  9805.     RETURN
  9806. C
  9807. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  9808. 51    DO 52 J=1,N
  9809.     K=N2+J
  9810. 52    X(J)=H(K)
  9811.     CALL FUNCT(N,X,F,G)
  9812. C
  9813. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE
  9814. C       FAILS TO BE SUFFICIENTLY SMALL
  9815.     IF(GNRM-EPS)55,55,53
  9816. C
  9817. C       TEST FOR REPEATED FAILURE OF ITERATION
  9818. 53    IF(IER)56,54,54
  9819. 54    IER=-1
  9820.     GOTO 1
  9821. 55    IER=0
  9822. 56    RETURN
  9823.     END
  9824. C
  9825. C    ..................................................................
  9826. C
  9827. C       SUBROUTINE DFRAT
  9828. C
  9829. C       PURPOSE
  9830. C          DFRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS
  9831. C          WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF
  9832. C          RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY
  9833. C
  9834. C       USAGE
  9835. C          CALL DFRAT(I,N,M,P,DATI,WGT,IER)
  9836. C
  9837. C       DESCRIPTION OF PARAMETERS
  9838. C          I     - SUBSCRIPT OF CURRENT DATA POINT
  9839. C          N     - NUMBER OF ALL DATA POINTS
  9840. C          M     - NUMBER OF FUNDAMENTAL FUNCTIONS USED
  9841. C          P     - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS
  9842. C                  ON RETURN THE VALUES OF THE M FUNDAMENTAL
  9843. C                  FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE
  9844. C                  P MUST BE OF DOUBLE PRECISION
  9845. C          DATI  - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED
  9846. C                  BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY
  9847. C                  N WEIGHT VALUES
  9848. C                  DATI MUST BE OF DOUBLE PRECISION
  9849. C          WGT   - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM
  9850. C                  WGT MUST BE OF DOUBLE PRECISION
  9851. C          IER   - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT
  9852. C                  VALUES FOR CONTROL
  9853. C                  IER(2) MEANS DIMENSION OF NUMERATOR
  9854. C                  IER(3) MEANS DIMENSION OF DENOMINATOR
  9855. C                  IER(1) IS USED AS RESULTANT ERROR PARAMETER,
  9856. C                  IER(1) = 0 IN CASE OF NO ERRORS
  9857. C                  IER(1) = 1 OTHERWISE (ZERO DENOMINATOR)
  9858. C
  9859. C       REMARKS
  9860. C          VECTOR IER IS USED FOR COMMUNICATION BETWEEN DARAT AND DFRAT
  9861. C
  9862. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9863. C          DCNP
  9864. C
  9865. C       METHOD
  9866. C          CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT
  9867. C
  9868. C    ..................................................................
  9869. C
  9870.     SUBROUTINE DFRAT(I,N,M,P,DATI,WGT,IER)
  9871. C
  9872. C
  9873. C       DIMENSIONED DUMMY VARIABLES
  9874.     DIMENSION P(1),DATI(1),IER(1)
  9875.     DOUBLE PRECISION P,DATI,WGT,T,F,FNUM,FDEN
  9876. C
  9877. C       INITIALIZATION
  9878.     IP=IER(2)
  9879.     IQ=IER(3)
  9880.     IQM1=IQ-1
  9881.     IPQ=IP+IQ
  9882. C
  9883. C       LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT
  9884. C       LOOK UP NUMERATOR AND DENOMINATOR
  9885.     T=DATI(I)
  9886.     J=I+N
  9887.     F=DATI(J)
  9888.     FNUM=P(J)
  9889.     J=J+N
  9890.     WGT=1.D0
  9891.     IF(DATI(2*N+1))2,2,1
  9892. 1    WGT=DATI(J)
  9893. 2    FDEN=P(J)
  9894. C
  9895. C       CALCULATE FUNCTION VALUE USED
  9896.     F=F*FDEN-FNUM
  9897. C
  9898. C       CHECK FOR ZERO DENOMINATOR
  9899.     IF(FDEN)4,3,4
  9900. C
  9901. C       ERROR RETURN IN CASE OF ZERO DENOMINATOR
  9902. 3    IER(1)=1
  9903.     RETURN
  9904. C
  9905. C       CALCULATE WEIGHT FACTORS USED
  9906. 4    WGT=WGT/(FDEN*FDEN)
  9907.     FNUM=-FNUM/FDEN
  9908. C
  9909. C       CALCULATE FUNDAMENTAL FUNCTIONS
  9910.     J=IQM1
  9911.     IF(IP-IQ)6,6,5
  9912. 5    J=IP-1
  9913. 6    CALL DCNP(P(IQ),T,J)
  9914. C
  9915. C       STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS
  9916. 7    IF(IQM1)10,10,8
  9917. 8    DO 9 II=1,IQM1
  9918.     J=II+IQ
  9919. 9    P(II)=P(J)*FNUM
  9920. C
  9921. C       STORE FUNCTION VALUE
  9922. 10    P(IPQ)=F
  9923. C
  9924. C       NORMAL RETURN
  9925.     IER(1)=0
  9926.     RETURN
  9927.     END
  9928. C
  9929. C    ..................................................................
  9930. C
  9931. C       SUBROUTINE DGELB
  9932. C
  9933. C       PURPOSE
  9934. C          TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A
  9935. C          COEFFICIENT MATRIX OF BAND STRUCTURE.
  9936. C
  9937. C       USAGE
  9938. C          CALL DGELB(R,A,M,N,MUD,MLD,EPS,IER)
  9939. C
  9940. C       DESCRIPTION OF PARAMETERS
  9941. C          R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
  9942. C                   (DESTROYED). ON RETURN R CONTAINS THE SOLUTION
  9943. C                   OF THE EQUATIONS.
  9944. C          A      - DOUBLE PRECISION M BY M COEFFICIENT MATRIX WITH
  9945. C                   BAND STRUCTURE (DESTROYED).
  9946. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  9947. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  9948. C          MUD    - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS
  9949. C                   CODIAGONALS ABOVE MAIN DIAGONAL).
  9950. C          MLD    - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS
  9951. C                   CODIAGONALS BELOW MAIN DIAGONAL).
  9952. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  9953. C                   RELATIVE TOLERANCE FOR TEST ON LOSS OF
  9954. C                   SIGNIFICANCE.
  9955. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  9956. C                   IER=0  - NO ERROR,
  9957. C                   IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
  9958. C                            TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT
  9959. C                            AT ANY ELIMINATION STEP EQUAL TO 0,
  9960. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  9961. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  9962. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  9963. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  9964. C                            ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
  9965. C
  9966. C       REMARKS
  9967. C          BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST
  9968. C          ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA
  9969. C          STORAGE LOCATIONS, WHERE
  9970. C            MA=M*MC-ML*(ML+1)/2    AND    ME=MA-MU*(MU+1)/2    WITH
  9971. C            MC=MIN(M,1+MUD+MLD),  ML=MC-1-MLD,  MU=MC-1-MUD.
  9972. C          RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
  9973. C          IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION
  9974. C          MATRIX R IS STORED COLUMNWISE TOO.
  9975. C          INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING
  9976. C          RESTRICTIONS     MUD NOT LESS THAN ZERO
  9977. C                           MLD NOT LESS THAN ZERO
  9978. C                           MUD+MLD NOT GREATER THAN 2*M-2.
  9979. C          NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
  9980. C          RESTRICTIONS ARE NOT SATISFIED.
  9981. C          THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
  9982. C          PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL
  9983. C          ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING
  9984. C          IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE.
  9985. C          IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE
  9986. C          EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K.
  9987. C          NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL.
  9988. C
  9989. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  9990. C          NONE
  9991. C
  9992. C       METHOD
  9993. C          SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH
  9994. C          COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE
  9995. C          IN REMAINING COEFFICIENT MATRICES.
  9996. C
  9997. C    ..................................................................
  9998. C
  9999.     SUBROUTINE DGELB(R,A,M,N,MUD,MLD,EPS,IER)
  10000. C
  10001. C
  10002.     DIMENSION R(1),A(1)
  10003.     DOUBLE PRECISION R,A,PIV,TB,TOL
  10004. C
  10005. C    TEST ON WRONG INPUT PARAMETERS
  10006.     IF(MLD)47,1,1
  10007. 1    IF(MUD)47,2,2
  10008. 2    MC=1+MLD+MUD
  10009.     IF(MC+1-M-M)3,3,47
  10010. C
  10011. C    PREPARE INTEGER PARAMETERS
  10012. C       MC=NUMBER OF COLUMNS IN MATRIX A
  10013. C       MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A
  10014. C       ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A
  10015. C       MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS
  10016. C       MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A
  10017. C       MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A
  10018. C       NM=NUMBER OF ELEMENTS IN MATRIX R
  10019. 3    IF(MC-M)5,5,4
  10020. 4    MC=M
  10021. 5    MU=MC-MUD-1
  10022.     ML=MC-MLD-1
  10023.     MR=M-ML
  10024.     MZ=(MU*(MU+1))/2
  10025.     MA=M*MC-(ML*(ML+1))/2
  10026.     NM=N*M
  10027. C
  10028. C    MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT
  10029. C    (NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS)
  10030.     IER=0
  10031.     PIV=0.D0
  10032.     IF(MLD)14,14,6
  10033. 6    JJ=MA
  10034.     J=MA-MZ
  10035.     KST=J
  10036.     DO 9 K=1,KST
  10037.     TB=A(J)
  10038.     A(JJ)=TB
  10039.     TB=DABS(TB)
  10040.     IF(TB-PIV)8,8,7
  10041. 7    PIV=TB
  10042. 8    J=J-1
  10043. 9    JJ=JJ-1
  10044. C
  10045. C    INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0)
  10046.     IF(MZ)14,14,10
  10047. 10    JJ=1
  10048.     J=1+MZ
  10049.     IC=1+MUD
  10050.     DO 13 I=1,MU
  10051.     DO 12 K=1,MC
  10052.     A(JJ)=0.D0
  10053.     IF(K-IC)11,11,12
  10054. 11    A(JJ)=A(J)
  10055.     J=J+1
  10056. 12    JJ=JJ+1
  10057. 13    IC=IC+1
  10058. C
  10059. C    GENERATE TEST VALUE FOR SINGULARITY
  10060. 14    TOL=EPS*PIV
  10061. C
  10062. C
  10063. C    START DECOMPOSITION LOOP
  10064.     KST=1
  10065.     IDST=MC
  10066.     IC=MC-1
  10067.     DO 38 K=1,M
  10068.     IF(K-MR-1)16,16,15
  10069. 15    IDST=IDST-1
  10070. 16    ID=IDST
  10071.     ILR=K+MLD
  10072.     IF(ILR-M)18,18,17
  10073. 17    ILR=M
  10074. 18    II=KST
  10075. C
  10076. C    PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR)
  10077.     PIV=0.D0
  10078.     DO 22 I=K,ILR
  10079.     TB=DABS(A(II))
  10080.     IF(TB-PIV)20,20,19
  10081. 19    PIV=TB
  10082.     J=I
  10083.     JJ=II
  10084. 20    IF(I-MR)22,22,21
  10085. 21    ID=ID-1
  10086. 22    II=II+ID
  10087. C
  10088. C    TEST ON SINGULARITY
  10089.     IF(PIV)47,47,23
  10090. 23    IF(IER)26,24,26
  10091. 24    IF(PIV-TOL)25,25,26
  10092. 25    IER=K-1
  10093. 26    PIV=1.D0/A(JJ)
  10094. C
  10095. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  10096.     ID=J-K
  10097.     DO 27 I=K,NM,M
  10098.     II=I+ID
  10099.     TB=PIV*R(II)
  10100.     R(II)=R(I)
  10101. 27    R(I)=TB
  10102. C
  10103. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A
  10104.     II=KST
  10105.     J=JJ+IC
  10106.     DO 28 I=JJ,J
  10107.     TB=PIV*A(I)
  10108.     A(I)=A(II)
  10109.     A(II)=TB
  10110. 28    II=II+1
  10111. C
  10112. C    ELEMENT REDUCTION
  10113.     IF(K-ILR)29,34,34
  10114. 29    ID=KST
  10115.     II=K+1
  10116.     MU=KST+1
  10117.     MZ=KST+IC
  10118.     DO 33 I=II,ILR
  10119. C
  10120. C    IN MATRIX A
  10121.     ID=ID+MC
  10122.     JJ=I-MR-1
  10123.     IF(JJ)31,31,30
  10124. 30    ID=ID-JJ
  10125. 31    PIV=-A(ID)
  10126.     J=ID+1
  10127.     DO 32 JJ=MU,MZ
  10128.     A(J-1)=A(J)+PIV*A(JJ)
  10129. 32    J=J+1
  10130.     A(J-1)=0.D0
  10131. C
  10132. C    IN MATRIX R
  10133.     J=K
  10134.     DO 33 JJ=I,NM,M
  10135.     R(JJ)=R(JJ)+PIV*R(J)
  10136. 33    J=J+M
  10137. 34    KST=KST+MC
  10138.     IF(ILR-MR)36,35,35
  10139. 35    IC=IC-1
  10140. 36    ID=K-MR
  10141.     IF(ID)38,38,37
  10142. 37    KST=KST-ID
  10143. 38    CONTINUE
  10144. C    END OF DECOMPOSITION LOOP
  10145. C
  10146. C
  10147. C    BACK SUBSTITUTION
  10148.     IF(MC-1)46,46,39
  10149. 39    IC=2
  10150.     KST=MA+ML-MC+2
  10151.     II=M
  10152.     DO 45 I=2,M
  10153.     KST=KST-MC
  10154.     II=II-1
  10155.     J=II-MR
  10156.     IF(J)41,41,40
  10157. 40    KST=KST+J
  10158. 41    DO 43 J=II,NM,M
  10159.     TB=R(J)
  10160.     MZ=KST+IC-2
  10161.     ID=J
  10162.     DO 42 JJ=KST,MZ
  10163.     ID=ID+1
  10164. 42    TB=TB-A(JJ)*R(ID)
  10165. 43    R(J)=TB
  10166.     IF(IC-MC)44,45,45
  10167. 44    IC=IC+1
  10168. 45    CONTINUE
  10169. 46    RETURN
  10170. C
  10171. C
  10172. C    ERROR RETURN
  10173. 47    IER=-1
  10174.     RETURN
  10175.     END
  10176. C
  10177. C    ..................................................................
  10178. C
  10179. C       SUBROUTINE DGELG
  10180. C
  10181. C       PURPOSE
  10182. C          TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS.
  10183. C
  10184. C       USAGE
  10185. C          CALL DGELG(R,A,M,N,EPS,IER)
  10186. C
  10187. C       DESCRIPTION OF PARAMETERS
  10188. C          R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
  10189. C                   (DESTROYED). ON RETURN R CONTAINS THE SOLUTIONS
  10190. C                   OF THE EQUATIONS.
  10191. C          A      - DOUBLE PRECISION M BY M COEFFICIENT MATRIX
  10192. C                   (DESTROYED).
  10193. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  10194. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  10195. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  10196. C                   RELATIVE TOLERANCE FOR TEST ON LOSS OF
  10197. C                   SIGNIFICANCE.
  10198. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  10199. C                   IER=0  - NO ERROR,
  10200. C                   IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
  10201. C                            PIVOT ELEMENT AT ANY ELIMINATION STEP
  10202. C                            EQUAL TO 0,
  10203. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  10204. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  10205. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  10206. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  10207. C                            ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
  10208. C
  10209. C       REMARKS
  10210. C          INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE
  10211. C          IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN
  10212. C          SOLUTION MATRIX R IS STORED COLUMNWISE TOO.
  10213. C          THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
  10214. C          GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
  10215. C          ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
  10216. C          INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
  10217. C          SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
  10218. C          INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
  10219. C          GIVEN IN CASE M=1.
  10220. C
  10221. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  10222. C          NONE
  10223. C
  10224. C       METHOD
  10225. C          SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
  10226. C          COMPLETE PIVOTING.
  10227. C
  10228. C    ..................................................................
  10229. C
  10230.     SUBROUTINE DGELG(R,A,M,N,EPS,IER)
  10231. C
  10232. C
  10233.     DIMENSION A(1),R(1)
  10234.     DOUBLE PRECISION R,A,PIV,TB,TOL,PIVI
  10235.     IF(M)23,23,1
  10236. C
  10237. C    SEARCH FOR GREATEST ELEMENT IN MATRIX A
  10238. 1    IER=0
  10239.     PIV=0.D0
  10240.     MM=M*M
  10241.     NM=N*M
  10242.     DO 3 L=1,MM
  10243.     TB=DABS(A(L))
  10244.     IF(TB-PIV)3,3,2
  10245. 2    PIV=TB
  10246.     I=L
  10247. 3    CONTINUE
  10248.     TOL=EPS*PIV
  10249. C    A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
  10250. C
  10251. C
  10252. C    START ELIMINATION LOOP
  10253.     LST=1
  10254.     DO 17 K=1,M
  10255. C
  10256. C    TEST ON SINGULARITY
  10257.     IF(PIV)23,23,4
  10258. 4    IF(IER)7,5,7
  10259. 5    IF(PIV-TOL)6,6,7
  10260. 6    IER=K-1
  10261. 7    PIVI=1.D0/A(I)
  10262.     J=(I-1)/M
  10263.     I=I-J*M-K
  10264.     J=J+1-K
  10265. C    I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT
  10266. C
  10267. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  10268.     DO 8 L=K,NM,M
  10269.     LL=L+I
  10270.     TB=PIVI*R(LL)
  10271.     R(LL)=R(L)
  10272. 8    R(L)=TB
  10273. C
  10274. C    IS ELIMINATION TERMINATED
  10275.     IF(K-M)9,18,18
  10276. C
  10277. C    COLUMN INTERCHANGE IN MATRIX A
  10278. 9    LEND=LST+M-K
  10279.     IF(J)12,12,10
  10280. 10    II=J*M
  10281.     DO 11 L=LST,LEND
  10282.     TB=A(L)
  10283.     LL=L+II
  10284.     A(L)=A(LL)
  10285. 11    A(LL)=TB
  10286. C
  10287. C    ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A
  10288. 12    DO 13 L=LST,MM,M
  10289.     LL=L+I
  10290.     TB=PIVI*A(LL)
  10291.     A(LL)=A(L)
  10292. 13    A(L)=TB
  10293. C
  10294. C    SAVE COLUMN INTERCHANGE INFORMATION
  10295.     A(LST)=J
  10296. C
  10297. C    ELEMENT REDUCTION AND NEXT PIVOT SEARCH
  10298.     PIV=0.D0
  10299.     LST=LST+1
  10300.     J=0
  10301.     DO 16 II=LST,LEND
  10302.     PIVI=-A(II)
  10303.     IST=II+M
  10304.     J=J+1
  10305.     DO 15 L=IST,MM,M
  10306.     LL=L-J
  10307.     A(L)=A(L)+PIVI*A(LL)
  10308.     TB=DABS(A(L))
  10309.     IF(TB-PIV)15,15,14
  10310. 14    PIV=TB
  10311.     I=L
  10312. 15    CONTINUE
  10313.     DO 16 L=K,NM,M
  10314.     LL=L+J
  10315. 16    R(LL)=R(LL)+PIVI*R(L)
  10316. 17    LST=LST+M
  10317. C    END OF ELIMINATION LOOP
  10318. C
  10319. C
  10320. C    BACK SUBSTITUTION AND BACK INTERCHANGE
  10321. 18    IF(M-1)23,22,19
  10322. 19    IST=MM+M
  10323.     LST=M+1
  10324.     DO 21 I=2,M
  10325.     II=LST-I
  10326.     IST=IST-LST
  10327.     L=IST-M
  10328.     L=A(L)+.5D0
  10329.     DO 21 J=II,NM,M
  10330.     TB=R(J)
  10331.     LL=J
  10332.     DO 20 K=IST,MM,M
  10333.     LL=LL+1
  10334. 20    TB=TB-A(K)*R(LL)
  10335.     K=J+L
  10336.     R(J)=R(K)
  10337. 21    R(K)=TB
  10338. 22    RETURN
  10339. C
  10340. C
  10341. C    ERROR RETURN
  10342. 23    IER=-1
  10343.     RETURN
  10344.     END
  10345. C
  10346. C    ..................................................................
  10347. C
  10348. C       SUBROUTINE DGELS
  10349. C
  10350. C       PURPOSE
  10351. C          TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH
  10352. C          SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH
  10353. C          IS ASSUMED TO BE STORED COLUMNWISE.
  10354. C
  10355. C       USAGE
  10356. C          CALL DGELS(R,A,M,N,EPS,IER,AUX)
  10357. C
  10358. C       DESCRIPTION OF PARAMETERS
  10359. C          R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
  10360. C                   (DESTROYED). ON RETURN R CONTAINS THE SOLUTION OF
  10361. C                   THE EQUATIONS.
  10362. C          A      - UPPER TRIANGULAR PART OF THE SYMMETRIC DOUBLE
  10363. C                   PRECISION M BY M COEFFICIENT MATRIX.  (DESTROYED)
  10364. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  10365. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  10366. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
  10367. C                   RELATIVE TOLERANCE FOR TEST ON LOSS OF
  10368. C                   SIGNIFICANCE.
  10369. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  10370. C                   IER=0  - NO ERROR,
  10371. C                   IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
  10372. C                            PIVOT ELEMENT AT ANY ELIMINATION STEP
  10373. C                            EQUAL TO 0,
  10374. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  10375. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  10376. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  10377. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  10378. C                            ABSOLUTELY GREATEST MAIN DIAGONAL
  10379. C                            ELEMENT OF MATRIX A.
  10380. C          AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY
  10381. C                   WITH DIMENSION M-1.
  10382. C
  10383. C       REMARKS
  10384. C          UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED
  10385. C          COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT
  10386. C          HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE
  10387. C          LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE
  10388. C          TOO.
  10389. C          THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
  10390. C          GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
  10391. C          ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
  10392. C          INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
  10393. C          SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
  10394. C          INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
  10395. C          GIVEN IN CASE M=1.
  10396. C          ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT
  10397. C          MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS
  10398. C          ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE DGELG (WHICH
  10399. C          WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION.
  10400. C
  10401. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  10402. C          NONE
  10403. C
  10404. C       METHOD
  10405. C          SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
  10406. C          PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE
  10407. C          SYMMETRY IN REMAINING COEFFICIENT MATRICES.
  10408. C
  10409. C    ..................................................................
  10410. C
  10411.     SUBROUTINE DGELS(R,A,M,N,EPS,IER,AUX)
  10412. C
  10413. C
  10414.     DIMENSION A(1),R(1),AUX(1)
  10415.     DOUBLE PRECISION R,A,AUX,PIV,TB,TOL,PIVI
  10416.     IF(M)24,24,1
  10417. C
  10418. C    SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT
  10419. 1    IER=0
  10420.     PIV=0.D0
  10421.     L=0
  10422.     DO 3 K=1,M
  10423.     L=L+K
  10424.     TB=DABS(A(L))
  10425.     IF(TB-PIV)3,3,2
  10426. 2    PIV=TB
  10427.     I=L
  10428.     J=K
  10429. 3    CONTINUE
  10430.     TOL=EPS*PIV
  10431. C    MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT.
  10432. C    PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
  10433. C
  10434. C
  10435. C    START ELIMINATION LOOP
  10436.     LST=0
  10437.     NM=N*M
  10438.     LEND=M-1
  10439.     DO 18 K=1,M
  10440. C
  10441. C    TEST ON USEFULNESS OF SYMMETRIC ALGORITHM
  10442.     IF(PIV)24,24,4
  10443. 4    IF(IER)7,5,7
  10444. 5    IF(PIV-TOL)6,6,7
  10445. 6    IER=K-1
  10446. 7    LT=J-K
  10447.     LST=LST+K
  10448. C
  10449. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  10450.     PIVI=1.D0/A(I)
  10451.     DO 8 L=K,NM,M
  10452.     LL=L+LT
  10453.     TB=PIVI*R(LL)
  10454.     R(LL)=R(L)
  10455. 8    R(L)=TB
  10456. C
  10457. C    IS ELIMINATION TERMINATED
  10458.     IF(K-M)9,19,19
  10459. C
  10460. C    ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A.
  10461. C    ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX.
  10462. 9    LR=LST+(LT*(K+J-1))/2
  10463.     LL=LR
  10464.     L=LST
  10465.     DO 14 II=K,LEND
  10466.     L=L+II
  10467.     LL=LL+1
  10468.     IF(L-LR)12,10,11
  10469. 10    A(LL)=A(LST)
  10470.     TB=A(L)
  10471.     GO TO 13
  10472. 11    LL=L+LT
  10473. 12    TB=A(LL)
  10474.     A(LL)=A(L)
  10475. 13    AUX(II)=TB
  10476. 14    A(L)=PIVI*TB
  10477. C
  10478. C    SAVE COLUMN INTERCHANGE INFORMATION
  10479.     A(LST)=LT
  10480. C
  10481. C    ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT
  10482.     PIV=0.D0
  10483.     LLST=LST
  10484.     LT=0
  10485.     DO 18 II=K,LEND
  10486.     PIVI=-AUX(II)
  10487.     LL=LLST
  10488.     LT=LT+1
  10489.     DO 15 LLD=II,LEND
  10490.     LL=LL+LLD
  10491.     L=LL+LT
  10492. 15    A(L)=A(L)+PIVI*A(LL)
  10493.     LLST=LLST+II
  10494.     LR=LLST+LT
  10495.     TB=DABS(A(LR))
  10496.     IF(TB-PIV)17,17,16
  10497. 16    PIV=TB
  10498.     I=LR
  10499.     J=II+1
  10500. 17    DO 18 LR=K,NM,M
  10501.     LL=LR+LT
  10502. 18    R(LL)=R(LL)+PIVI*R(LR)
  10503. C    END OF ELIMINATION LOOP
  10504. C
  10505. C
  10506. C    BACK SUBSTITUTION AND BACK INTERCHANGE
  10507. 19    IF(LEND)24,23,20
  10508. 20    II=M
  10509.     DO 22 I=2,M
  10510.     LST=LST-II
  10511.     II=II-1
  10512.     L=A(LST)+.5D0
  10513.     DO 22 J=II,NM,M
  10514.     TB=R(J)
  10515.     LL=J
  10516.     K=LST
  10517.     DO 21 LT=II,LEND
  10518.     LL=LL+1
  10519.     K=K+LT
  10520. 21    TB=TB-A(K)*R(LL)
  10521.     K=J+L
  10522.     R(J)=R(K)
  10523. 22    R(K)=TB
  10524. 23    RETURN
  10525. C
  10526. C
  10527. C    ERROR RETURN
  10528. 24    IER=-1
  10529.     RETURN
  10530.     END
  10531. C
  10532. C    ..................................................................
  10533. C
  10534. C       SUBROUTINE DGT3
  10535. C
  10536. C       PURPOSE
  10537. C          TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF
  10538. C          ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES.
  10539. C
  10540. C       USAGE
  10541. C          CALL DGT3(X,Y,Z,NDIM,IER)
  10542. C
  10543. C       DESCRIPTION OF PARAMETERS
  10544. C          X     -  GIVEN VECTOR OF ARGUMENT VALUES (DIMENSION NDIM)
  10545. C          Y     -  GIVEN VECTOR OF FUNCTION VALUES CORRESPONDING TO X
  10546. C                   (DIMENSION NDIM)
  10547. C          Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
  10548. C                   NDIM)
  10549. C          NDIM  -  DIMENSION OF VECTORS X,Y AND Z
  10550. C          IER   -  RESULTING ERROR PARAMETER
  10551. C                   IER  = -1  - NDIM IS LESS THAN 3
  10552. C                   IER  =  0  - NO ERROR
  10553. C                   IER POSITIVE  - X(IER) = X(IER-1) OR X(IER) =
  10554. C                                   X(IER-2)
  10555. C
  10556. C       REMARKS
  10557. C          (1)   IF IER = -1,2,3, THEN THERE IS NO COMPUTATION.
  10558. C          (2)   IF IER =  4,...,N, THEN THE DERIVATIVE VALUES Z(1)
  10559. C                ,..., Z(IER-1) HAVE BEEN COMPUTED.
  10560. C          (3)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
  10561. C                X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  10562. C
  10563. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  10564. C          NONE
  10565. C
  10566. C       METHOD
  10567. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
  10568. C          DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
  10569. C          POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
  10570. C          (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B.,
  10571. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  10572. C          TORONTO/LONDON, 1956, PP. 64-68.)
  10573. C
  10574. C    ..................................................................
  10575. C
  10576.     SUBROUTINE DGT3(X,Y,Z,NDIM,IER)
  10577. C
  10578. C
  10579.     DIMENSION X(1),Y(1),Z(1)
  10580. C
  10581. C       TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3
  10582.     IER=-1
  10583.     IF(NDIM-3)8,1,1
  10584. C
  10585. C       PREPARE DIFFERENTIATION LOOP
  10586. 1    A=X(1)
  10587.     B=Y(1)
  10588.     I=2
  10589.     DY2=X(2)-A
  10590.     IF(DY2)2,9,2
  10591. 2    DY2=(Y(2)-B)/DY2
  10592. C
  10593. C       START DIFFERENTIATION LOOP
  10594.     DO 6 I=3,NDIM
  10595.     A=X(I)-A
  10596.     IF(A)3,9,3
  10597. 3    A=(Y(I)-B)/A
  10598.     B=X(I)-X(I-1)
  10599.     IF(B)4,9,4
  10600. 4    DY1=DY2
  10601.     DY2=(Y(I)-Y(I-1))/B
  10602.     DY3=A
  10603.     A=X(I-1)
  10604.     B=Y(I-1)
  10605.     IF(I-3)5,5,6
  10606. 5    Z(1)=DY1+DY3-DY2
  10607. 6    Z(I-1)=DY1+DY2-DY3
  10608. C       END DIFFERENTIATION LOOP
  10609. C
  10610. C       NORMAL EXIT
  10611.     IER=0
  10612.     I=NDIM
  10613. 7    Z(I)=DY2+DY3-DY1
  10614. 8    RETURN
  10615. C
  10616. C       ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS
  10617. 9    IER=I
  10618.     I=I-1
  10619.     IF(I-2)8,8,7
  10620.     END
  10621. C
  10622. C    ..................................................................
  10623. C
  10624. C       SUBROUTINE DHARM
  10625. C
  10626. C       PURPOSE
  10627. C          PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX
  10628. C          DOUBLE PRECISION,THREE DIMENSIONAL ARRAY
  10629. C
  10630. C       USAGE
  10631. C          CALL DHARM(A,M,INV,S,IFSET,IFERR)
  10632. C
  10633. C       DESCRIPTION OF PARAMETERS
  10634. C          A     - A DOUBLE PRECISION VECTOR
  10635. C                  AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL
  10636. C                  ARRAY TO BE TRANSFORMED.  THE REAL PART OF
  10637. C                  A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL
  10638. C                  WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE
  10639. C                  NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC.
  10640. C                  THE IMAGINARY PART IS IN THE CELL IMMEDIATELY
  10641. C                  FOLLOWING.  NOTE THAT THE SUBSCRIPT I1 INCREASES
  10642. C                  MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY.
  10643. C                  AS OUTPUT, A CONTAINS THE COMPLEX FOURIER
  10644. C                  TRANSFORM.  THE NUMBER OF CORE LOCATIONS OF
  10645. C                  ARRAY A IS 2*(N1*N2*N3)
  10646. C          M     - A THREE CELL VECTOR WHICH DETERMINES THE SIZES
  10647. C                  OF THE 3 DIMENSIONS OF THE ARRAY A.   THE SIZE,
  10648. C                  NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3
  10649. C          INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION
  10650. C                  OF DIMENSION ONE FOURTH OF THE QUANTITY
  10651. C                  MAX(N1,N2,N3)
  10652. C                  LOCATIONS OF A, VIZ., (1/8)*2*N1*N2*N3
  10653. C          S     - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES
  10654. C                  WITH DIMENSION THE SAME AS INV
  10655. C          IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS
  10656. C                     0    SET UP SINE AND INV TABLES ONLY
  10657. C                     1    SET UP SINE AND INV TABLES ONLY AND
  10658. C                          CALCULATE FOURIER TRANSFORM
  10659. C                    -1    SET UP SINE AND INV TABLES ONLY AND
  10660. C                          CALCULATE INVERSE FOURIER TRANSFORM (FOR
  10661. C                          THE MEANING OF INVERSE SEE THE EQUATIONS
  10662. C                          UNDER METHOD BELOW)
  10663. C                     2    CALCULATE FOURIER TRANSFORM ONLY (ASSUME
  10664. C                          SINE AND INV TABLES EXIST)
  10665. C                    -2    CALCULATE INVERSE FOURIER TRANSFORM ONLY
  10666. C                          (ASSUME SINE AND INV TABLES EXIST)
  10667. C          IFERR - ERROR INDICATOR.   WHEN IFSET IS 0,+1,-1,
  10668. C                  IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN
  10669. C                  20, I=1,2,3   WHEN IFSET IS 2,-2 , IFERR = 1
  10670. C                  MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE
  10671. C                  ENOUGH OR HAVE NOT BEEN COMPUTED .
  10672. C                  IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE
  10673. C                  CONDITIONS ARE PRESENT
  10674. C
  10675. C       REMARKS
  10676. C          THIS SUBROUTINE IS TO BE USED FOR COMPLEX, DOUBLE PRECISION,
  10677. C          3-DIMENSIONAL ARRAYS IN WHICH EACH DIMENSION IS A POWER OF
  10678. C          2. THE MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN
  10679. C          20, I = 1,2,3.
  10680. C
  10681. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  10682. C          NONE
  10683. C
  10684. C       METHOD
  10685. C          FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX
  10686. C          ARRAY A IS OBTAINED.
  10687. C
  10688. C                 N1-1   N2-1   N3-1                L1   L2   L3
  10689. C    X(J1,J2,J3)=SUM    SUM    SUM    A(K1,K2,K3)*W1  *W2  *W3
  10690. C                 K1=0   K2=0   K3=0
  10691. C
  10692. C                 WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1,
  10693. C                       L2=K2*J2, L3=K3*J3
  10694. C
  10695. C
  10696. C          FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF
  10697. C          COMPLEX ARRAY X IS OBTAINED.
  10698. C
  10699. C    A(K1,K2,K3)=
  10700. C              1      N1-1   N2-1   N3-1                -L1  -L2  -L3
  10701. C          -------- *SUM    SUM    SUM    X(J1,J2,J3)*W1  *W2  *W3
  10702. C          N1*N2*N3   J1=0   J2=0   J3=0
  10703. C
  10704. C
  10705. C          SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE
  10706. C          MACHINE CALCULATION OF COMPLEX FOURIER SERIES',
  10707. C          MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297.
  10708. C
  10709. C    ..................................................................
  10710. C
  10711.     SUBROUTINE DHARM(A,M,INV,S,IFSET,IFERR)
  10712.     DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2)
  10713.     DOUBLE PRECISION A,R,W3,AWI,THETA,ROOT2,S,T,W,W2,FN,AWR
  10714.     EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3)
  10715. 10    IF( IABS(IFSET) - 1) 900,900,12
  10716. 12    MTT=MAX0(M(1),M(2),M(3)) -2
  10717.     ROOT2=DSQRT(2.0D0)
  10718.     IF (MTT-MT ) 14,14,13
  10719. 13    IFERR=1
  10720.     RETURN
  10721. 14    IFERR=0
  10722.     M1=M(1)
  10723.     M2=M(2)
  10724.     M3=M(3)
  10725.     N1=2**M1
  10726.     N2=2**M2
  10727.     N3=2**M3
  10728. 16    IF(IFSET) 18,18,20
  10729. 18    NX= N1*N2*N3
  10730.     FN = NX
  10731.     DO 19 I = 1,NX
  10732.     A(2*I-1) = A(2*I-1)/FN
  10733. 19    A(2*I) = -A(2*I)/FN
  10734. 20    NP(1)=N1*2
  10735.     NP(2)= NP(1)*N2
  10736.     NP(3)=NP(2)*N3
  10737.     DO 250 ID=1,3
  10738.     IL = NP(3)-NP(ID)
  10739.     IL1 = IL+1
  10740.     MI = M(ID)
  10741.     IF (MI)250,250,30
  10742. 30    IDIF=NP(ID)
  10743.     KBIT=NP(ID)
  10744.     MEV = 2*(MI/2)
  10745.     IF (MI - MEV )60,60,40
  10746. C
  10747. C    M IS ODD. DO L=1 CASE
  10748. 40    KBIT=KBIT/2
  10749.     KL=KBIT-2
  10750.     DO 50 I=1,IL1,IDIF
  10751.     KLAST=KL+I
  10752.     DO 50 K=I,KLAST,2
  10753.     KD=K+KBIT
  10754. C
  10755. C    DO ONE STEP WITH L=1,J=0
  10756. C    A(K)=A(K)+A(KD)
  10757. C    A(KD)=A(K)-A(KD)
  10758. C
  10759.     T=A(KD)
  10760.     A(KD)=A(K)-T
  10761.     A(K)=A(K)+T
  10762.     T=A(KD+1)
  10763.     A(KD+1)=A(K+1)-T
  10764. 50    A(K+1)=A(K+1)+T
  10765.     IF (MI - 1)250,250,52
  10766. 52    LFIRST =3
  10767. C
  10768. C    DEF - JLAST = 2**(L-2) -1
  10769.     JLAST=1
  10770.     GO TO 70
  10771. C
  10772. C    M IS EVEN
  10773. 60    LFIRST = 2
  10774.     JLAST=0
  10775. 70    DO 240 L=LFIRST,MI,2
  10776.     JJDIF=KBIT
  10777.     KBIT=KBIT/4
  10778.     KL=KBIT-2
  10779. C
  10780. C    DO FOR J=0
  10781.     DO 80 I=1,IL1,IDIF
  10782.     KLAST=I+KL
  10783.     DO 80 K=I,KLAST,2
  10784.     K1=K+KBIT
  10785.     K2=K1+KBIT
  10786.     K3=K2+KBIT
  10787. C
  10788. C    DO TWO STEPS WITH J=0
  10789. C    A(K)=A(K)+A(K2)
  10790. C    A(K2)=A(K)-A(K2)
  10791. C    A(K1)=A(K1)+A(K3)
  10792. C    A(K3)=A(K1)-A(K3)
  10793. C
  10794. C    A(K)=A(K)+A(K1)
  10795. C    A(K1)=A(K)-A(K1)
  10796. C    A(K2)=A(K2)+A(K3)*I
  10797. C    A(K3)=A(K2)-A(K3)*I
  10798. C
  10799.     T=A(K2)
  10800.     A(K2)=A(K)-T
  10801.     A(K)=A(K)+T
  10802.     T=A(K2+1)
  10803.     A(K2+1)=A(K+1)-T
  10804.     A(K+1)=A(K+1)+T
  10805. C
  10806.     T=A(K3)
  10807.     A(K3)=A(K1)-T
  10808.     A(K1)=A(K1)+T
  10809.     T=A(K3+1)
  10810.     A(K3+1)=A(K1+1)-T
  10811.     A(K1+1)=A(K1+1)+T
  10812. C
  10813.     T=A(K1)
  10814.     A(K1)=A(K)-T
  10815.     A(K)=A(K)+T
  10816.     T=A(K1+1)
  10817.     A(K1+1)=A(K+1)-T
  10818.     A(K+1)=A(K+1)+T
  10819. C
  10820.     R=-A(K3+1)
  10821.     T = A(K3)
  10822.     A(K3)=A(K2)-R
  10823.     A(K2)=A(K2)+R
  10824.     A(K3+1)=A(K2+1)-T
  10825. 80    A(K2+1)=A(K2+1)+T
  10826.     IF (JLAST) 235,235,82
  10827. 82    JJ=JJDIF   +1
  10828. C
  10829. C    DO FOR J=1
  10830.     ILAST= IL +JJ
  10831.     DO 85 I = JJ,ILAST,IDIF
  10832.     KLAST = KL+I
  10833.     DO 85 K=I,KLAST,2
  10834.     K1 = K+KBIT
  10835.     K2 = K1+KBIT
  10836.     K3 = K2+KBIT
  10837. C
  10838. C    LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I,
  10839. C    A(K)=A(K)+A(K2)*I
  10840. C    A(K2)=A(K)-A(K2)*I
  10841. C    A(K1)=A(K1)*W+A(K3)*W3
  10842. C    A(K3)=A(K1)*W-A(K3)*W3
  10843. C
  10844. C    A(K)=A(K)+A(K1)
  10845. C    A(K1)=A(K)-A(K1)
  10846. C    A(K2)=A(K2)+A(K3)*I
  10847. C    A(K3)=A(K2)-A(K3)*I
  10848. C
  10849.     R =-A(K2+1)
  10850.     T = A(K2)
  10851.     A(K2) = A(K)-R
  10852.     A(K) = A(K)+R
  10853.     A(K2+1)=A(K+1)-T
  10854.     A(K+1)=A(K+1)+T
  10855. C
  10856.     AWR=A(K1)-A(K1+1)
  10857.     AWI = A(K1+1)+A(K1)
  10858.     R=-A(K3)-A(K3+1)
  10859.     T=A(K3)-A(K3+1)
  10860.     A(K3)=(AWR-R)/ROOT2
  10861.     A(K3+1)=(AWI-T)/ROOT2
  10862.     A(K1)=(AWR+R)/ROOT2
  10863.     A(K1+1)=(AWI+T)/ROOT2
  10864.     T= A(K1)
  10865.     A(K1)=A(K)-T
  10866.     A(K)=A(K)+T
  10867.     T=A(K1+1)
  10868.     A(K1+1)=A(K+1)-T
  10869.     A(K+1)=A(K+1)+T
  10870.     R=-A(K3+1)
  10871.     T=A(K3)
  10872.     A(K3)=A(K2)-R
  10873.     A(K2)=A(K2)+R
  10874.     A(K3+1)=A(K2+1)-T
  10875. 85    A(K2+1)=A(K2+1)+T
  10876.     IF(JLAST-1) 235,235,90
  10877. 90    JJ= JJ + JJDIF
  10878. C
  10879. C    NOW DO THE REMAINING J'S
  10880.     DO 230 J=2,JLAST
  10881. C
  10882. C    FETCH W'S
  10883. C    DEF- W=W**INV(J), W2=W**2, W3=W**3
  10884. 96    I=INV(J+1)
  10885. 98    IC=NT-I
  10886.     W(1)=S(IC)
  10887.     W(2)=S(I)
  10888.     I2=2*I
  10889.     I2C=NT-I2
  10890.     IF(I2C)120,110,100
  10891. C
  10892. C    2*I IS IN FIRST QUADRANT
  10893. 100    W2(1)=S(I2C)
  10894.     W2(2)=S(I2)
  10895.     GO TO 130
  10896. 110    W2(1)=0.
  10897.     W2(2)=1.
  10898.     GO TO 130
  10899. C
  10900. C    2*I IS IN SECOND QUADRANT
  10901. 120    I2CC = I2C+NT
  10902.     I2C=-I2C
  10903.     W2(1)=-S(I2C)
  10904.     W2(2)=S(I2CC)
  10905. 130    I3=I+I2
  10906.     I3C=NT-I3
  10907.     IF(I3C)160,150,140
  10908. C
  10909. C    I3 IN FIRST QUADRANT
  10910. 140    W3(1)=S(I3C)
  10911.     W3(2)=S(I3)
  10912.     GO TO 200
  10913. 150    W3(1)=0.
  10914.     W3(2)=1.
  10915.     GO TO 200
  10916. C
  10917. 160    I3CC=I3C+NT
  10918.     IF(I3CC)190,180,170
  10919. C
  10920. C    I3 IN SECOND QUADRANT
  10921. 170    I3C=-I3C
  10922.     W3(1)=-S(I3C)
  10923.     W3(2)=S(I3CC)
  10924.     GO TO 200
  10925. 180    W3(1)=-1.
  10926.     W3(2)=0.
  10927.     GO TO 200
  10928. C
  10929. C    3*I IN THIRD QUADRANT
  10930. 190    I3CCC=NT+I3CC
  10931.     I3CC = -I3CC
  10932.     W3(1)=-S(I3CCC)
  10933.     W3(2)=-S(I3CC)
  10934. 200    ILAST=IL+JJ
  10935.     DO 220 I=JJ,ILAST,IDIF
  10936.     KLAST=KL+I
  10937.     DO 220 K=I,KLAST,2
  10938.     K1=K+KBIT
  10939.     K2=K1+KBIT
  10940.     K3=K2+KBIT
  10941. C
  10942. C    DO TWO STEPS WITH J NOT 0
  10943. C    A(K)=A(K)+A(K2)*W2
  10944. C    A(K2)=A(K)-A(K2)*W2
  10945. C    A(K1)=A(K1)*W+A(K3)*W3
  10946. C    A(K3)=A(K1)*W-A(K3)*W3
  10947. C
  10948. C    A(K)=A(K)+A(K1)
  10949. C    A(K1)=A(K)-A(K1)
  10950. C    A(K2)=A(K2)+A(K3)*I
  10951. C    A(K3)=A(K2)-A(K3)*I
  10952. C
  10953.     R=A(K2)*W2(1)-A(K2+1)*W2(2)
  10954.     T=A(K2)*W2(2)+A(K2+1)*W2(1)
  10955.     A(K2)=A(K)-R
  10956.     A(K)=A(K)+R
  10957.     A(K2+1)=A(K+1)-T
  10958.     A(K+1)=A(K+1)+T
  10959. C
  10960.     R=A(K3)*W3(1)-A(K3+1)*W3(2)
  10961.     T=A(K3)*W3(2)+A(K3+1)*W3(1)
  10962.     AWR=A(K1)*W(1)-A(K1+1)*W(2)
  10963.     AWI=A(K1)*W(2)+A(K1+1)*W(1)
  10964.     A(K3)=AWR-R
  10965.     A(K3+1)=AWI-T
  10966.     A(K1)=AWR+R
  10967.     A(K1+1)=AWI+T
  10968.     T=A(K1)
  10969.     A(K1)=A(K)-T
  10970.     A(K)=A(K)+T
  10971.     T=A(K1+1)
  10972.     A(K1+1)=A(K+1)-T
  10973.     A(K+1)=A(K+1)+T
  10974.     R=-A(K3+1)
  10975.     T=A(K3)
  10976.     A(K3)=A(K2)-R
  10977.     A(K2)=A(K2)+R
  10978.     A(K3+1)=A(K2+1)-T
  10979. 220    A(K2+1)=A(K2+1)+T
  10980. C    END OF I AND K LOOPS
  10981. C
  10982. 230    JJ=JJDIF+JJ
  10983. C    END OF J-LOOP
  10984. C
  10985. 235    JLAST=4*JLAST+3
  10986. 240    CONTINUE
  10987. C    END OF  L  LOOP
  10988. C
  10989. 250    CONTINUE
  10990. C    END OF  ID  LOOP
  10991. C
  10992. C    WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE
  10993. C    BIT-REVERSED.  THE FOLLOWING ROUTINE PUTS THEM IN ORDER
  10994.     NTSQ=NT*NT
  10995.     M3MT=M3-MT
  10996. 350    IF(M3MT) 370,360,360
  10997. C
  10998. C    M3 GR. OR EQ. MT
  10999. 360    IGO3=1
  11000.     N3VNT=N3/NT
  11001.     MINN3=NT
  11002.     GO TO 380
  11003. C
  11004. C    M3 LESS THAN MT
  11005. 370    IGO3=2
  11006.     N3VNT=1
  11007.     NTVN3=NT/N3
  11008.     MINN3=N3
  11009. 380    JJD3 = NTSQ/N3
  11010.     M2MT=M2-MT
  11011. 450    IF (M2MT)470,460,460
  11012. C
  11013. C    M2 GR. OR EQ. MT
  11014. 460    IGO2=1
  11015.     N2VNT=N2/NT
  11016.     MINN2=NT
  11017.     GO TO 480
  11018. C
  11019. C    M2 LESS THAN MT
  11020. 470    IGO2 = 2
  11021.     N2VNT=1
  11022.     NTVN2=NT/N2
  11023.     MINN2=N2
  11024. 480    JJD2=NTSQ/N2
  11025.     M1MT=M1-MT
  11026. 550    IF(M1MT)570,560,560
  11027. C
  11028. C    M1 GR. OR EQ. MT
  11029. 560    IGO1=1
  11030.     N1VNT=N1/NT
  11031.     MINN1=NT
  11032.     GO TO 580
  11033. C
  11034. C    M1 LESS THAN MT
  11035. 570    IGO1=2
  11036.     N1VNT=1
  11037.     NTVN1=NT/N1
  11038.     MINN1=N1
  11039. 580    JJD1=NTSQ/N1
  11040. 600    JJ3=1
  11041.     J=1
  11042.     DO 880 JPP3=1,N3VNT
  11043.     IPP3=INV(JJ3)
  11044.     DO 870 JP3=1,MINN3
  11045.     GO TO (610,620),IGO3
  11046. 610    IP3=INV(JP3)*N3VNT
  11047.     GO TO 630
  11048. 620    IP3=INV(JP3)/NTVN3
  11049. 630    I3=(IPP3+IP3)*N2
  11050. 700    JJ2=1
  11051.     DO 870 JPP2=1,N2VNT
  11052.     IPP2=INV(JJ2)+I3
  11053.     DO 860 JP2=1,MINN2
  11054.     GO TO (710,720),IGO2
  11055. 710    IP2=INV(JP2)*N2VNT
  11056.     GO TO 730
  11057. 720    IP2=INV(JP2)/NTVN2
  11058. 730    I2=(IPP2+IP2)*N1
  11059. 800    JJ1=1
  11060.     DO 860 JPP1=1,N1VNT
  11061.     IPP1=INV(JJ1)+I2
  11062.     DO 850 JP1=1,MINN1
  11063.     GO TO (810,820),IGO1
  11064. 810    IP1=INV(JP1)*N1VNT
  11065.     GO TO 830
  11066. 820    IP1=INV(JP1)/NTVN1
  11067. 830    I=2*(IPP1+IP1)+1
  11068.     IF (J-I) 840,850,850
  11069. 840    T=A(I)
  11070.     A(I)=A(J)
  11071.     A(J)=T
  11072.     T=A(I+1)
  11073.     A(I+1)=A(J+1)
  11074.     A(J+1)=T
  11075. 850    J=J+2
  11076. 860    JJ1=JJ1+JJD1
  11077. C
  11078. 870    JJ2=JJ2+JJD2
  11079. C    END OF JPP2 AND JP3 LOOPS
  11080. C
  11081. 880    JJ3 = JJ3+JJD3
  11082. C    END OF JPP3 LOOP
  11083. C
  11084. 890    IF(IFSET)891,895,895
  11085. 891    DO 892 I = 1,NX
  11086. 892    A(2*I) = -A(2*I)
  11087. 895    RETURN
  11088. C
  11089. C    THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES.
  11090. C
  11091. 900    MT=MAX0(M(1),M(2),M(3)) -2
  11092.     MT = MAX0(2,MT)
  11093. 904    IF (MT-18) 906,906,13
  11094. 906    IFERR=0
  11095.     NT=2**MT
  11096.     NTV2=NT/2
  11097. C
  11098. C    SET UP SIN TABLE
  11099. C    THETA=PIE/2**(L+1) FOR L=1
  11100. 910    THETA=.7853981633974483
  11101. C
  11102. C    JSTEP=2**(MT-L+1) FOR L=1
  11103.     JSTEP=NT
  11104. C
  11105. C    JDIF=2**(MT-L) FOR L=1
  11106.     JDIF=NTV2
  11107.     S(JDIF)=DSIN(THETA)
  11108.     DO 950 L=2,MT
  11109.     THETA=THETA/2.0D0
  11110.     JSTEP2=JSTEP
  11111.     JSTEP=JDIF
  11112.     JDIF=JSTEP/2
  11113.     S(JDIF)=DSIN(THETA)
  11114.     JC1=NT-JDIF
  11115.     S(JC1)=DCOS(THETA)
  11116.     JLAST=NT-JSTEP2
  11117.     IF(JLAST - JSTEP) 950,920,920
  11118. 920    DO 940 J=JSTEP,JLAST,JSTEP
  11119.     JC=NT-J
  11120.     JD=J+JDIF
  11121. 940    S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC)
  11122. 950    CONTINUE
  11123. C
  11124. C    SET UP INV(J) TABLE
  11125. C
  11126. 960    MTLEXP=NTV2
  11127. C
  11128. C    MTLEXP=2**(MT-L). FOR L=1
  11129.     LM1EXP=1
  11130. C
  11131. C    LM1EXP=2**(L-1). FOR L=1
  11132.     INV(1)=0
  11133.     DO 980 L=1,MT
  11134.     INV(LM1EXP+1) = MTLEXP
  11135.     DO 970 J=2,LM1EXP
  11136.     JJ=J+LM1EXP
  11137. 970    INV(JJ)=INV(J)+MTLEXP
  11138.     MTLEXP=MTLEXP/2
  11139. 980    LM1EXP=LM1EXP*2
  11140. 982    IF(IFSET)12,895,12
  11141.     END
  11142. C
  11143. C    ..................................................................
  11144. C
  11145. C       SUBROUTINE DHEP
  11146. C
  11147. C       PURPOSE
  11148. C          COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X)
  11149. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  11150. C
  11151. C       USAGE
  11152. C          CALL DHEP(Y,X,N)
  11153. C
  11154. C       DESCRIPTION OF PARAMETERS
  11155. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  11156. C                  OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N
  11157. C                  FOR GIVEN ARGUMENT X.
  11158. C                  DOUBLE PRECISION VECTOR.
  11159. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  11160. C          X     - ARGUMENT OF HERMITE POLYNOMIAL
  11161. C                  DOUBLE PRECISION VARIABLE.
  11162. C          N     - ORDER OF HERMITE POLYNOMIAL
  11163. C
  11164. C       REMARKS
  11165. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  11166. C
  11167. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  11168. C          NONE
  11169. C
  11170. C       METHOD
  11171. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  11172. C          HERMITE POLYNOMIALS H(N,X)
  11173. C          H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X))
  11174. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  11175. C          THE SECOND IS THE ARGUMENT.
  11176. C          STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X.
  11177. C
  11178. C    ..................................................................
  11179. C
  11180.     SUBROUTINE DHEP(Y,X,N)
  11181. C
  11182.     DIMENSION Y(1)
  11183.     DOUBLE PRECISION Y,X,F
  11184. C
  11185. C       TEST OF ORDER
  11186.     Y(1)=1.D0
  11187.     IF(N)1,1,2
  11188. 1    RETURN
  11189. C
  11190. 2    Y(2)=X+X
  11191.     IF(N-1)1,1,3
  11192. C
  11193. 3    DO 4 I=2,N
  11194.     F=X*Y(I)-DFLOAT(I-1)*Y(I-1)
  11195. 4    Y(I+1)=F+F
  11196.     RETURN
  11197.     END
  11198. C
  11199. C    ..................................................................
  11200. C
  11201. C       SUBROUTINE DHEPS
  11202. C
  11203. C       PURPOSE
  11204. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE
  11205. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  11206. C
  11207. C       USAGE
  11208. C          CALL DHEPS(Y,X,C,N)
  11209. C
  11210. C       DESCRIPTION OF PARAMETERS
  11211. C          Y     - RESULT VALUE
  11212. C                  DOUBLE PRECISION VARIABLE
  11213. C          X     - ARGUMENT VALUE
  11214. C                  DOUBLE PRECISION VARIABLE
  11215. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  11216. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  11217. C                  DOUBLE PRECISION VECTOR
  11218. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  11219. C
  11220. C       REMARKS
  11221. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  11222. C
  11223. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  11224. C          NONE
  11225. C
  11226. C       METHOD
  11227. C          DEFINITION
  11228. C          Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
  11229. C          EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
  11230. C          USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS
  11231. C          H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)).
  11232. C
  11233. C    ..................................................................
  11234. C
  11235.     SUBROUTINE DHEPS(Y,X,C,N)
  11236. C
  11237.     DIMENSION C(1)
  11238.     DOUBLE PRECISION C,Y,X,H0,H1,H2
  11239. C
  11240. C       TEST OF DIMENSION
  11241.     IF(N)1,1,2
  11242. 1    RETURN
  11243. C
  11244. 2    Y=C(1)
  11245.     IF(N-2)1,3,3
  11246. C
  11247. C       INITIALIZATION
  11248. 3    H0=1.D0
  11249.     H1=X+X
  11250. C
  11251.     DO 4 I=2,N
  11252.     H2=X*H1-DFLOAT(I-1)*H0
  11253.     H0=H1
  11254.     H1=H2+H2
  11255. 4    Y=Y+C(I)*H0
  11256.     RETURN
  11257.     END
  11258. C
  11259. C    ..................................................................
  11260. C
  11261. C       SUBROUTINE DHPCG
  11262. C
  11263. C       PURPOSE
  11264. C          TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL
  11265. C          DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
  11266. C
  11267. C       USAGE
  11268. C          CALL DHPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  11269. C          PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
  11270. C
  11271. C       DESCRIPTION OF PARAMETERS
  11272. C          PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
  11273. C                   DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
  11274. C                   SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
  11275. C                   ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
  11276. C                   OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
  11277. C                   SUBROUTINE DHPCG. EXCEPT PRMT(5) THE COMPONENTS
  11278. C                   ARE NOT DESTROYED BY SUBROUTINE DHPCG AND THEY ARE
  11279. C          PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
  11280. C          PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
  11281. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  11282. C                   (INPUT),
  11283. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
  11284. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  11285. C                   IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
  11286. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  11287. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  11288. C                   OUTPUT SUBROUTINE.
  11289. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCG INITIALIZES
  11290. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  11291. C                   SUBROUTINE DHPCG AT ANY OUTPUT POINT, HE HAS TO
  11292. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  11293. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  11294. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  11295. C                   THAN 5. HOWEVER SUBROUTINE DHPCG DOES NOT REQUIRE
  11296. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  11297. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  11298. C                   (CALLING DHPCG) WHICH ARE OBTAINED BY SPECIAL
  11299. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  11300. C          Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
  11301. C                   (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
  11302. C                   DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
  11303. C                   POINTS X.
  11304. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
  11305. C                   (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
  11306. C                   EQUAL TO 1. LATERON DERY IS THE VECTOR OF
  11307. C                   DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
  11308. C                   INTERMEDIATE POINTS X.
  11309. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  11310. C                   EQUATIONS IN THE SYSTEM.
  11311. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  11312. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  11313. C                   GREATER THAN 10, SUBROUTINE DHPCG RETURNS WITH
  11314. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  11315. C                   ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  11316. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  11317. C                   PRMT(1)) RESPECTIVELY.
  11318. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  11319. C                   COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM
  11320. C                   TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST
  11321. C                   MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT
  11322. C                   DESTROY X AND Y.
  11323. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  11324. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  11325. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  11326. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  11327. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  11328. C                   SUBROUTINE DHPCG IS TERMINATED.
  11329. C          AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16
  11330. C                   ROWS AND NDIM COLUMNS.
  11331. C
  11332. C       REMARKS
  11333. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  11334. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  11335. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  11336. C              IHLF=11),
  11337. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
  11338. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  11339. C          (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  11340. C          (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  11341. C
  11342. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  11343. C          THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
  11344. C          OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
  11345. C
  11346. C       METHOD
  11347. C          EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
  11348. C          CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
  11349. C          PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
  11350. C          DEPENDENT VARIABLES.
  11351. C          FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
  11352. C          USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
  11353. C          COMPUTATION OF STARTING VALUES.
  11354. C          SUBROUTINE DHPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING
  11355. C          THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
  11356. C          TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
  11357. C          MUST BE CODED BY THE USER.
  11358. C          FOR REFERENCE, SEE
  11359. C          (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
  11360. C               COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
  11361. C          (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
  11362. C               MTAC, VOL.16, ISS.80 (1962), PP.431-437.
  11363. C
  11364. C    ..................................................................
  11365. C
  11366.     SUBROUTINE DHPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  11367. C
  11368. C
  11369.     DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1)
  11370.     DOUBLE PRECISION Y,DERY,AUX,PRMT,X,H,Z,DELT
  11371.     N=1
  11372.     IHLF=0
  11373.     X=PRMT(1)
  11374.     H=PRMT(3)
  11375.     PRMT(5)=0.D0
  11376.     DO 1 I=1,NDIM
  11377.     AUX(16,I)=0.D0
  11378.     AUX(15,I)=DERY(I)
  11379. 1    AUX(1,I)=Y(I)
  11380.     IF(H*(PRMT(2)-X))3,2,4
  11381. C
  11382. C    ERROR RETURNS
  11383. 2    IHLF=12
  11384.     GOTO 4
  11385. 3    IHLF=13
  11386. C
  11387. C    COMPUTATION OF DERY FOR STARTING VALUES
  11388. 4    CALL FCT(X,Y,DERY)
  11389. C
  11390. C    RECORDING OF STARTING VALUES
  11391.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11392.     IF(PRMT(5))6,5,6
  11393. 5    IF(IHLF)7,7,6
  11394. 6    RETURN
  11395. 7    DO 8 I=1,NDIM
  11396. 8    AUX(8,I)=DERY(I)
  11397. C
  11398. C    COMPUTATION OF AUX(2,I)
  11399.     ISW=1
  11400.     GOTO 100
  11401. C
  11402. 9    X=X+H
  11403.     DO 10 I=1,NDIM
  11404. 10    AUX(2,I)=Y(I)
  11405. C
  11406. C    INCREMENT H IS TESTED BY MEANS OF BISECTION
  11407. 11    IHLF=IHLF+1
  11408.     X=X-H
  11409.     DO 12 I=1,NDIM
  11410. 12    AUX(4,I)=AUX(2,I)
  11411.     H=.5D0*H
  11412.     N=1
  11413.     ISW=2
  11414.     GOTO 100
  11415. C
  11416. 13    X=X+H
  11417.     CALL FCT(X,Y,DERY)
  11418.     N=2
  11419.     DO 14 I=1,NDIM
  11420.     AUX(2,I)=Y(I)
  11421. 14    AUX(9,I)=DERY(I)
  11422.     ISW=3
  11423.     GOTO 100
  11424. C
  11425. C    COMPUTATION OF TEST VALUE DELT
  11426. 15    DELT=0.D0
  11427.     DO 16 I=1,NDIM
  11428. 16    DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I))
  11429.     DELT=.066666666666666667D0*DELT
  11430.     IF(DELT-PRMT(4))19,19,17
  11431. 17    IF(IHLF-10)11,18,18
  11432. C
  11433. C    NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
  11434. 18    IHLF=11
  11435.     X=X+H
  11436.     GOTO 4
  11437. C
  11438. C    THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS.
  11439. 19    X=X+H
  11440.     CALL FCT(X,Y,DERY)
  11441.     DO 20 I=1,NDIM
  11442.     AUX(3,I)=Y(I)
  11443. 20    AUX(10,I)=DERY(I)
  11444.     N=3
  11445.     ISW=4
  11446.     GOTO 100
  11447. C
  11448. 21    N=1
  11449.     X=X+H
  11450.     CALL FCT(X,Y,DERY)
  11451.     X=PRMT(1)
  11452.     DO 22 I=1,NDIM
  11453.     AUX(11,I)=DERY(I)
  11454.    22    Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
  11455.      1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
  11456. 23    X=X+H
  11457.     N=N+1
  11458.     CALL FCT(X,Y,DERY)
  11459.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11460.     IF(PRMT(5))6,24,6
  11461. 24    IF(N-4)25,200,200
  11462. 25    DO 26 I=1,NDIM
  11463.     AUX(N,I)=Y(I)
  11464. 26    AUX(N+7,I)=DERY(I)
  11465.     IF(N-3)27,29,200
  11466. C
  11467. 27    DO 28 I=1,NDIM
  11468.     DELT=AUX(9,I)+AUX(9,I)
  11469.     DELT=DELT+DELT
  11470. 28    Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
  11471.     GOTO 23
  11472. C
  11473. 29    DO 30 I=1,NDIM
  11474.     DELT=AUX(9,I)+AUX(10,I)
  11475.     DELT=DELT+DELT+DELT
  11476. 30    Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
  11477.     GOTO 23
  11478. C
  11479. C    THE FOLLOWING PART OF SUBROUTINE DHPCG COMPUTES BY MEANS OF
  11480. C    RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
  11481. C    PREDICTOR-CORRECTOR METHOD.
  11482. 100    DO 101 I=1,NDIM
  11483.     Z=H*AUX(N+7,I)
  11484.     AUX(5,I)=Z
  11485. 101    Y(I)=AUX(N,I)+.4D0*Z
  11486. C    Z IS AN AUXILIARY STORAGE LOCATION
  11487. C
  11488.     Z=X+.4D0*H
  11489.     CALL FCT(Z,Y,DERY)
  11490.     DO 102 I=1,NDIM
  11491.     Z=H*DERY(I)
  11492.     AUX(6,I)=Z
  11493. 102   Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*Z
  11494. C
  11495.     Z=X+.45573725421878943D0*H
  11496.     CALL FCT(Z,Y,DERY)
  11497.     DO 103 I=1,NDIM
  11498.     Z=H*DERY(I)
  11499.     AUX(7,I)=Z
  11500. 103   Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
  11501.      1AUX(6,I)+3.8328647604670103D0*Z
  11502. C
  11503.     Z=X+H
  11504.     CALL FCT(Z,Y,DERY)
  11505.     DO 104 I=1,NDIM
  11506.  104  Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
  11507.      1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
  11508.      2H*DERY(I)
  11509.     GOTO(9,13,15,21),ISW
  11510. C
  11511. C    POSSIBLE BREAK-POINT FOR LINKAGE
  11512. C
  11513. C    STARTING VALUES ARE COMPUTED.
  11514. C    NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
  11515. 200    ISTEP=3
  11516. 201    IF(N-8)204,202,204
  11517. C
  11518. C    N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
  11519. 202    DO 203 N=2,7
  11520.     DO 203 I=1,NDIM
  11521.     AUX(N-1,I)=AUX(N,I)
  11522. 203    AUX(N+6,I)=AUX(N+7,I)
  11523.     N=7
  11524. C
  11525. C    N LESS THAN 8 CAUSES N+1 TO GET N
  11526. 204    N=N+1
  11527. C
  11528. C    COMPUTATION OF NEXT VECTOR Y
  11529.     DO 205 I=1,NDIM
  11530.     AUX(N-1,I)=Y(I)
  11531. 205    AUX(N+6,I)=DERY(I)
  11532.     X=X+H
  11533. 206    ISTEP=ISTEP+1
  11534.     DO 207 I=1,NDIM
  11535.      0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
  11536.      1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
  11537.     Y(I)=DELT-.9256198347107438D0*AUX(16,I)
  11538. 207    AUX(16,I)=DELT
  11539. C    PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
  11540. C    IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
  11541. C
  11542.     CALL FCT(X,Y,DERY)
  11543. C    DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
  11544. C
  11545.     DO 208 I=1,NDIM
  11546.      0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
  11547.      1+AUX(N+6,I)-AUX(N+5,I)))
  11548.     AUX(16,I)=AUX(16,I)-DELT
  11549. 208    Y(I)=DELT+.07438016528925620D0*AUX(16,I)
  11550. C
  11551. C    TEST WHETHER H MUST BE HALVED OR DOUBLED
  11552.     DELT=0.D0
  11553.     DO 209 I=1,NDIM
  11554. 209    DELT=DELT+AUX(15,I)*DABS(AUX(16,I))
  11555.     IF(DELT-PRMT(4))210,222,222
  11556. C
  11557. C    H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
  11558. 210    CALL FCT(X,Y,DERY)
  11559.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11560.     IF(PRMT(5))212,211,212
  11561. 211    IF(IHLF-11)213,212,212
  11562. 212    RETURN
  11563. 213    IF(H*(X-PRMT(2)))214,212,212
  11564. 214    IF(DABS(X-PRMT(2))-.1D0*DABS(H))212,215,215
  11565. 215    IF(DELT-.02D0*PRMT(4))216,216,201
  11566. C
  11567. C
  11568. C    H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
  11569. C    AVAILABLE
  11570. 216    IF(IHLF)201,201,217
  11571. 217    IF(N-7)201,218,218
  11572. 218    IF(ISTEP-4)201,219,219
  11573. 219    IMOD=ISTEP/2
  11574.     IF(ISTEP-IMOD-IMOD)201,220,201
  11575. 220    H=H+H
  11576.     IHLF=IHLF-1
  11577.     ISTEP=0
  11578.     DO 221 I=1,NDIM
  11579.     AUX(N-1,I)=AUX(N-2,I)
  11580.     AUX(N-2,I)=AUX(N-4,I)
  11581.     AUX(N-3,I)=AUX(N-6,I)
  11582.     AUX(N+6,I)=AUX(N+5,I)
  11583.     AUX(N+5,I)=AUX(N+3,I)
  11584.     AUX(N+4,I)=AUX(N+1,I)
  11585.     DELT=AUX(N+6,I)+AUX(N+5,I)
  11586.     DELT=DELT+DELT+DELT
  11587.   221    AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
  11588.      1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
  11589.     GOTO 201
  11590. C
  11591. C
  11592. C    H MUST BE HALVED
  11593. 222    IHLF=IHLF+1
  11594.     IF(IHLF-10)223,223,210
  11595. 223    H=.5D0*H
  11596.     ISTEP=0
  11597.     DO 224 I=1,NDIM
  11598.      0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
  11599.      1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
  11600.     AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
  11601.      1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
  11602.      218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
  11603.     AUX(N-3,I)=AUX(N-2,I)
  11604. 224    AUX(N+4,I)=AUX(N+5,I)
  11605.     X=X-H
  11606.     DELT=X-(H+H)
  11607.     CALL FCT(DELT,Y,DERY)
  11608.     DO 225 I=1,NDIM
  11609.     AUX(N-2,I)=Y(I)
  11610.     AUX(N+5,I)=DERY(I)
  11611. 225    Y(I)=AUX(N-4,I)
  11612.     DELT=DELT-(H+H)
  11613.     CALL FCT(DELT,Y,DERY)
  11614.     DO 226 I=1,NDIM
  11615.     DELT=AUX(N+5,I)+AUX(N+4,I)
  11616.     DELT=DELT+DELT+DELT
  11617.     AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
  11618.      1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
  11619. 226    AUX(N+3,I)=DERY(I)
  11620.     GOTO 206
  11621.     END
  11622. C
  11623. C    ..................................................................
  11624. C
  11625. C       SUBROUTINE DHPCL
  11626. C
  11627. C       PURPOSE
  11628. C          TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR
  11629. C          DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
  11630. C
  11631. C       USAGE
  11632. C          CALL DHPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
  11633. C          PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
  11634. C
  11635. C       DESCRIPTION OF PARAMETERS
  11636. C          PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
  11637. C                   DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
  11638. C                   SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
  11639. C                   ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
  11640. C                   OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
  11641. C                   SUBROUTINE DHPCL. EXCEPT PRMT(5) THE COMPONENTS
  11642. C                   ARE NOT DESTROYED BY SUBROUTINE DHPCL AND THEY ARE
  11643. C          PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
  11644. C          PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
  11645. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  11646. C                   (INPUT),
  11647. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
  11648. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  11649. C                   IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
  11650. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  11651. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  11652. C                   OUTPUT SUBROUTINE.
  11653. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCL INITIALIZES
  11654. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  11655. C                   SUBROUTINE DHPCL AT ANY OUTPUT POINT, HE HAS TO
  11656. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  11657. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  11658. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  11659. C                   THAN 5. HOWEVER SUBROUTINE DHPCL DOES NOT REQUIRE
  11660. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  11661. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  11662. C                   (CALLING DHPCL) WHICH ARE OBTAINED BY SPECIAL
  11663. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  11664. C          Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
  11665. C                   (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
  11666. C                   DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
  11667. C                   POINTS X.
  11668. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
  11669. C                   (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
  11670. C                   EQUAL TO 1. LATERON DERY IS THE VECTOR OF
  11671. C                   DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
  11672. C                   INTERMEDIATE POINTS X.
  11673. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  11674. C                   EQUATIONS IN THE SYSTEM.
  11675. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  11676. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  11677. C                   GREATER THAN 10, SUBROUTINE DHPCL RETURNS WITH
  11678. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  11679. C                   ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  11680. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  11681. C                   PRMT(1)) RESPECTIVELY.
  11682. C          AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  11683. C                   COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE
  11684. C                   RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
  11685. C                   ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE
  11686. C                   SHOULD NOT DESTROY X.
  11687. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  11688. C                   COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
  11689. C                   RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
  11690. C                   ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE
  11691. C                   SHOULD NOT DESTROY X.
  11692. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  11693. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  11694. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  11695. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  11696. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  11697. C                   SUBROUTINE DHPCL IS TERMINATED.
  11698. C          AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16
  11699. C                   ROWS AND NDIM COLUMNS.
  11700. C          A      - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED
  11701. C                   AS AUXILIARY STORAGE ARRAY.
  11702. C
  11703. C       REMARKS
  11704. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  11705. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  11706. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  11707. C              IHLF=11),
  11708. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
  11709. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  11710. C          (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  11711. C          (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  11712. C
  11713. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  11714. C          THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND
  11715. C          OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
  11716. C
  11717. C       METHOD
  11718. C          EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
  11719. C          CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
  11720. C          PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
  11721. C          DEPENDENT VARIABLES.
  11722. C          FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
  11723. C          USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
  11724. C          COMPUTATION OF STARTING VALUES.
  11725. C          SUBROUTINE DHPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING
  11726. C          THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
  11727. C          TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
  11728. C          MUST BE CODED BY THE USER.
  11729. C          FOR REFERENCE, SEE
  11730. C          (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
  11731. C               COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
  11732. C          (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
  11733. C               MTAC, VOL.16, ISS.80 (1962), PP.431-437.
  11734. C
  11735. C    ..................................................................
  11736. C
  11737.     SUBROUTINE DHPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
  11738. C
  11739. C
  11740. C    THE FOLLOWING FIRST PART OF SUBROUTINE DHPCL (UNTIL FIRST BREAK-
  11741. C    POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE
  11742. C    COMPUTATION
  11743. C
  11744.     DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1)
  11745.     DOUBLE PRECISION PRMT,Y,DERY,AUX,X,H,Z,DELT,A,HS
  11746.     GOTO 100
  11747. C
  11748. C    THIS PART OF SUBROUTINE DHPCL COMPUTES THE RIGHT HAND SIDE DERY OF
  11749. C    THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS.
  11750. 1    CALL AFCT(X,A)
  11751.     CALL FCT(X,DERY)
  11752.     DO 3 M=1,NDIM
  11753.     LL=M-NDIM
  11754.     HS=0.D0
  11755.     DO 2 L=1,NDIM
  11756.     LL=LL+NDIM
  11757. 2    HS=HS+A(LL)*Y(L)
  11758. 3    DERY(M)=HS+DERY(M)
  11759.     GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2
  11760. C
  11761. C    POSSIBLE BREAK-POINT FOR LINKAGE
  11762. C
  11763. 100    N=1
  11764.     IHLF=0
  11765.     X=PRMT(1)
  11766.     H=PRMT(3)
  11767.     PRMT(5)=0.D0
  11768.     DO 101 I=1,NDIM
  11769.     AUX(16,I)=0.D0
  11770.     AUX(15,I)=DERY(I)
  11771. 101    AUX(1,I)=Y(I)
  11772.     IF(H*(PRMT(2)-X))103,102,104
  11773. C
  11774. C    ERROR RETURNS
  11775. 102    IHLF=12
  11776.     GOTO 104
  11777. 103    IHLF=13
  11778. C
  11779. C    COMPUTATION OF DERY FOR STARTING VALUES
  11780. 104    ISW2=1
  11781.     GOTO 1
  11782. C
  11783. C    RECORDING OF STARTING VALUES
  11784. 105    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11785.     IF(PRMT(5))107,106,107
  11786. 106    IF(IHLF)108,108,107
  11787. 107    RETURN
  11788. 108    DO 109 I=1,NDIM
  11789. C
  11790. 109    AUX(8,I)=DERY(I)
  11791. C    COMPUTATION OF AUX(2,I)
  11792.     ISW1=1
  11793.     GOTO 200
  11794. 110    X=X+H
  11795.     DO 111 I=1,NDIM
  11796. 111    AUX(2,I)=Y(I)
  11797. C
  11798. C    INCREMENT H IS TESTED BY MEANS OF BISECTION
  11799. 112    IHLF=IHLF+1
  11800.     X=X-H
  11801.     DO 113 I=1,NDIM
  11802. 113    AUX(4,I)=AUX(2,I)
  11803.     H=.5D0*H
  11804.     N=1
  11805.     ISW1=2
  11806.     GOTO 200
  11807. C
  11808. 114    X=X+H
  11809.     ISW2=5
  11810.     GOTO 1
  11811. 115    N=2
  11812.     DO 116 I=1,NDIM
  11813.     AUX(2,I)=Y(I)
  11814. 116    AUX(9,I)=DERY(I)
  11815.     ISW1=3
  11816.     GOTO 200
  11817. C
  11818. C    COMPUTATION OF TEST VALUE DELT
  11819. 117    DELT=0.D0
  11820.     DO 118 I=1,NDIM
  11821. 118    DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I))
  11822.     DELT=.066666666666666667D0*DELT
  11823.     IF(DELT-PRMT(4))121,121,119
  11824. 119    IF(IHLF-10)112,120,120
  11825. C
  11826. C    NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
  11827. 120    IHLF=11
  11828.     X=X+H
  11829.     GOTO 104
  11830. C
  11831. C    SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
  11832. 121    X=X+H
  11833.     ISW2=6
  11834.     GOTO 1
  11835. 122    DO 123 I=1,NDIM
  11836.     AUX(3,I)=Y(I)
  11837. 123    AUX(10,I)=DERY(I)
  11838.     N=3
  11839.     ISW1=4
  11840.     GOTO 200
  11841. C
  11842. 124    N=1
  11843.     X=X+H
  11844.     ISW2=7
  11845.     GOTO 1
  11846. 125    X=PRMT(1)
  11847.     DO 126 I=1,NDIM
  11848.     AUX(11,I)=DERY(I)
  11849.   126    Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
  11850.      1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
  11851. 127    X=X+H
  11852.     N=N+1
  11853.     ISW2=12
  11854.     GOTO 1
  11855. 128    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11856.     IF(PRMT(5))107,129,107
  11857. 129    IF(N-4)130,300,300
  11858. 130    DO 131 I=1,NDIM
  11859.     AUX(N,I)=Y(I)
  11860. 131    AUX(N+7,I)=DERY(I)
  11861.     IF(N-3)132,134,300
  11862. C
  11863. 132    DO 133 I=1,NDIM
  11864.     DELT=AUX(9,I)+AUX(9,I)
  11865.     DELT=DELT+DELT
  11866. 133    Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
  11867.     GOTO 127
  11868. C
  11869. 134    DO 135 I=1,NDIM
  11870.     DELT=AUX(9,I)+AUX(10,I)
  11871.     DELT=DELT+DELT+DELT
  11872. 135    Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
  11873.     GOTO 127
  11874. C
  11875. C    THE FOLLOWING PART OF SUBROUTINE DHPCL COMPUTES BY MEANS OF
  11876. C    RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
  11877. C    PREDICTOR-CORRECTOR METHOD.
  11878. 200    Z=X
  11879.     DO 201 I=1,NDIM
  11880.     X=H*AUX(N+7,I)
  11881.     AUX(5,I)=X
  11882. 201    Y(I)=AUX(N,I)+.4D0*X
  11883. C    X IS AN AUXILIARY STORAGE LOCATION
  11884. C
  11885.     X=Z+.4D0*H
  11886.     ISW2=2
  11887.     GOTO 1
  11888. 202    DO 203 I=1,NDIM
  11889.     X=H*DERY(I)
  11890.     AUX(6,I)=X
  11891. 203    Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X
  11892. C
  11893.     X=Z+.45573725421878943D0*H
  11894.     ISW2=3
  11895.     GOTO 1
  11896. 204    DO 205 I=1,NDIM
  11897.     X=H*DERY(I)
  11898.     AUX(7,I)=X
  11899. 205   Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
  11900.      1AUX(6,I)+3.8328647604670103D0*X
  11901. C
  11902.     X=Z+H
  11903.     ISW2=4
  11904.     GOTO 1
  11905. 206    DO 207 I=1,NDIM
  11906.   207 Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
  11907.      1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
  11908.      2H*DERY(I)
  11909.     X=Z
  11910.     GOTO(110,114,117,124),ISW1
  11911. C
  11912. C    POSSIBLE BREAK-POINT FOR LINKAGE
  11913. C
  11914. C    STARTING VALUES ARE COMPUTED.
  11915. C    NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
  11916. 300    ISTEP=3
  11917. 301    IF(N-8)304,302,304
  11918. C
  11919. C    N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
  11920. 302    DO 303 N=2,7
  11921.     DO 303 I=1,NDIM
  11922.     AUX(N-1,I)=AUX(N,I)
  11923. 303    AUX(N+6,I)=AUX(N+7,I)
  11924.     N=7
  11925. C
  11926. C    N LESS THAN 8 CAUSES N+1 TO GET N
  11927. 304    N=N+1
  11928. C
  11929. C    COMPUTATION OF NEXT VECTOR Y
  11930.     DO 305 I=1,NDIM
  11931.     AUX(N-1,I)=Y(I)
  11932. 305    AUX(N+6,I)=DERY(I)
  11933.     X=X+H
  11934. 306    ISTEP=ISTEP+1
  11935.     DO 307 I=1,NDIM
  11936.     DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
  11937.      1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
  11938.     Y(I)=DELT-.9256198347107438D0*AUX(16,I)
  11939. 307    AUX(16,I)=DELT
  11940. C    PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
  11941. C    IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
  11942.     ISW2=8
  11943.     GOTO 1
  11944. C    DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
  11945. C
  11946. 308    DO 309 I=1,NDIM
  11947.       DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
  11948.      1+AUX(N+6,I)-AUX(N+5,I)))
  11949.     AUX(16,I)=AUX(16,I)-DELT
  11950. 309    Y(I)=DELT+.07438016528925620D0*AUX(16,I)
  11951. C
  11952. C    TEST WHETHER H MUST BE HALVED OR DOUBLED
  11953.     DELT=0.D0
  11954.     DO 310 I=1,NDIM
  11955. 310    DELT=DELT+AUX(15,I)*DABS(AUX(16,I))
  11956.     IF(DELT-PRMT(4))311,324,324
  11957. C
  11958. C    H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
  11959. 311    ISW2=9
  11960.     GOTO 1
  11961. 312    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  11962.     IF(PRMT(5))314,313,314
  11963. 313    IF(IHLF-11)315,314,314
  11964. 314    RETURN
  11965. 315    IF(H*(X-PRMT(2)))316,314,314
  11966. 316    IF(DABS(X-PRMT(2))-.1D0*DABS(H))314,317,317
  11967. 317    IF(DELT-.02D0*PRMT(4))318,318,301
  11968. C
  11969. C    H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
  11970. C    AVAILABLE
  11971. 318    IF(IHLF)301,301,319
  11972. 319    IF(N-7)301,320,320
  11973. 320    IF(ISTEP-4)301,321,321
  11974. 321    IMOD=ISTEP/2
  11975.     IF(ISTEP-IMOD-IMOD)301,322,301
  11976. 322    H=H+H
  11977.     IHLF=IHLF-1
  11978.     ISTEP=0
  11979.     DO 323 I=1,NDIM
  11980.     AUX(N-1,I)=AUX(N-2,I)
  11981.     AUX(N-2,I)=AUX(N-4,I)
  11982.     AUX(N-3,I)=AUX(N-6,I)
  11983.     AUX(N+6,I)=AUX(N+5,I)
  11984.     AUX(N+5,I)=AUX(N+3,I)
  11985.     AUX(N+4,I)=AUX(N+1,I)
  11986.     DELT=AUX(N+6,I)+AUX(N+5,I)
  11987.     DELT=DELT+DELT+DELT
  11988.   323    AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
  11989.      1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
  11990.     GOTO 301
  11991. C
  11992. C    H MUST BE HALVED
  11993. 324    IHLF=IHLF+1
  11994.     IF(IHLF-10)325,325,311
  11995. 325    H=.5D0*H
  11996.     ISTEP=0
  11997.     DO 326 I=1,NDIM
  11998.       Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
  11999.      1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
  12000.          AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
  12001.      1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
  12002.      218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
  12003.     AUX(N-3,I)=AUX(N-2,I)
  12004. 326    AUX(N+4,I)=AUX(N+5,I)
  12005.     DELT=X-H
  12006.     X=DELT-(H+H)
  12007.     ISW2=10
  12008.     GOTO 1
  12009. 327    DO 328 I=1,NDIM
  12010.     AUX(N-2,I)=Y(I)
  12011.     AUX(N+5,I)=DERY(I)
  12012. 328    Y(I)=AUX(N-4,I)
  12013.     X=X-(H+H)
  12014.     ISW2=11
  12015.     GOTO 1
  12016. 329    X=DELT
  12017.     DO 330 I=1,NDIM
  12018.     DELT=AUX(N+5,I)+AUX(N+4,I)
  12019.     DELT=DELT+DELT+DELT
  12020.          AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
  12021.      1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
  12022. 330    AUX(N+3,I)=DERY(I)
  12023.     GOTO 306
  12024.     END
  12025. C
  12026. C    ..................................................................
  12027. C
  12028. C       SUBROUTINE DISCR
  12029. C
  12030. C       PURPOSE
  12031. C          COMPUTE A SET OF LINEAR FUNCTIONS WHICH SERVE AS INDICES
  12032. C          FOR CLASSIFYING AN INDIVIDUAL INTO ONE OF SEVERAL GROUPS.
  12033. C          NORMALLY THIS SUBROUTINE IS USED IN THE PERFORMANCE OF
  12034. C          DISCRIMINANT ANALYSIS.
  12035. C
  12036. C       USAGE
  12037. C          CALL DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG)
  12038. C
  12039. C       DESCRIPTION OF PARAMETERS
  12040. C          K     - NUMBER OF GROUPS. K MUST BE GREATER THAN ONE.
  12041. C          M     - NUMBER OF VARIABLES
  12042. C          N     - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF
  12043. C                  GROUPS.
  12044. C          X     - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA-
  12045. C                  LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1),
  12046. C                  X(2,1,1), X(3,1,1), ETC.  THE FIRST SUBSCRIPT IS
  12047. C                  CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER
  12048. C                  AND THE THIRD SUBSCRIPT IS GROUP NUMBER.  THE
  12049. C                  LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF
  12050. C                  DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K).
  12051. C          XBAR  - INPUT MATRIX (M X K) CONTAINING MEANS OF M VARIABLES
  12052. C                  IN K GROUPS
  12053. C          D     - INPUT MATRIX (M X M) CONTAINING THE INVERSE OF
  12054. C                  POOLED DISPERSION MATRIX.
  12055. C          CMEAN - OUTPUT VECTOR OF LENGTH M CONTAINING COMMON MEANS.
  12056. C          V     - OUTPUT VARIABLE CONTAINING GENERALIZED MAHALANOBIS
  12057. C                  D-SQUARE.
  12058. C          C     - OUTPUT MATRIX (M+1 X K) CONTAINING THE COEFFICIENTS
  12059. C                  OF DISCRIMINANT FUNCTIONS.  THE FIRST POSITION OF
  12060. C                  EACH COLUMN (FUNCTION) CONTAINS THE VALUE OF THE
  12061. C                  CONSTANT FOR THAT FUNCTION.
  12062. C          P     - OUTPUT VECTOR CONTAINING THE PROBABILITY ASSOCIATED
  12063. C                  WITH THE LARGEST DISCRIMINANT FUNCTIONS OF ALL CASES
  12064. C                  IN ALL GROUPS.  CALCULATED RESULTS ARE STORED IN THE
  12065. C                  MANNER EQUIVALENT TO A 2-DIMENSIONAL AREA (THE
  12066. C                  FIRST SUBSCRIPT IS CASE NUMBER, AND THE SECOND
  12067. C                  SUBSCRIPT IS GROUP NUMBER).  VECTOR P HAS LENGTH
  12068. C                  EQUAL TO THE TOTAL NUMBER OF CASES, T (T = N(1)+N(2)
  12069. C                  +...+N(K)).
  12070. C          LG    - OUTPUT VECTOR CONTAINING THE SUBSCRIPTS OF THE
  12071. C                  LARGEST DISCRIMINANT FUNCTIONS STORED IN VECTOR P.
  12072. C                  THE LENGTH OF VECTOR LG IS THE SAME AS THE LENGTH
  12073. C                  OF VECTOR P.
  12074. C
  12075. C       REMARKS
  12076. C          THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO
  12077. C          THE NUMBER OF GROUPS.
  12078. C
  12079. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  12080. C          NONE
  12081. C
  12082. C       METHOD
  12083. C          REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
  12084. C          DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO
  12085. C          MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS,
  12086. C          1958, SECTION 6.6-6.8.
  12087. C
  12088. C    ..................................................................
  12089. C
  12090.     SUBROUTINE DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG)
  12091.     DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1),C(1),P(1),LG(1)
  12092. C
  12093. C       ...............................................................
  12094. C
  12095. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  12096. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  12097. C       STATEMENT WHICH FOLLOWS.
  12098. C
  12099. C    DOUBLE PRECISION XBAR,D,CMEAN,V,C,SUM,P,PL
  12100. C
  12101. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  12102. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  12103. C       ROUTINE.
  12104. C
  12105. C       THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
  12106. C       CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  EXP IN STATEMENT
  12107. C       250 MUST BE CHANGED TO DEXP.
  12108. C
  12109. C       ...............................................................
  12110. C
  12111. C    CALCULATE COMMON MEANS
  12112. C
  12113.     N1=N(1)
  12114.     DO 100 I=2,K
  12115. 100    N1=N1+N(I)
  12116.     FNT=N1
  12117.     DO 110 I=1,K
  12118. 110    P(I)=N(I)
  12119.     DO 130 I=1,M
  12120.     CMEAN(I)=0
  12121.     N1=I-M
  12122.     DO 120 J=1,K
  12123.     N1=N1+M
  12124. 120    CMEAN(I)=CMEAN(I)+P(J)*XBAR(N1)
  12125. 130    CMEAN(I)=CMEAN(I)/FNT
  12126. C
  12127. C    CALCULATE GENERALIZED MAHALANOBIS D SQUARE
  12128. C
  12129.     L=0
  12130.     DO 140 I=1,K
  12131.     DO 140 J=1,M
  12132.     L=L+1
  12133. 140    C(L)=XBAR(L)-CMEAN(J)
  12134.     V=0.0
  12135.     L=0
  12136.     DO 160 J=1,M
  12137.     DO 160 I=1,M
  12138.     N1=I-M
  12139.     N2=J-M
  12140.     SUM=0.0
  12141.     DO 150 IJ=1,K
  12142.     N1=N1+M
  12143.     N2=N2+M
  12144. 150    SUM=SUM+P(IJ)*C(N1)*C(N2)
  12145.     L=L+1
  12146. 160    V=V+D(L)*SUM
  12147. C
  12148. C    CALCULATE THE COEFFICIENTS OF DISCRIMINANT FUNCTIONS
  12149. C
  12150.     N2=0
  12151.     DO 190 KA=1,K
  12152.     DO 170 I=1,M
  12153.     N2=N2+1
  12154. 170    P(I)=XBAR(N2)
  12155.     IQ=(M+1)*(KA-1)+1
  12156.     SUM=0.0
  12157.     DO 180 J=1,M
  12158.     N1=J-M
  12159.     DO 180 L=1,M
  12160.     N1=N1+M
  12161. 180    SUM=SUM+D(N1)*P(J)*P(L)
  12162.     C(IQ)=-(SUM/2.0)
  12163.     DO 190 I=1,M
  12164.     N1=I-M
  12165.     IQ=IQ+1
  12166.     C(IQ)=0.0
  12167.     DO 190 J=1,M
  12168.     N1=N1+M
  12169. 190    C(IQ)=C(IQ)+D(N1)*P(J)
  12170. C
  12171. C    FOR EACH CASE IN EACH GROUP, CALCULATE..
  12172. C
  12173. C       DISCRIMINANT FUNCTIONS
  12174. C
  12175.     LBASE=0
  12176.     N1=0
  12177.     DO 270 KG=1,K
  12178.     NN=N(KG)
  12179.     DO 260 I=1,NN
  12180.     L=I-NN+LBASE
  12181.     DO 200 J=1,M
  12182.     L=L+NN
  12183. 200    D(J)=X(L)
  12184.     N2=0
  12185.     DO 220 KA=1,K
  12186.     N2=N2+1
  12187.     SUM=C(N2)
  12188.     DO 210 J=1,M
  12189.     N2=N2+1
  12190. 210    SUM=SUM+C(N2)*D(J)
  12191. 220    XBAR(KA)=SUM
  12192. C
  12193. C       THE LARGEST DISCRIMINANT FUNCTION
  12194. C
  12195.     L=1
  12196.     SUM=XBAR(1)
  12197.     DO 240 J=2,K
  12198.     IF(SUM-XBAR(J)) 230, 240, 240
  12199. 230    L=J
  12200.     SUM=XBAR(J)
  12201. 240    CONTINUE
  12202. C
  12203. C       PROBABILITY ASSOCIATED WITH THE LARGEST DISCRIMINANT FUNCTION
  12204. C
  12205.     PL=0.0
  12206.     DO 250 J=1,K
  12207. 250    PL=PL+ EXP(XBAR(J)-SUM)
  12208.     N1=N1+1
  12209.     LG(N1)=L
  12210. 260    P(N1)=1.0/PL
  12211. 270    LBASE=LBASE+NN*M
  12212. C
  12213.     RETURN
  12214.     END
  12215. C
  12216. C    ..................................................................
  12217. C
  12218. C       SUBROUTINE DJELF
  12219. C
  12220. C       PURPOSE
  12221. C          COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN.
  12222. C
  12223. C       USAGE
  12224. C          CALL DJELF(SN,CN,DN,X,SCK)
  12225. C
  12226. C       DESCRIPTION OF PARAMETERS
  12227. C          SN    - RESULT VALUE SN(X) IN DOUBLE PRECISION
  12228. C          CN    - RESULT VALUE CN(X) IN DOUBLE PRECISION
  12229. C          DN    - RESULT VALUE DN(X) IN DOUBLE PRECISION
  12230. C          X     - DOUBLE PRECISION ARGUMENT OF JACOBIAN ELLIPTIC
  12231. C                  FUNCTIONS
  12232. C          SCK   - SQUARE OF COMPLEMENTARY MODULUS IN DOUBLE PRECISION
  12233. C
  12234. C       REMARKS
  12235. C          NONE
  12236. C
  12237. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  12238. C          NONE
  12239. C
  12240. C       METHOD
  12241. C          DEFINITION
  12242. C          X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER
  12243. C          T FROM 0 TO SN), WHERE K=SQRT(1-SCK).
  12244. C          SN*SN + CN*CN = 1
  12245. C          (K*SN)**2 + DN**2 = 1.
  12246. C          EVALUATION
  12247. C          CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC
  12248. C          GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION
  12249. C          BEFORE INVERSION OF THE INTEGRAL TAKES PLACE.
  12250. C          REFERENCE
  12251. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  12252. C                 ELLIPTIC FUNCTIOMS.
  12253. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  12254. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  12255. C
  12256. C    ..................................................................
  12257. C
  12258.     SUBROUTINE DJELF(SN,CN,DN,X,SCK)
  12259. C
  12260.     DIMENSION ARI(12),GEO(12)
  12261.     DOUBLE PRECISION SN,CN,DN,X,SCK,ARI,GEO,CM,Y,A,B,C,D
  12262. C
  12263. C       TEST MODULUS
  12264. C
  12265.     CM=SCK
  12266.     Y=X
  12267.     IF(SCK)3,1,4
  12268. 1    D=DEXP(X)
  12269.     A=1.D0/D
  12270.     B=A+D
  12271.     CN=2.D0/B
  12272.     DN=CN
  12273.     A=(D-A)/2.D0
  12274.     SN=A*CN
  12275. C       DEGENERATE CASE SCK=0 GIVES RESULTS
  12276. C          CN X = DN X = 1/COSH X
  12277. C          SN X = TANH X
  12278. 2    RETURN
  12279. C
  12280. C       JACOBIS MODULUS TRANSFORMATION
  12281. C
  12282. 3    D=1.D0-SCK
  12283.     CM=-SCK/D
  12284.     D=DSQRT(D)
  12285.     Y=D*X
  12286. 4    A=1.D0
  12287.     DN=1.D0
  12288.     DO 6 I=1,12
  12289.     L=I
  12290.     ARI(I)=A
  12291.     CM=DSQRT(CM)
  12292.     GEO(I)=CM
  12293.     C=(A+CM)*.5D0
  12294.     IF(DABS(A-CM)-1.D-9*A)7,7,5
  12295. 5    CM=A*CM
  12296. 6    A=C
  12297. C
  12298. C       START BACKWARD RECURSION
  12299. C
  12300. 7    Y=C*Y
  12301.     SN=DSIN(Y)
  12302.     CN=DCOS(Y)
  12303.     IF(SN)8,13,8
  12304. 8    A=CN/SN
  12305.     C=A*C
  12306.     DO 9 I=1,L
  12307.     K=L-I+1
  12308.     B=ARI(K)
  12309.     A=C*A
  12310.     C=DN*C
  12311.     DN=(GEO(K)+A)/(B+A)
  12312. 9    A=C/B
  12313.     A=1.D0/DSQRT(C*C+1.D0)
  12314.     IF(SN)10,11,11
  12315. 10    SN=-A
  12316.     GOTO 12
  12317. 11    SN=A
  12318. 12    CN=C*SN
  12319. 13    IF(SCK)14,2,2
  12320. 14    A=DN
  12321.     DN=CN
  12322.     CN=A
  12323.     SN=SN/D
  12324.     RETURN
  12325.     END
  12326. C
  12327. C    ..................................................................
  12328. C
  12329. C       SUBROUTINE DLAP
  12330. C
  12331. C       PURPOSE
  12332. C          COMPUTE THE VALUES OF THE LAGUERRE POLYNOMIALS L(N,X)
  12333. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  12334. C
  12335. C       USAGE
  12336. C          CALL DLAP(Y,X,N)
  12337. C
  12338. C       DESCRIPTION OF PARAMETERS
  12339. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  12340. C                  OF LAGUERRE POLYNOMIALS OF ORDER 0 UP TO N
  12341. C                  FOR GIVEN ARGUMENT X.
  12342. C                  DOUBLE PRECISION VECTOR.
  12343. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  12344. C          X     - ARGUMENT OF LAGUERRE POLYNOMIAL
  12345. C                  DOUBLE PRECISION VARIABLE.
  12346. C          N     - ORDER OF LAGUERRE POLYNOMIAL
  12347. C
  12348. C       REMARKS
  12349. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  12350. C
  12351. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  12352. C          NONE
  12353. C
  12354. C       METHOD
  12355. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  12356. C          LAGUERRE POLYNOMIALS L(N,X)
  12357. C          L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
  12358. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  12359. C          THE SECOND IS THE ARGUMENT.
  12360. C          STARTING VALUES ARE L(0,X)=1, L(1,X)=1.-X.
  12361. C
  12362. C    ..................................................................
  12363. C
  12364.     SUBROUTINE DLAP(Y,X,N)
  12365. C
  12366.     DIMENSION Y(1)
  12367.     DOUBLE PRECISION Y,X,T
  12368. C
  12369. C       TEST OF ORDER
  12370.     Y(1)=1.D0
  12371.     IF(N)1,1,2
  12372. 1    RETURN
  12373. C
  12374. 2    Y(2)=1.D0-X
  12375.     IF(N-1)1,1,3
  12376. C
  12377. C       INITIALIZATION
  12378. 3    T=1.D0+X
  12379. C
  12380.     DO 4 I=2,N
  12381. 4    Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/DFLOAT(I)
  12382.     RETURN
  12383.     END
  12384. C
  12385. C    ..................................................................
  12386. C
  12387. C       SUBROUTINE DLAPS
  12388. C
  12389. C       PURPOSE
  12390. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LAGUERRE
  12391. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  12392. C
  12393. C       USAGE
  12394. C          CALL DLAPS(Y,X,C,N)
  12395. C
  12396. C       DESCRIPTION OF PARAMETERS
  12397. C          Y     - RESULT VALUE
  12398. C                  DOUBLE PRECISION VARIABLE
  12399. C          X     - ARGUMENT VALUE
  12400. C                  DOUBLE PRECISION VARIABLE
  12401. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  12402. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  12403. C                  DOUBLE PRECISION VECTOR
  12404. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  12405. C
  12406. C       REMARKS
  12407. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  12408. C
  12409. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  12410. C          NONE
  12411. C
  12412. C       METHOD
  12413. C          DEFINITION
  12414. C          Y=SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
  12415. C          EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
  12416. C          USING THE RECURRENCE EQUATION FOR LAGUERRE POLYNOMIALS
  12417. C          L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1).
  12418. C
  12419. C    ..................................................................
  12420. C
  12421.     SUBROUTINE DLAPS(Y,X,C,N)
  12422. C
  12423.     DIMENSION C(1)
  12424.     DOUBLE PRECISION C,Y,X,H0,H1,H2,T
  12425. C
  12426. C       TEST OF DIMENSION
  12427.     IF(N)1,1,2
  12428. 1    RETURN
  12429. C
  12430. 2    Y=C(1)
  12431.     IF(N-2)1,3,3
  12432. C
  12433. C       INITIALIZATION
  12434. 3    H0=1.D0
  12435.     H1=1.D0-X
  12436.     T=1.D0+X
  12437.     DO 4 I=2,N
  12438.     H2=H1-H0+H1-(T*H1-H0)/DFLOAT(I)
  12439.     H0=H1
  12440.     H1=H2
  12441. 4    Y=Y+C(I)*H0
  12442.     RETURN
  12443.     END
  12444. C
  12445. C    ..................................................................
  12446. C
  12447. C       SUBROUTINE DLBVP
  12448. C
  12449. C       PURPOSE
  12450. C          TO SOLVE A LINEAR BOUNDARY VALUE PROBLEM, WHICH CONSISTS OF
  12451. C          A SYSTEM OF NDIM LINEAR FIRST ORDER DIFFERENTIAL EQUATIONS
  12452. C                 DY/DX=A(X)*Y(X)+F(X)
  12453. C          AND NDIM LINEAR BOUNDARY CONDITIONS
  12454. C                 B*Y(XL)+C*Y(XU)=R.
  12455. C
  12456. C       USAGE
  12457. C          CALL DLBVP (PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
  12458. C                     AUX,A)
  12459. C          PARAMETERS AFCT,FCT,DFCT,OUTP REQUIRE AN EXTERNAL STATEMENT.
  12460. C
  12461. C       DESCRIPTION OF PARAMETERS
  12462. C          PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
  12463. C                   DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
  12464. C                   SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
  12465. C                   ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
  12466. C                   OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
  12467. C                   SUBROUTINE DLBVP. EXCEPT PRMT(5) THE COMPONENTS
  12468. C                   ARE NOT DESTROYED BY SUBROUTINE DLBVP AND THEY ARE
  12469. C          PRMT(1)- LOWER BOUND XL OF THE INTERVAL (INPUT),
  12470. C          PRMT(1)- UPPER BOUND XU OF THE INTERVAL (INPUT),
  12471. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  12472. C                   (INPUT),
  12473. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF RELATIVE ERROR IS
  12474. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  12475. C                   IF INCREMENT IS LESS THAN PRMT(3) AND RELATIVE
  12476. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  12477. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  12478. C                   OUTPUT SUBROUTINE.
  12479. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DLBVP INITIALIZES
  12480. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  12481. C                   SUBROUTINE DLBVP AT ANY OUTPUT POINT, HE HAS TO
  12482. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  12483. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  12484. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  12485. C                   THAN 5. HOWEVER SUBROUTINE DLBVP DOES NOT REQUIRE
  12486. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  12487. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  12488. C                   (CALLING DLBVP) WHICH ARE OBTAINED BY SPECIAL
  12489. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  12490. C          B      - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX
  12491. C                   (DESTROYED). IT IS THE COEFFICIENT MATRIX OF Y(XL)
  12492. C                   IN THE BOUNDARY CONDITIONS.
  12493. C          C      - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX
  12494. C                   (POSSIBLY DESTROYED). IT IS THE COEFFICIENT MATRIX
  12495. C                   OF Y(XU) IN THE BOUNDARY CONDITIONS.
  12496. C          R      - DOUBLE PRECISION INPUT VECTOR WITH DIMENSION NDIM
  12497. C                   (DESTROYED). IT SPECIFIES THE RIGHT HAND SIDE OF
  12498. C                   THE BOUNDARY CONDITIONS.
  12499. C          Y      - DOUBLE PRECISION AUXILIARY VECTOR WITH
  12500. C                   DIMENSION NDIM. IT IS USED AS STORAGE LOCATION
  12501. C                   FOR THE RESULTING VALUES OF DEPENDENT VARIABLES
  12502. C                   COMPUTED AT INTERMEDIATE POINTS X.
  12503. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
  12504. C                   (DESTROYED). ITS MAXIMAL COMPONENT SHOULD BE
  12505. C                   EQUAL TO 1. LATERON DERY IS THE VECTOR OF
  12506. C                   DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
  12507. C                   INTERMEDIATE POINTS X.
  12508. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  12509. C                   DIFFERENTIAL EQUATIONS IN THE SYSTEM.
  12510. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  12511. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  12512. C                   GREATER THAN 10, SUBROUTINE DLBVP RETURNS WITH
  12513. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  12514. C                   ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  12515. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  12516. C                   PRMT(1)) RESPECTIVELY. FINALLY ERROR MESSAGE
  12517. C                   IHLF=14 INDICATES, THAT THERE IS NO SOLUTION OR
  12518. C                   THAT THERE ARE MORE THAN ONE SOLUTION OF THE
  12519. C                   PROBLEM.
  12520. C                   A NEGATIVE VALUE OF IHLF HANDED TO SUBROUTINE OUTP
  12521. C                   TOGETHER WITH INITIAL VALUES OF FINALLY GENERATED
  12522. C                   INITIAL VALUE PROBLEM INDICATES, THAT THERE WAS
  12523. C                   POSSIBLE LOSS OF SIGNIFICANCE IN THE SOLUTION OF
  12524. C                   THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS FOR
  12525. C                   THESE INITIAL VALUES. THE ABSOLUTE VALUE OF IHLF
  12526. C                   SHOWS, AFTER WHICH ELIMINATION STEP OF GAUSS
  12527. C                   ALGORITHM POSSIBLE LOSS OF SIGNIFICANCE WAS
  12528. C                   DETECTED.
  12529. C          AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  12530. C                   COMPUTES THE COEFFICIENT MATRIX A OF VECTOR Y ON
  12531. C                   THE RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
  12532. C                   EQUATIONS FOR A GIVEN X-VALUE. ITS PARAMETER LIST
  12533. C                   MUST BE X,A. SUBROUTINE AFCT SHOULD NOT DESTROY X.
  12534. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  12535. C                   COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
  12536. C                   RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
  12537. C                   EQUATIONS) FOR A GIVEN X-VALUE. ITS PARAMETER LIST
  12538. C                   MUST BE X,F. SUBROUTINE FCT SHOULD NOT DESTROY X.
  12539. C          DFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  12540. C                   COMPUTES VECTOR DF (DERIVATIVE OF THE INHOMOGENEOUS
  12541. C                   PART ON THE RIGHT HAND SIDE OF THE SYSTEM OF
  12542. C                   DIFFERENTIAL EQUATIONS) FOR A GIVEN X-VALUE. ITS
  12543. C                   PARAMETER LIST MUST BE X,DF. SUBROUTINE DFCT
  12544. C                   SHOULD NOT DESTROY X.
  12545. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  12546. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  12547. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  12548. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  12549. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  12550. C                   SUBROUTINE DLBVP IS TERMINATED.
  12551. C          AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 20
  12552. C                   ROWS AND NDIM COLUMNS.
  12553. C          A      - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED
  12554. C                   AS AUXILIARY STORAGE ARRAY.
  12555. C
  12556. C       REMARKS
  12557. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  12558. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  12559. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  12560. C              IHLF=11),
  12561. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR IF IT HAS WRONG SIGN
  12562. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  12563. C          (3) THERE IS NO OR MORE THAN ONE SOLUTION OF THE PROBLEM
  12564. C              (ERROR MESSAGE IHLF=14),
  12565. C          (4) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  12566. C          (5) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  12567. C
  12568. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  12569. C          SUBROUTINE DGELG     SYSTEM OF LINEAR EQUATIONS.
  12570. C          THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F), DFCT(X,DF),
  12571. C          AND OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED
  12572. C          BY THE USER.
  12573. C
  12574. C       METHOD
  12575. C          EVALUATION IS DONE USING THE METHOD OF ADJOINT EQUATIONS.
  12576. C          HAMMINGS FOURTH ORDER MODIFIED PREDICTOR-CORRECTOR METHOD
  12577. C          IS USED TO SOLVE THE ADJOINT INITIAL VALUE PROBLEMS AND FI-
  12578. C          NALLY TO SOLVE THE GENERATED INITIAL VALUE PROBLEM FOR Y(X).
  12579. C          THE INITIAL INCREMENT PRMT(3) IS AUTOMATICALLY ADJUSTED.
  12580. C          FOR COMPUTATION OF INTEGRAL SUM, A FOURTH ORDER HERMITEAN
  12581. C          INTEGRATION FORMULA IS USED.
  12582. C          FOR REFERENCE, SEE
  12583. C          (1) LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
  12584. C              ILIFFE, LONDON, 1960, PP.64-67.
  12585. C          (2) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
  12586. C              COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
  12587. C          (3) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
  12588. C              MTAC, VOL.16, ISS.80 (1962), PP.431-437.
  12589. C          (4) ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  12590. C              PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  12591. C              PP.227-232.
  12592. C
  12593. C    ..................................................................
  12594. C
  12595.     SUBROUTINE DLBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
  12596.      1AUX,A)
  12597. C
  12598. C
  12599.     DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1)
  12600.     DOUBLE PRECISION PRMT,B,C,R,Y,DERY,AUX,A,H,X,Z,GL,HS,GU,SUM,
  12601.      1DGL,DGU,XST,XEND,DELT
  12602. C
  12603. C    ERROR TEST
  12604.     IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3
  12605. 1    IHLF=12
  12606.     RETURN
  12607. 2    IHLF=13
  12608.     RETURN
  12609. C
  12610. C    SEARCH FOR ZERO-COLUMNS IN MATRICES B AND C
  12611. 3    KK=-NDIM
  12612.     IB=0
  12613.     IC=0
  12614.     DO 7 K=1,NDIM
  12615.     AUX(15,K)=DERY(K)
  12616.     AUX(1,K)=1.D0
  12617.     AUX(17,K)=1.D0
  12618.     KK=KK+NDIM
  12619.     DO 4 I=1,NDIM
  12620.     II=KK+I
  12621.     IF(B(II))5,4,5
  12622. 4    CONTINUE
  12623.     IB=IB+1
  12624.     AUX(1,K)=0.D0
  12625. 5    DO 6 I=1,NDIM
  12626.     II=KK+I
  12627.     IF(C(II))7,6,7
  12628. 6    CONTINUE
  12629.     IC=IC+1
  12630.     AUX(17,K)=0.D0
  12631. 7    CONTINUE
  12632. C
  12633. C    DETERMINATION OF LOWER AND UPPER BOUND
  12634.     IF(IC-IB)8,11,11
  12635. 8    H=PRMT(2)
  12636.     PRMT(2)=PRMT(1)
  12637.     PRMT(1)=H
  12638.     PRMT(3)=-PRMT(3)
  12639.     DO 9 I=1,NDIM
  12640. 9    AUX(17,I)=AUX(1,I)
  12641.     II=NDIM*NDIM
  12642.     DO 10 I=1,II
  12643.     H=B(I)
  12644.     B(I)=C(I)
  12645. 10    C(I)=H
  12646. C
  12647. C    PREPARATIONS FOR CONSTRUCTION OF ADJOINT INITIAL VALUE PROBLEMS
  12648. 11    X=PRMT(2)
  12649.     CALL FCT(X,Y)
  12650.     CALL DFCT(X,DERY)
  12651.     DO 12 I=1,NDIM
  12652.     AUX(18,I)=Y(I)
  12653. 12    AUX(19,I)=DERY(I)
  12654. C
  12655. C    POSSIBLE BREAK-POINT FOR LINKAGE
  12656. C
  12657. C    THE FOLLOWING PART OF SUBROUTINE DLBVP UNTIL NEXT BREAK-POINT FOR
  12658. C    LINKAGE HAS TO REMAIN IN CORE DURING THE WHOLE REST OF THE
  12659. C    COMPUTATIONS
  12660. C
  12661. C    START LOOP FOR GENERATING ADJOINT INITIAL VALUE PROBLEMS
  12662.     K=0
  12663.     KK=0
  12664. 100    K=K+1
  12665.     IF(AUX(17,K))108,108,101
  12666. C
  12667. C    INITIALIZATION OF ADJOINT INITIAL VALUE PROBLEM
  12668. 101    X=PRMT(2)
  12669.     CALL AFCT(X,A)
  12670.     SUM=0.D0
  12671.     GL=AUX(18,K)
  12672.     DGL=AUX(19,K)
  12673.     II=K
  12674.     DO 104 I=1,NDIM
  12675.     H=-A(II)
  12676.     DERY(I)=H
  12677.     AUX(20,I)=R(I)
  12678.     Y(I)=0.D0
  12679.     IF(I-K)103,102,103
  12680. 102    Y(I)=1.D0
  12681. 103    DGL=DGL+H*AUX(18,I)
  12682. 104    II=II+NDIM
  12683.     XEND=PRMT(1)
  12684.     H=.0625D0*(XEND-X)
  12685.     ISW=0
  12686.     GOTO 400
  12687. C    THIS IS BRANCH TO ADJOINT LINEAR INITIAL VALUE PROBLEM
  12688. C
  12689. C    THIS IS RETURN FROM ADJOINT LINEAR INITIAL VALUE PROBLEM
  12690. 105    IF(IHLF-10)106,106,117
  12691. C
  12692. C    UPDATING OF COEFFICIENT MATRIX B AND VECTOR R
  12693. 106    DO 107 I=1,NDIM
  12694.     KK=KK+1
  12695.     H=C(KK)
  12696.     R(I)=AUX(20,I)+H*SUM
  12697.     II=I
  12698.     DO 107 J=1,NDIM
  12699.     B(II)=B(II)+H*Y(J)
  12700. 107    II=II+NDIM
  12701.     GOTO 109
  12702. 108    KK=KK+NDIM
  12703. 109    IF(K-NDIM)100,110,110
  12704. C
  12705. C
  12706. C    GENERATION OF LAST INITIAL VALUE PROBLEM
  12707. 110    EPS=PRMT(4)
  12708.     CALL DGELG(R,B,NDIM,1,EPS,I)
  12709.     IF(I)111,112,112
  12710. 111    IHLF=14
  12711.     RETURN
  12712. C
  12713. 112    PRMT(5)=0.D0
  12714.     IHLF=-I
  12715.     X=PRMT(1)
  12716.     XEND=PRMT(2)
  12717.     H=PRMT(3)
  12718.     DO 113 I=1,NDIM
  12719. 113    Y(I)=R(I)
  12720.     ISW=1
  12721. 114    ISW2=12
  12722.     GOTO 200
  12723. 115    ISW3=-1
  12724.     GOTO 300
  12725. 116    IF(IHLF)400,400,117
  12726. C    THIS WAS BRANCH INTO INITIAL VALUE PROBLEM
  12727. C
  12728. C    THIS IS RETURN FROM INITIAL VALUE PROBLEM
  12729. 117    RETURN
  12730. C
  12731. C    THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE RIGHT
  12732. C    HAND SIDE DERY OF THE SYSTEM OF ADJOINT LINEAR DIFFERENTIAL
  12733. C    EQUATIONS (IN CASE ISW=0) OR OF THE GIVEN SYSTEM (IN CASE ISW=1).
  12734. 200    CALL AFCT(X,A)
  12735.     IF(ISW)201,201,205
  12736. C
  12737. C    ADJOINT SYSTEM
  12738. 201    LL=0
  12739.     DO 203 M=1,NDIM
  12740.     HS=0.D0
  12741.     DO 202 L=1,NDIM
  12742.     LL=LL+1
  12743. 202    HS=HS-A(LL)*Y(L)
  12744. 203    DERY(M)=HS
  12745. 204    GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2
  12746. C
  12747. C    GIVEN SYSTEM
  12748. 205    CALL FCT(X,DERY)
  12749.     DO 207 M=1,NDIM
  12750.     LL=M-NDIM
  12751.     HS=0.D0
  12752.     DO 206 L=1,NDIM
  12753.     LL=LL+NDIM
  12754. 206    HS=HS+A(LL)*Y(L)
  12755. 207    DERY(M)=HS+DERY(M)
  12756.     GOTO 204
  12757. C
  12758. C    THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE VALUE OF
  12759. C    INTEGRAL SUM, WHICH IS A PART OF THE OUTPUT OF ADJOINT INITIAL
  12760. C    VALUE PROBLEM (IN CASE ISW=0) OR RECORDS RESULT VALUES OF THE
  12761. C    FINAL INITIAL VALUE PROBLEM (IN CASE ISW=1).
  12762. 300    IF(ISW)301,301,305
  12763. C
  12764. C    ADJOINT PROBLEM
  12765. 301    CALL FCT(X,R)
  12766.     GU=0.D0
  12767.     DGU=0.D0
  12768.     DO 302 L=1,NDIM
  12769.     GU=GU+Y(L)*R(L)
  12770. 302    DGU=DGU+DERY(L)*R(L)
  12771.     CALL DFCT(X,R)
  12772.     DO 303 L=1,NDIM
  12773. 303    DGU=DGU+Y(L)*R(L)
  12774.     SUM=SUM+.5D0*H*((GL+GU)+.16666666666666667D0*H*(DGL-DGU))
  12775.     GL=GU
  12776.     DGL=DGU
  12777. 304    IF(ISW3)116,422,618
  12778. C
  12779. C    GIVEN PROBLEM
  12780. 305    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  12781.     IF(PRMT(5))117,304,117
  12782. C
  12783. C    POSSIBLE BREAK-POINT FOR LINKAGE
  12784. C
  12785. C    THE FOLLOWING PART OF SUBROUTINE DLBVP SOLVES IN CASE ISW=0 THE
  12786. C    ADJOINT INITIAL VALUE PROBLEM. IT COMPUTES INTEGRAL SUM AND
  12787. C    THE VECTOR Y OF DEPENDENT VARIABLES AT THE LOWER BOUND PRMT(1).
  12788. C    IN CASE ISW=1 IT SOLVES FINALLY GENERATED INITIAL VALUE PROBLEM.
  12789. 400    N=1
  12790.     XST=X
  12791.     IHLF=0
  12792.     DO 401 I=1,NDIM
  12793.     AUX(16,I)=0.D0
  12794.     AUX(1,I)=Y(I)
  12795. 401    AUX(8,I)=DERY(I)
  12796.     ISW1=1
  12797.     GOTO 500
  12798. C
  12799. 402    X=X+H
  12800.     DO 403 I=1,NDIM
  12801. 403    AUX(2,I)=Y(I)
  12802. C
  12803. C    INCREMENT H IS TESTED BY MEANS OF BISECTION
  12804. 404    IHLF=IHLF+1
  12805.     X=X-H
  12806.     DO 405 I=1,NDIM
  12807. 405    AUX(4,I)=AUX(2,I)
  12808.     H=.5D0*H
  12809.     N=1
  12810.     ISW1=2
  12811.     GOTO 500
  12812. C
  12813. 406    X=X+H
  12814.     ISW2=4
  12815.     GOTO 200
  12816. 407    N=2
  12817.     DO 408 I=1,NDIM
  12818.     AUX(2,I)=Y(I)
  12819. 408    AUX(9,I)=DERY(I)
  12820.     ISW1=3
  12821.     GOTO 500
  12822. C
  12823. C    TEST ON SATISFACTORY ACCURACY
  12824. 409    DO 414 I=1,NDIM
  12825.     Z=DABS(Y(I))
  12826.     IF(Z-1.D0)410,411,411
  12827. 410    Z=1.D0
  12828. 411    DELT=.066666666666666667D0*DABS(Y(I)-AUX(4,I))
  12829.     IF(ISW)413,413,412
  12830. 412    DELT=AUX(15,I)*DELT
  12831. 413    IF(DELT-Z*PRMT(4))414,414,429
  12832. 414    CONTINUE
  12833. C
  12834. C    SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
  12835.     X=X+H
  12836.     ISW2=5
  12837.     GOTO 200
  12838. 415    DO 416 I=1,NDIM
  12839.     AUX(3,I)=Y(I)
  12840. 416    AUX(10,I)=DERY(I)
  12841.     N=3
  12842.     ISW1=4
  12843.     GOTO 500
  12844. C
  12845. 417    N=1
  12846.     X=X+H
  12847.     ISW2=6
  12848.     GOTO 200
  12849. 418    X=XST
  12850.     DO 419 I=1,NDIM
  12851.     AUX(11,I)=DERY(I)
  12852.   419    Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
  12853.      1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
  12854. 420    X=X+H
  12855.     N=N+1
  12856.     ISW2=11
  12857.     GOTO 200
  12858. 421    ISW3=0
  12859.     GOTO 300
  12860. 422    IF(N-4)423,600,600
  12861. 423    DO 424 I=1,NDIM
  12862.     AUX(N,I)=Y(I)
  12863. 424    AUX(N+7,I)=DERY(I)
  12864.     IF(N-3)425,427,600
  12865. C
  12866. 425    DO 426 I=1,NDIM
  12867.     DELT=AUX(9,I)+AUX(9,I)
  12868.     DELT=DELT+DELT
  12869. 426    Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
  12870.     GOTO 420
  12871. C
  12872. 427    DO 428 I=1,NDIM
  12873.     DELT=AUX(9,I)+AUX(10,I)
  12874.     DELT=DELT+DELT+DELT
  12875. 428    Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
  12876.     GOTO 420
  12877. C
  12878. C    NO SATISFACTORY ACCURACY. H MUST BE HALVED.
  12879. 429    IF(IHLF-10)404,430,430
  12880. C
  12881. C    NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
  12882. 430    IHLF=11
  12883.     X=X+H
  12884.     IF(ISW)105,105,114
  12885. C
  12886. C    THIS PART OF LINEAR INITIAL VALUE PROBLEM COMPUTES
  12887. C    STARTING VALUES BY MEANS OF RUNGE-KUTTA METHOD.
  12888. 500    Z=X
  12889.     DO 501 I=1,NDIM
  12890.     X=H*AUX(N+7,I)
  12891.     AUX(5,I)=X
  12892. 501    Y(I)=AUX(N,I)+.4D0*X
  12893. C
  12894.     X=Z+.4D0*H
  12895.     ISW2=1
  12896.     GOTO 200
  12897. 502    DO 503 I=1,NDIM
  12898.     X=H*DERY(I)
  12899.     AUX(6,I)=X
  12900. 503    Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X
  12901. C
  12902.     X=Z+.45573725421878943D0*H
  12903.     ISW2=2
  12904.     GOTO 200
  12905. 504    DO 505 I=1,NDIM
  12906.     X=H*DERY(I)
  12907.     AUX(7,I)=X
  12908. 505   Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
  12909.      1AUX(6,I)+3.8328647604670103D0*X
  12910. C
  12911.     X=Z+H
  12912.     ISW2=3
  12913.     GOTO 200
  12914. 506    DO 507 I=1,NDIM
  12915.   507 Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
  12916.      1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
  12917.      2H*DERY(I)
  12918.     X=Z
  12919.     GOTO(402,406,409,417),ISW1
  12920. C
  12921. C    POSSIBLE BREAK-POINT FOR LINKAGE
  12922. C
  12923. C    STARTING VALUES ARE COMPUTED.
  12924. C    NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
  12925. 600    ISTEP=3
  12926. 601    IF(N-8)604,602,604
  12927. C
  12928. C    N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
  12929. 602    DO 603 N=2,7
  12930.     DO 603 I=1,NDIM
  12931.     AUX(N-1,I)=AUX(N,I)
  12932. 603    AUX(N+6,I)=AUX(N+7,I)
  12933.     N=7
  12934. C
  12935. C    N LESS THAN 8 CAUSES N+1 TO GET N
  12936. 604    N=N+1
  12937. C
  12938. C    COMPUTATION OF NEXT VECTOR Y
  12939.     DO 605 I=1,NDIM
  12940.     AUX(N-1,I)=Y(I)
  12941. 605    AUX(N+6,I)=DERY(I)
  12942.     X=X+H
  12943. 606    ISTEP=ISTEP+1
  12944.     DO 607 I=1,NDIM
  12945.     DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
  12946.      1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
  12947.     Y(I)=DELT-.9256198347107438D0*AUX(16,I)
  12948. 607    AUX(16,I)=DELT
  12949. C    PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
  12950. C    IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
  12951. C
  12952.     ISW2=7
  12953.     GOTO 200
  12954. C    DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY.
  12955. C
  12956. 608    DO 609 I=1,NDIM
  12957.       DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
  12958.      1+AUX(N+6,I)-AUX(N+5,I)))
  12959.     AUX(16,I)=AUX(16,I)-DELT
  12960. 609    Y(I)=DELT+.07438016528925620D0*AUX(16,I)
  12961. C
  12962. C    TEST WHETHER H MUST BE HALVED OR DOUBLED
  12963.     DELT=0.D0
  12964.     DO 616 I=1,NDIM
  12965.     Z=DABS(Y(I))
  12966.     IF(Z-1.D0)610,611,611
  12967. 610    Z=1.D0
  12968. 611    Z=DABS(AUX(16,I))/Z
  12969.     IF(ISW)613,613,612
  12970. 612    Z=AUX(15,I)*Z
  12971. 613    IF(Z-PRMT(4))614,614,628
  12972. 614    IF(DELT-Z)615,616,616
  12973. 615    DELT=Z
  12974. 616    CONTINUE
  12975. C
  12976. C    H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
  12977.     ISW2=8
  12978.     GOTO 200
  12979. 617    ISW3=1
  12980.     GOTO 300
  12981. 618    IF(H*(X-XEND))619,621,621
  12982. 619    IF(DABS(X-XEND)-.1D0*DABS(H))621,620,620
  12983. 620    IF(DELT-.02D0*PRMT(4))622,622,601
  12984. 621    IF(ISW)105,105,117
  12985. C
  12986. C    H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
  12987. C    AVAILABLE.
  12988. 622    IF(IHLF)601,601,623
  12989. 623    IF(N-7)601,624,624
  12990. 624    IF(ISTEP-4)601,625,625
  12991. 625    IMOD=ISTEP/2
  12992.     IF(ISTEP-IMOD-IMOD)601,626,601
  12993. 626    H=H+H
  12994.     IHLF=IHLF-1
  12995.     ISTEP=0
  12996.     DO 627 I=1,NDIM
  12997.     AUX(N-1,I)=AUX(N-2,I)
  12998.     AUX(N-2,I)=AUX(N-4,I)
  12999.     AUX(N-3,I)=AUX(N-6,I)
  13000.     AUX(N+6,I)=AUX(N+5,I)
  13001.     AUX(N+5,I)=AUX(N+3,I)
  13002.     AUX(N+4,I)=AUX(N+1,I)
  13003.     DELT=AUX(N+6,I)+AUX(N+5,I)
  13004.     DELT=DELT+DELT+DELT
  13005.   627    AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
  13006.      1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
  13007.     GOTO 601
  13008. C
  13009. C    H MUST BE HALVED
  13010. 628    IHLF=IHLF+1
  13011.     IF(IHLF-10)630,630,629
  13012. 629    IF(ISW)105,105,114
  13013. 630    H=.5D0*H
  13014.     ISTEP=0
  13015.     DO 631 I=1,NDIM
  13016.       Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
  13017.      1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
  13018.          AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
  13019.      1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
  13020.      218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
  13021.     AUX(N-3,I)=AUX(N-2,I)
  13022. 631    AUX(N+4,I)=AUX(N+5,I)
  13023.     DELT=X-H
  13024.     X=DELT-(H+H)
  13025.     ISW2=9
  13026.     GOTO 200
  13027. 632    DO 633 I=1,NDIM
  13028.     AUX(N-2,I)=Y(I)
  13029.     AUX(N+5,I)=DERY(I)
  13030. 633    Y(I)=AUX(N-4,I)
  13031.     X=X-(H+H)
  13032.     ISW2=10
  13033.     GOTO 200
  13034. 634    X=DELT
  13035.     DO 635 I=1,NDIM
  13036.     DELT=AUX(N+5,I)+AUX(N+4,I)
  13037.     DELT=DELT+DELT+DELT
  13038.          AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
  13039.      1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
  13040. 635    AUX(N+3,I)=DERY(I)
  13041.     GOTO 606
  13042. C    END OF INITIAL VALUE PROBLEM
  13043.     END
  13044. C
  13045. C    ..................................................................
  13046. C
  13047. C       SUBROUTINE DLEP
  13048. C
  13049. C       PURPOSE
  13050. C          COMPUTE THE VALUES OF THE LEGENDRE POLYNOMIALS P(N,X)
  13051. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  13052. C
  13053. C       USAGE
  13054. C          CALL DLEP(Y,X,N)
  13055. C
  13056. C       DESCRIPTION OF PARAMETERS
  13057. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  13058. C                  OF LEGENDRE POLYNOMIALS OF ORDER 0 UP TO N
  13059. C                  FOR GIVEN ARGUMENT X.
  13060. C                  DOUBLE PRECISION VECTOR.
  13061. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  13062. C          X     - ARGUMENT OF LEGENDRE POLYNOMIAL
  13063. C                  DOUBLE PRECISION VARIABLE.
  13064. C          N     - ORDER OF LEGENDRE POLYNOMIAL
  13065. C
  13066. C       REMARKS
  13067. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  13068. C
  13069. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13070. C          NONE
  13071. C
  13072. C       METHOD
  13073. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  13074. C          LEGENDRE POLYNOMIALS P(N,X)
  13075. C          P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
  13076. C          WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
  13077. C          THE SECOND IS THE ARGUMENT.
  13078. C          STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
  13079. C
  13080. C    ..................................................................
  13081. C
  13082.     SUBROUTINE DLEP(Y,X,N)
  13083. C
  13084.     DIMENSION Y(1)
  13085.     DOUBLE PRECISION Y,X,G
  13086. C
  13087. C       TEST OF ORDER
  13088.     Y(1)=1.D0
  13089.     IF(N)1,1,2
  13090. 1    RETURN
  13091. C
  13092. 2    Y(2)=X
  13093.     IF(N-1)1,1,3
  13094. C
  13095. 3    DO 4 I=2,N
  13096.     G=X*Y(I)
  13097. 4    Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/DFLOAT(I)
  13098.     RETURN
  13099.     END
  13100. C
  13101. C    ..................................................................
  13102. C
  13103. C       SUBROUTINE DLEPS
  13104. C
  13105. C       PURPOSE
  13106. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LEGENDRE
  13107. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  13108. C
  13109. C       USAGE
  13110. C          CALL DLEPS(Y,X,C,N)
  13111. C
  13112. C       DESCRIPTION OF PARAMETERS
  13113. C          Y     - RESULT VALUE
  13114. C                  DOUBLE PRECISION VARIABLE
  13115. C          X     - ARGUMENT VALUE
  13116. C                  DOUBLE PRECISION VARIABLE
  13117. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  13118. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  13119. C                  DOUBLE PRECISION VECTOR
  13120. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  13121. C
  13122. C       REMARKS
  13123. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  13124. C
  13125. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13126. C          NONE
  13127. C
  13128. C       METHOD
  13129. C          DEFINITION
  13130. C          Y=SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
  13131. C          EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
  13132. C          USING THE RECURRENCE EQUATION FOR LEGENDRE POLYNOMIALS
  13133. C          P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1).
  13134. C
  13135. C    ..................................................................
  13136. C
  13137.     SUBROUTINE DLEPS(Y,X,C,N)
  13138. C
  13139.     DIMENSION C(1)
  13140.     DOUBLE PRECISION C,Y,X,H0,H1,H2
  13141. C
  13142. C       TEST OF DIMENSION
  13143.     IF(N)1,1,2
  13144. 1    RETURN
  13145. C
  13146. 2    Y=C(1)
  13147.     IF(N-2)1,3,3
  13148. C
  13149. C       INITIALIZATION
  13150. 3    H0=1.D0
  13151.     H1=X
  13152. C
  13153.     DO 4 I=2,N
  13154.     H2=X*H1
  13155.     H2=H2-H0+H2-(H2-H0)/DFLOAT(I)
  13156.     H0=H1
  13157.     H1=H2
  13158. 4    Y=Y+C(I)*H0
  13159.     RETURN
  13160.     END
  13161. C
  13162. C    ..................................................................
  13163. C
  13164. C       SUBROUTINE DLGAM
  13165. C
  13166. C       PURPOSE
  13167. C          COMPUTES THE DOUBLE PRECISION NATURAL LOGARITHM OF THE
  13168. C          GAMMA FUNCTION OF A GIVEN DOUBLE PRECISION ARGUMENT.
  13169. C
  13170. C       USAGE
  13171. C          CALL DLGAM(XX,DLNG,IER)
  13172. C
  13173. C       DESCRIPTION OF PARAMETERS
  13174. C          XX   - THE DOUBLE PRECISION ARGUMENT FOR THE LOG GAMMA
  13175. C                 FUNCTION.
  13176. C          DLNG - THE RESULTANT DOUBLE PRECISION LOG GAMMA FUNCTION
  13177. C                 VALUE.
  13178. C          IER  - RESULTANT ERROR CODE WHERE
  13179. C                 IER= 0----NO ERROR.
  13180. C                 IER=-1----XX IS WITHIN 10**(-9) OF BEING ZERO OR XX
  13181. C                           IS NEGATIVE.  DLNG IS SET TO -1.OD75.
  13182. C                 IER=+1----XX IS GREATER THAN 10**70. DLNG IS SET TO
  13183. C                           +1.OD75.
  13184. C
  13185. C       REMARKS
  13186. C          NONE
  13187. C
  13188. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13189. C          NONE
  13190. C
  13191. C       METHOD
  13192. C          THE EULER-MCLAURIN EXPANSION TO THE SEVENTH DERIVATIVE TERM
  13193. C          IS USED, AS GIVEN BY M. ABRAMOWITZ AND I.A. STEGUN,
  13194. C          'HANDBOOK OF MATHEMATICAL FUNCTIONS', U. S. DEPARTMENT OF
  13195. C          COMMERCE, NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
  13196. C          SERIES, 1966, EQUATION 6.1.41.
  13197. C
  13198. C    ..................................................................
  13199. C
  13200.     SUBROUTINE DLGAM(XX,DLNG,IER)
  13201.     DOUBLE PRECISION XX,ZZ,TERM,RZ2,DLNG
  13202.     IER=0
  13203.     ZZ=XX
  13204.     IF(XX-1.D10) 2,2,1
  13205. 1    IF(XX-1.7D33) 8,9,9                                                       0
  13206. C
  13207. C       SEE IF XX IS NEAR ZERO OR NEGATIVE
  13208. C
  13209. 2    IF(XX-1.D-9) 3,3,4
  13210. 3    IER=-1
  13211.     DLNG=-1.7D38                                                              0
  13212.     GO TO 10
  13213. C
  13214. C       XX GREATER THAN ZERO AND LESS THAN OR EQUAL TO 1.D+10
  13215. C
  13216. 4    TERM=1.D0
  13217. 5    IF(ZZ-18.D0) 6,6,7
  13218. 6    TERM=TERM*ZZ
  13219.     ZZ=ZZ+1.D0
  13220.     GO TO 5
  13221. 7    RZ2=1.D0/ZZ**2
  13222.     DLNG =(ZZ-0.5D0)*DLOG(ZZ)-ZZ +0.9189385332046727 -DLOG(TERM)+
  13223.      1(1.D0/ZZ)*(.8333333333333333D-1 -(RZ2*(.2777777777777777D-2 +(RZ2*
  13224.      2(.7936507936507936D-3 -(RZ2*(.5952380952380952D-3)))))))
  13225.     GO TO 10
  13226. C
  13227. C       XX GREATER THAN 1.D+10 AND LESS THAN 1.D+70
  13228. C
  13229. 8    DLNG=ZZ*(DLOG(ZZ)-1.D0)
  13230.     GO TO 10
  13231. C
  13232. C       XX GREATER THAN OR EQUAL TO 1.D+70
  13233. C
  13234. 9    IER=+1
  13235.     DLNG=1.7D38                                                               0
  13236. 10    RETURN
  13237.     END
  13238. C
  13239. C    ..................................................................
  13240. C
  13241. C       SUBROUTINE DLLSQ
  13242. C
  13243. C       PURPOSE
  13244. C          TO SOLVE LINEAR LEAST SQUARES PROBLEMS, I.E. TO MINIMIZE
  13245. C          THE EUCLIDEAN NORM OF B-A*X, WHERE A IS A M BY N MATRIX
  13246. C          WITH M NOT LESS THAN N. IN THE SPECIAL CASE M=N SYSTEMS OF
  13247. C          LINEAR EQUATIONS MAY BE SOLVED.
  13248. C
  13249. C       USAGE
  13250. C          CALL DLLSQ (A,B,M,N,L,X,IPIV,EPS,IER,AUX)
  13251. C
  13252. C       DESCRIPTION OF PARAMETERS
  13253. C          A      - DOUBLE PRECISION M BY N COEFFICIENT MATRIX
  13254. C                   (DESTROYED).
  13255. C          B      - DOUBLE PRECISION M BY L RIGHT HAND SIDE MATRIX
  13256. C                   (DESTROYED).
  13257. C          M      - ROW NUMBER OF MATRICES A AND B.
  13258. C          N      - COLUMN NUMBER OF MATRIX A, ROW NUMBER OF MATRIX X.
  13259. C          L      - COLUMN NUMBER OF MATRICES B AND X.
  13260. C          X      - DOUBLE PRECISION N BY L SOLUTION MATRIX.
  13261. C          IPIV   - INTEGER OUTPUT VECTOR OF DIMENSION N WHICH
  13262. C                   CONTAINS INFORMATIONS ON COLUMN INTERCHANGES
  13263. C                   IN MATRIX A. (SEE REMARK NO.3).
  13264. C          EPS    - SINGLE PRECISION INPUT PARAMETER WHICH SPECIFIES
  13265. C                   A RELATIVE TOLERANCE FOR DETERMINATION OF RANK OF
  13266. C                   MATRIX A.
  13267. C          IER    - A RESULTING ERROR PARAMETER.
  13268. C          AUX    - A DOUBLE PRECISION AUXILIARY STORAGE ARRAY OF
  13269. C                   DIMENSION MAX(2*N,L). ON RETURN FIRST L LOCATIONS
  13270. C                   OF AUX CONTAIN THE RESULTING LEAST SQUARES.
  13271. C
  13272. C       REMARKS
  13273. C          (1) NO ACTION BESIDES ERROR MESSAGE IER=-2 IN CASE
  13274. C              M LESS THAN N.
  13275. C          (2) NO ACTION BESIDES ERROR MESSAGE IER=-1 IN CASE
  13276. C              OF A ZERO-MATRIX A.
  13277. C          (3) IF RANK K OF MATRIX A IS FOUND TO BE LESS THAN N BUT
  13278. C              GREATER THAN 0, THE PROCEDURE RETURNS WITH ERROR CODE
  13279. C              IER=K INTO CALLING PROGRAM. THE LAST N-K ELEMENTS OF
  13280. C              VECTOR IPIV DENOTE THE USELESS COLUMNS IN MATRIX A.
  13281. C              THE REMAINING USEFUL COLUMNS FORM A BASE OF MATRIX A.
  13282. C          (4) IF THE PROCEDURE WAS SUCCESSFUL, ERROR PARAMETER IER
  13283. C              IS SET TO 0.
  13284. C
  13285. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13286. C          NONE
  13287. C
  13288. C       METHOD
  13289. C          HOUSEHOLDER TRANSFORMATIONS ARE USED TO TRANSFORM MATRIX A
  13290. C          TO UPPER TRIANGULAR FORM. AFTER HAVING APPLIED THE SAME
  13291. C          TRANSFORMATION TO THE RIGHT HAND SIDE MATRIX B, AN
  13292. C          APPROXIMATE SOLUTION OF THE PROBLEM IS COMPUTED BY
  13293. C          BACK SUBSTITUTION. FOR REFERENCE, SEE
  13294. C          G. GOLUB, NUMERICAL METHODS FOR SOLVING LINEAR LEAST
  13295. C          SQUARES PROBLEMS, NUMERISCHE MATHEMATIK, VOL.7,
  13296. C          ISS.3 (1965), PP.206-216.
  13297. C
  13298. C    ..................................................................
  13299. C
  13300.     SUBROUTINE DLLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX)
  13301. C
  13302.     DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1)
  13303.     DOUBLE PRECISION A,B,X,AUX,PIV,H,SIG,BETA,TOL
  13304. C
  13305. C    ERROR TEST
  13306.     IF(M-N)30,1,1
  13307. C
  13308. C    GENERATION OF INITIAL VECTOR S(K) (K=1,2,...,N) IN STORAGE
  13309. C    LOCATIONS AUX(K) (K=1,2,...,N)
  13310. 1    PIV=0.D0
  13311.     IEND=0
  13312.     DO 4 K=1,N
  13313.     IPIV(K)=K
  13314.     H=0.D0
  13315.     IST=IEND+1
  13316.     IEND=IEND+M
  13317.     DO 2 I=IST,IEND
  13318. 2    H=H+A(I)*A(I)
  13319.     AUX(K)=H
  13320.     IF(H-PIV)4,4,3
  13321. 3    PIV=H
  13322.     KPIV=K
  13323. 4    CONTINUE
  13324. C
  13325. C    ERROR TEST
  13326.     IF(PIV)31,31,5
  13327. C
  13328. C    DEFINE TOLERANCE FOR CHECKING RANK OF A
  13329. 5    SIG=DSQRT(PIV)
  13330.     TOL=SIG*ABS(EPS)
  13331. C
  13332. C
  13333. C    DECOMPOSITION LOOP
  13334.     LM=L*M
  13335.     IST=-M
  13336.     DO 21 K=1,N
  13337.     IST=IST+M+1
  13338.     IEND=IST+M-K
  13339.     I=KPIV-K
  13340.     IF(I)8,8,6
  13341. C
  13342. C    INTERCHANGE K-TH COLUMN OF A WITH KPIV-TH IN CASE KPIV.GT.K
  13343. 6    H=AUX(K)
  13344.     AUX(K)=AUX(KPIV)
  13345.     AUX(KPIV)=H
  13346.     ID=I*M
  13347.     DO 7 I=IST,IEND
  13348.     J=I+ID
  13349.     H=A(I)
  13350.     A(I)=A(J)
  13351. 7    A(J)=H
  13352. C
  13353. C    COMPUTATION OF PARAMETER SIG
  13354. 8    IF(K-1)11,11,9
  13355. 9    SIG=0.D0
  13356.     DO 10 I=IST,IEND
  13357. 10    SIG=SIG+A(I)*A(I)
  13358.     SIG=DSQRT(SIG)
  13359. C
  13360. C    TEST ON SINGULARITY
  13361.     IF(SIG-TOL)32,32,11
  13362. C
  13363. C    GENERATE CORRECT SIGN OF PARAMETER SIG
  13364. 11    H=A(IST)
  13365.     IF(H)12,13,13
  13366. 12    SIG=-SIG
  13367. C
  13368. C    SAVE INTERCHANGE INFORMATION
  13369. 13    IPIV(KPIV)=IPIV(K)
  13370.     IPIV(K)=KPIV
  13371. C
  13372. C    GENERATION OF VECTOR UK IN K-TH COLUMN OF MATRIX A AND OF
  13373. C    PARAMETER BETA
  13374.     BETA=H+SIG
  13375.     A(IST)=BETA
  13376.     BETA=1.D0/(SIG*BETA)
  13377.     J=N+K
  13378.     AUX(J)=-SIG
  13379.     IF(K-N)14,19,19
  13380. C
  13381. C    TRANSFORMATION OF MATRIX A
  13382. 14    PIV=0.D0
  13383.     ID=0
  13384.     JST=K+1
  13385.     KPIV=JST
  13386.     DO 18 J=JST,N
  13387.     ID=ID+M
  13388.     H=0.D0
  13389.     DO 15 I=IST,IEND
  13390.     II=I+ID
  13391. 15    H=H+A(I)*A(II)
  13392.     H=BETA*H
  13393.     DO 16 I=IST,IEND
  13394.     II=I+ID
  13395. 16    A(II)=A(II)-A(I)*H
  13396. C
  13397. C    UPDATING OF ELEMENT S(J) STORED IN LOCATION AUX(J)
  13398.     II=IST+ID
  13399.     H=AUX(J)-A(II)*A(II)
  13400.     AUX(J)=H
  13401.     IF(H-PIV)18,18,17
  13402. 17    PIV=H
  13403.     KPIV=J
  13404. 18    CONTINUE
  13405. C
  13406. C    TRANSFORMATION OF RIGHT HAND SIDE MATRIX B
  13407. 19    DO 21 J=K,LM,M
  13408.     H=0.D0
  13409.     IEND=J+M-K
  13410.     II=IST
  13411.     DO 20 I=J,IEND
  13412.     H=H+A(II)*B(I)
  13413. 20    II=II+1
  13414.     H=BETA*H
  13415.     II=IST
  13416.     DO 21 I=J,IEND
  13417.     B(I)=B(I)-A(II)*H
  13418. 21    II=II+1
  13419. C    END OF DECOMPOSITION LOOP
  13420. C
  13421. C
  13422. C    BACK SUBSTITUTION AND BACK INTERCHANGE
  13423.     IER=0
  13424.     I=N
  13425.     LN=L*N
  13426.     PIV=1.D0/AUX(2*N)
  13427.     DO 22 K=N,LN,N
  13428.     X(K)=PIV*B(I)
  13429. 22    I=I+M
  13430.     IF(N-1)26,26,23
  13431. 23    JST=(N-1)*M+N
  13432.     DO 25 J=2,N
  13433.     JST=JST-M-1
  13434.     K=N+N+1-J
  13435.     PIV=1.D0/AUX(K)
  13436.     KST=K-N
  13437.     ID=IPIV(KST)-KST
  13438.     IST=2-J
  13439.     DO 25 K=1,L
  13440.     H=B(KST)
  13441.     IST=IST+N
  13442.     IEND=IST+J-2
  13443.     II=JST
  13444.     DO 24 I=IST,IEND
  13445.     II=II+M
  13446. 24    H=H-A(II)*X(I)
  13447.     I=IST-1
  13448.     II=I+ID
  13449.     X(I)=X(II)
  13450.     X(II)=PIV*H
  13451. 25    KST=KST+M
  13452. C
  13453. C
  13454. C    COMPUTATION OF LEAST SQUARES
  13455. 26    IST=N+1
  13456.     IEND=0
  13457.     DO 29 J=1,L
  13458.     IEND=IEND+M
  13459.     H=0.D0
  13460.     IF(M-N)29,29,27
  13461. 27    DO 28 I=IST,IEND
  13462. 28    H=H+B(I)*B(I)
  13463.     IST=IST+M
  13464. 29    AUX(J)=H
  13465.     RETURN
  13466. C
  13467. C    ERROR RETURN IN CASE M LESS THAN N
  13468. 30    IER=-2
  13469.     RETURN
  13470. C
  13471. C    ERROR RETURN IN CASE OF ZERO-MATRIX A
  13472. 31    IER=-1
  13473.     RETURN
  13474. C
  13475. C    ERROR RETURN IN CASE OF RANK OF MATRIX A LESS THAN N
  13476. 32    IER=K-1
  13477.     RETURN
  13478.     END
  13479. C
  13480. C    ..................................................................
  13481. C
  13482. C       SUBROUTINE DMATX
  13483. C
  13484. C       PURPOSE
  13485. C          COMPUTE MEANS OF VARIABLES IN EACH GROUP AND A POOLED
  13486. C          DISPERSION MATRIX FOR ALL THE GROUPS. NORMALLY THIS SUB-
  13487. C          ROUTINE IS USED IN THE PERFORMANCE OF DISCRIMINANT ANALYSIS.
  13488. C
  13489. C       USAGE
  13490. C          CALL DMATX (K,M,N,X,XBAR,D,CMEAN)
  13491. C
  13492. C       DESCRIPTION OF PARAMETERS
  13493. C          K     - NUMBER OF GROUPS
  13494. C          M     - NUMBER OF VARIABLES (MUST BE THE SAME FOR ALL
  13495. C                  GROUPS).
  13496. C          N     - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF
  13497. C                  GROUPS.
  13498. C          X     - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA-
  13499. C                  LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1),
  13500. C                  X(2,1,1), X(3,1,1), ETC.  THE FIRST SUBSCRIPT IS
  13501. C                  CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER
  13502. C                  AND THE THIRD SUBSCRIPT IS GROUP NUMBER.  THE
  13503. C                  LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF
  13504. C                  DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K).
  13505. C          XBAR  - OUTPUT MATRIX (M X K) CONTAINING MEANS OF VARIABLES
  13506. C                  IN K GROUPS.
  13507. C          D     - OUTPUT MATRIX (M X M) CONTAINING POOLED DISPERSION.
  13508. C          CMEAN - WORKING VECTOR OF LENGTH M.
  13509. C
  13510. C       REMARKS
  13511. C          THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO
  13512. C          THE NUMBER OF GROUPS.
  13513. C
  13514. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13515. C          NONE
  13516. C
  13517. C       METHOD
  13518. C          REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
  13519. C          DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO
  13520. C          MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS,
  13521. C          1958, SECTION 6.6-6.8.
  13522. C
  13523. C    ..................................................................
  13524. C
  13525.     SUBROUTINE DMATX (K,M,N,X,XBAR,D,CMEAN)
  13526.     DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1)
  13527. C
  13528. C       ...............................................................
  13529. C
  13530. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  13531. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  13532. C       STATEMENT WHICH FOLLOWS.
  13533. C
  13534. C    DOUBLE PRECISION XBAR,D,CMEAN
  13535. C
  13536. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  13537. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  13538. C       ROUTINE.
  13539. C
  13540. C       ...............................................................
  13541. C
  13542. C    INITIALIZATION
  13543. C
  13544.     MM=M*M
  13545.     DO 100 I=1,MM
  13546. 100    D(I)=0.0
  13547. C
  13548. C    CALCULATE MEANS
  13549. C
  13550.     N4=0
  13551.     L=0
  13552.     LM=0
  13553.     DO 160 NG=1,K
  13554.     N1=N(NG)
  13555.     FN=N1
  13556.     DO 130 J=1,M
  13557.     LM=LM+1
  13558.     XBAR(LM)=0.0
  13559.     DO 120 I=1,N1
  13560.     L=L+1
  13561. 120    XBAR(LM)=XBAR(LM)+X(L)
  13562. 130    XBAR(LM)=XBAR(LM)/FN
  13563. C
  13564. C    CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
  13565. C
  13566.     LMEAN=LM-M
  13567.     DO 150 I=1,N1
  13568.     LL=N4+I-N1
  13569.     DO 140 J=1,M
  13570.     LL=LL+N1
  13571.     N2=LMEAN+J
  13572. 140    CMEAN(J)=X(LL)-XBAR(N2)
  13573.     LL=0
  13574.     DO 150 J=1,M
  13575.     DO 150 JJ=1,M
  13576.     LL=LL+1
  13577. 150    D(LL)=D(LL)+CMEAN(J)*CMEAN(JJ)
  13578. 160    N4=N4+N1*M
  13579. C
  13580. C    CALCULATE THE POOLED DISPERSION MATRIX
  13581. C
  13582.     LL=-K
  13583.     DO 170 I=1,K
  13584. 170    LL=LL+N(I)
  13585.     FN=LL
  13586.     DO 180 I=1,MM
  13587. 180    D(I)=D(I)/FN
  13588. C
  13589.     RETURN
  13590.     END
  13591. C
  13592. C    ..................................................................
  13593. C
  13594. C       SUBROUTINE DMCHB
  13595. C
  13596. C       PURPOSE
  13597. C          FOR A GIVEN POSITIVE-DEFINITE M BY M MATRIX A WITH SYMMETRIC
  13598. C          BAND STRUCTURE AND - IF NECESSARY - A GIVEN GENERAL M BY N
  13599. C          MATRIX R, THE FOLLOWING CALCULATIONS (DEPENDENT ON THE
  13600. C          VALUE OF THE DECISION PARAMETER IOP) ARE PERFORMED
  13601. C          (1) MATRIX A IS FACTORIZED (IF IOP IS NOT NEGATIVE), THAT
  13602. C              MEANS BAND MATRIX TU WITH UPPER CODIAGONALS ONLY IS
  13603. C              GENERATED ON THE LOCATIONS OF A SUCH THAT
  13604. C              TRANSPOSE(TU)*TU=A.
  13605. C          (2) MATRIX R IS MULTIPLIED ON THE LEFT BY INVERSE(TU)
  13606. C              AND/OR INVERSE(TRANSPOSE(TU)) AND THE RESULT IS STORED
  13607. C              IN THE LOCATIONS OF R.
  13608. C          THIS SUBROUTINE ESPECIALLY CAN BE USED TO SOLVE THE SYSTEM
  13609. C          OF SIMULTANEOUS LINEAR EQUATIONS A*X=R WITH POSITIVE-
  13610. C          DEFINITE COEFFICIENT MATRIX A OF SYMMETRIC BAND STRUCTURE.
  13611. C
  13612. C       USAGE
  13613. C          CALL DMCHB (R,A,M,N,MUD,IOP,EPS,IER)
  13614. C
  13615. C       DESCRIPTION OF PARAMETERS
  13616. C          R      - INPUT IN CASES IOP=-3,-2,-1,1,2,3  DOUBLE PRECISION
  13617. C                         M BY N RIGHT HAND SIDE MATRIX,
  13618. C                         IN CASE IOP=0  IRRELEVANT.
  13619. C                   OUTPUT IN CASES IOP=1,-1  INVERSE(A)*R,
  13620. C                          IN CASES IOP=2,-2  INVERSE(TU)*R,
  13621. C                          IN CASES IOP=3,-3  INVERSE(TRANSPOSE(TU))*R,
  13622. C                          IN CASE  IOP=0     UNCHANGED.
  13623. C          A      - INPUT IN CASES IOP=0,1,2,3  DOUBLE PRECISION M BY M
  13624. C                         POSITIVE-DEFINITE COEFFICIENT MATRIX OF
  13625. C                         SYMMETRIC BAND STRUCTURE STORED IN
  13626. C                         COMPRESSED FORM (SEE REMARKS),
  13627. C                         IN CASES IOP=-1,-2,-3 DOUBLE PRECISION M BY M
  13628. C                         BAND MATRIX TU WITH UPPER CODIAGONALS ONLY,
  13629. C                         STORED IN COMPRESSED FORM (SEE REMARKS).
  13630. C                   OUTPUT IN ALL CASES  BAND MATRIX TU WITH UPPER
  13631. C                          CODIAGONALS ONLY, STORED IN COMPRESSED FORM
  13632. C                          (THAT MEANS UNCHANGED IF IOP=-1,-2,-3).
  13633. C          M      - INPUT VALUE SPECIFYING THE NUMBER OF ROWS AND
  13634. C                   COLUMNS OF A AND THE NUMBER OF ROWS OF R.
  13635. C          N      - INPUT VALUE SPECIFYING THE NUMBER OF COLUMNS OF R
  13636. C                   (IRRELEVANT IN CASE IOP=0).
  13637. C          MUD    - INPUT VALUE SPECIFYING THE NUMBER OF UPPER
  13638. C                   CODIAGONALS OF A.
  13639. C          IOP    - ONE OF THE VALUES -3,-2,-1,0,1,2,3 GIVEN AS INPUT
  13640. C                   AND USED AS DECISION PARAMETER.
  13641. C          EPS    - SINGLE PRECISION INPUT VALUE USED AS RELATIVE
  13642. C                   TOLERANCE FOR TEST ON LOSS OF SIGNIFICANT DIGITS.
  13643. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  13644. C                    IER=0  - NO ERROR,
  13645. C                    IER=-1 - NO RESULT BECAUSE OF WRONG INPUT
  13646. C                             PARAMETERS M,MUD,IOP (SEE REMARKS),
  13647. C                             OR BECAUSE OF A NONPOSITIVE RADICAND AT
  13648. C                             SOME FACTORIZATION STEP,
  13649. C                             OR BECAUSE OF A ZERO DIAGONAL ELEMENT
  13650. C                             AT SOME DIVISION STEP.
  13651. C                    IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  13652. C                             CANCE INDICATED AT FACTORIZATION STEP K+1
  13653. C                             WHERE RADICAND WAS NO LONGER GREATER
  13654. C                             THAN EPS*A(K+1,K+1).
  13655. C
  13656. C       REMARKS
  13657. C          UPPER PART OF SYMMETRIC BAND MATRIX A CONSISTING OF MAIN
  13658. C          DIAGONAL AND MUD UPPER CODIAGONALS (RESP. BAND MATRIX TU
  13659. C          CONSISTING OF MAIN DIAGONAL AND MUD UPPER CODIAGONALS)
  13660. C          IS ASSUMED TO BE STORED IN COMPRESSED FORM, I.E. ROWWISE
  13661. C          IN TOTALLY NEEDED M+MUD*(2M-MUD-1)/2 SUCCESSIVE STORAGE
  13662. C          LOCATIONS. ON RETURN UPPER BAND FACTOR TU (ON THE LOCATIONS
  13663. C          OF A) IS STORED IN THE SAME WAY.
  13664. C          RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
  13665. C          IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN RESULT MATRIX
  13666. C          INVERSE(A)*R OR INVERSE(TU)*R OR INVERSE(TRANSPOSE(TU))*R
  13667. C          IS STORED COLUMNWISE TOO ON THE LOCATIONS OF R.
  13668. C          INPUT PARAMETERS M, MUD, IOP SHOULD SATISFY THE FOLLOWING
  13669. C          RESTRICTIONS     MUD NOT LESS THAN ZERO,
  13670. C                           1+MUD NOT GREATER THAN M,
  13671. C                           ABS(IOP) NOT GREATER THAN 3.
  13672. C          NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
  13673. C          RESTRICTIONS ARE NOT SATISFIED.
  13674. C          THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
  13675. C          PARAMETERS ARE SATISFIED, IF RADICANDS AT ALL FACTORIZATION
  13676. C          STEPS ARE POSITIVE AND/OR IF ALL DIAGONAL ELEMENTS OF
  13677. C          UPPER BAND FACTOR TU ARE NONZERO.
  13678. C
  13679. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13680. C          NONE
  13681. C
  13682. C       METHOD
  13683. C          FACTORIZATION IS DONE USING CHOLESKY-S SQUARE-ROOT METHOD,
  13684. C          WHICH GENERATES THE UPPER BAND MATRIX TU SUCH THAT
  13685. C          TRANSPOSE(TU)*TU=A. TU IS RETURNED AS RESULT ON THE
  13686. C          LOCATIONS OF A. FURTHER, DEPENDENT ON THE ACTUAL VALUE OF
  13687. C          IOP, DIVISION OF R BY TRANSPOSE(TU) AND/OR TU IS PERFORMED
  13688. C          AND THE RESULT IS RETURNED ON THE LOCATIONS OF R.
  13689. C          FOR REFERENCE, SEE H. RUTISHAUSER, ALGORITHMUS 1 - LINEARES
  13690. C          GLEICHUNGSSYSTEM MIT SYMMETRISCHER POSITIV-DEFINITER
  13691. C          BANDMATRIX NACH CHOLESKY - , COMPUTING (ARCHIVES FOR
  13692. C          ELECTRONIC COMPUTING), VOL.1, ISS.1 (1966), PP.77-78.
  13693. C
  13694. C    ..................................................................
  13695. C
  13696. c    SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER)
  13697. cC
  13698. cC
  13699. c    DIMENSION R(1),A(1)
  13700. c    DOUBLE PRECISION TOL,SUM,PIV,R,A
  13701. cC
  13702. cC       TEST ON WRONG INPUT PARAMETERS
  13703. c    IF(IABS(IOP)-3)1,1,43
  13704. c1    IF(MUD)43,2,2
  13705. c2    MC=MUD+1
  13706. c    IF(M-MC)43,3,3
  13707. c3    MR=M-MUD
  13708. c    IER=0
  13709. cC
  13710. cC       MC IS THE MAXIMUM NUMBER OF ELEMENTS IN THE ROWS OF ARRAY A
  13711. cC       MR IS THE INDEX OF THE LAST ROW IN ARRAY A WITH MC ELEMENTS
  13712. cC
  13713. cC    ******************************************************************
  13714. cC
  13715. cC       START FACTORIZATION OF MATRIX A
  13716. c    IF(IOP)24,4,4
  13717. c4    IEND=0
  13718. c    LLDST=MUD
  13719. c    DO 23 K=1,M
  13720. c    IST=IEND+1
  13721. c    IEND=IST+MUD
  13722. c    J=K-MR
  13723. c    IF(J)6,6,5
  13724. c5    IEND=IEND-J
  13725. c6    IF(J-1)8,8,7
  13726. c7    LLDST=LLDST-1
  13727. c8    LMAX=MUD
  13728. c    J=MC-K
  13729. c    IF(J)10,10,9
  13730. c9    LMAX=LMAX-J
  13731. c10    ID=0
  13732. c    TOL=A(IST)*EPS
  13733. cC
  13734. cC       START FACTORIZATION-LOOP OVER K-TH ROW
  13735. c    DO 23 I=IST,IEND
  13736. c    SUM=0.D0
  13737. c    IF(LMAX)14,14,11
  13738. cC
  13739. cC       PREPARE INNER LOOP
  13740. c11    LL=IST
  13741. c    LLD=LLDST
  13742. cC
  13743. cC       START INNER LOOP
  13744. c    DO 13 L=1,LMAX
  13745. c    LL=LL-LLD
  13746. c    LLL=LL+ID
  13747. c    SUM=SUM+A(LL)*A(LLL)
  13748. c    IF(LLD-MUD)12,13,13
  13749. c12    LLD=LLD+1
  13750. c13    CONTINUE
  13751.       SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER)
  13752.       DIMENSION R(1),A(1)
  13753.       DOUBLE PRECISION TOL,SUM,PIV,R,A
  13754.       IF(IABS(IOP)-3)1,1,43
  13755.     1 IF(MUD)43,2,2
  13756.     2 MC=MUD+1
  13757.       IF(M-MC)43,3,3
  13758.     3 MR=M-MUD
  13759.       IER=0
  13760.       IF(IOP)24,4,4
  13761.     4 IEND=0
  13762.       LLDST=MUD
  13763.       DO 23 K=1,M
  13764.       IST=IEND+1
  13765.       IEND=IST+MUD
  13766.       J=K-MR
  13767.       IF(J)6,6,5
  13768.     5 IEND=IEND-J
  13769.     6 IF(J-1)8,8,7
  13770.     7 LLDST=LLDST-1
  13771.     8 LMAX=MUD
  13772.       J=MC-K
  13773.       IF(J)10,10,9
  13774.     9 LMAX=LMAX-J
  13775.    10 ID=0
  13776.       TOL=A(IST)*EPS
  13777.       DO 23 I=IST,IEND
  13778.       SUM=0.D0
  13779.       IF(LMAX)14,14,11
  13780.    11 LL=IST
  13781.       LLD=LLDST
  13782.       DO 13 L=1,LMAX
  13783.       LL=LL-LLD
  13784.       LLL=LL+ID
  13785.       SUM=SUM+A(LL)*A(LLL)
  13786.       IF(LLD-MUD)12,13,13
  13787.    12 LLD=LLD+1
  13788.    13 CONTINUE
  13789.    14 SUM=A(I)-SUM
  13790.       IF(I-IST)15,15,20
  13791.    15 IF(SUM)43,43,16
  13792.    16 IF(SUM-TOL)17,17,19
  13793.    17 IF(IER)18,18,19
  13794.    18 IER=K-1
  13795.    19 PIV=DSQRT(SUM)
  13796.       A(I)=PIV
  13797.       PIV=1.D0/PIV
  13798.       GO TO 21
  13799.    20 A(I)=SUM*PIV
  13800.    21 ID=ID+1
  13801.       IF(ID-J)23,23,22
  13802.    22 LMAX=LMAX-1
  13803.    23 CONTINUE
  13804.       IF(IOP)24,44,24
  13805.    24 ID=N*M
  13806.       IEND=IABS(IOP)-2
  13807.       IF(IEND)25,35,25
  13808.    25 IST=1
  13809.       LMAX=0
  13810.       J=-MR
  13811.       LLDST=MUD
  13812.       DO 34 K=1,M
  13813.       PIV=A(IST)
  13814.       IF(PIV)26,43,26
  13815.    26 PIV=1.D0/PIV
  13816.       DO 30 I=K,ID,M
  13817.       SUM=0.D0
  13818.       IF(LMAX)30,30,27
  13819.    27 LL=IST
  13820.       LLL=I
  13821.       LLD=LLDST
  13822.       DO 29 L=1,LMAX
  13823.       LL=LL-LLD
  13824.       LLL=LLL-1
  13825.       SUM=SUM+A(LL)*R(LLL)
  13826.       IF(LLD-MUD)28,29,29
  13827.    28 LLD=LLD+1
  13828.    29 CONTINUE
  13829.    30 R(I)=PIV*(R(I)-SUM)
  13830.       IF(MC-K)32,32,31
  13831.    31 LMAX=K
  13832.    32 IST=IST+MC
  13833.       J=J+1
  13834.       IF(J)34,34,33
  13835.    33 IST=IST-J
  13836.       LLDST=LLDST-1
  13837.    34 CONTINUE
  13838.       IF(IEND)35,35,44
  13839.    35 IST=M+(MUD*(M+M-MC))/2+1
  13840.       LMAX=0
  13841.       K=M
  13842.    36 IEND=IST-1
  13843.       IST=IEND-LMAX
  13844.       PIV=A(IST)
  13845.       IF(PIV)37,43,37
  13846.    37 PIV=1.D0/PIV
  13847.       L=IST+1
  13848.       DO 40 I=K,ID,M
  13849.       SUM=0.D0
  13850.       IF(LMAX)40,40,38
  13851.    38 LLL=I
  13852.       DO 39 LL=L,IEND
  13853.       LLL=LLL+1
  13854.    39 SUM=SUM+A(LL)*R(LLL)
  13855.    40 R(I)=PIV*(R(I)-SUM)
  13856.       IF(K-MR)42,42,41
  13857.    41 LMAX=LMAX+1
  13858.    42 K=K-1
  13859.       IF(K)44,44,36
  13860.    43 IER=-1
  13861.    44 RETURN
  13862.       END
  13863. C
  13864. C    ..................................................................
  13865. C
  13866. C       SUBROUTINE DMFGR
  13867. C
  13868. C       PURPOSE
  13869. C          FOR A GIVEN M BY N MATRIX THE FOLLOWING CALCULATIONS
  13870. C          ARE PERFORMED
  13871. C          (1) DETERMINE RANK AND LINEARLY INDEPENDENT ROWS AND
  13872. C              COLUMNS (BASIS).
  13873. C          (2) FACTORIZE A SUBMATRIX OF MAXIMAL RANK.
  13874. C          (3) EXPRESS NON-BASIC ROWS IN TERMS OF BASIC ONES.
  13875. C          (4) EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES.
  13876. C
  13877. C       USAGE
  13878. C          CALL DMFGR(A,M,N,EPS,IRANK,IROW,ICOL)
  13879. C
  13880. C       DESCRIPTION OF PARAMETERS
  13881. C          A      - DOUBLE PRECISION GIVEN MATRIX WITH M ROWS
  13882. C                   AND N COLUMNS.
  13883. C                   ON RETURN A CONTAINS THE TRIANGULAR FACTORS
  13884. C                   OF A SUBMATRIX OF MAXIMAL RANK.
  13885. C          M      - NUMBER OF ROWS OF MATRIX A.
  13886. C          N      - NUMBER OF COLUMNS OF MATRIX A.
  13887. C          EPS    - SINGLE PRECISION TESTVALUE FOR ZERO AFFECTED BY
  13888. C                   ROUNDOFF NOISE.
  13889. C          IRANK  - RESULTANT RANK OF GIVEN MATRIX.
  13890. C          IROW   - INTEGER VECTOR OF DIMENSION M CONTAINING THE
  13891. C                   SUBSCRIPTS OF BASIC ROWS IN IROW(1),...,IROW(IRANK)
  13892. C          ICOL   - INTEGER VECTOR OF DIMENSION N CONTAINING THE
  13893. C                   SUBSCRIPTS OF BASIC COLUMNS IN ICOL(1) UP TO
  13894. C                   ICOL(IRANK).
  13895. C
  13896. C       REMARKS
  13897. C          THE LEFT HAND TRIANGULAR FACTOR IS NORMALIZED SUCH THAT
  13898. C          THE DIAGONAL CONTAINS ALL ONES THUS ALLOWING TO STORE ONLY
  13899. C          THE SUBDIAGONAL PART.
  13900. C
  13901. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  13902. C          NONE
  13903. C
  13904. C       METHOD
  13905. C          GAUSSIAN ELIMINATION TECHNIQUE IS USED FOR CALCULATION
  13906. C          OF THE TRIANGULAR FACTORS OF A GIVEN MATRIX.
  13907. C          COMPLETE PIVOTING IS BUILT IN.
  13908. C          IN CASE OF A SINGULAR MATRIX ONLY THE TRIANGULAR FACTORS
  13909. C          OF A SUBMATRIX OF MAXIMAL RANK ARE RETAINED.
  13910. C          THE REMAINING PARTS OF THE RESULTANT MATRIX GIVE THE
  13911. C          DEPENDENCIES OF ROWS AND THE SOLUTION OF THE HOMOGENEOUS
  13912. C          MATRIX EQUATION A*X=0.
  13913. C
  13914. C    ..................................................................
  13915. C
  13916.     SUBROUTINE DMFGR(A,M,N,EPS,IRANK,IROW,ICOL)
  13917. C
  13918. C       DIMENSIONED DUMMY VARIABLES
  13919.     DIMENSION A(1),IROW(1),ICOL(1)
  13920.     DOUBLE PRECISION A,PIV,HOLD,SAVE
  13921. C
  13922. C       TEST OF SPECIFIED DIMENSIONS
  13923.     IF(M)2,2,1
  13924. 1    IF(N)2,2,4
  13925. 2    IRANK=-1
  13926. 3    RETURN
  13927. C       RETURN IN CASE OF FORMAL ERRORS
  13928. C
  13929. C
  13930. C       INITIALIZE COLUMN INDEX VECTOR
  13931. C       SEARCH FIRST PIVOT ELEMENT
  13932. 4    IRANK=0
  13933.     PIV=0.D0
  13934.     JJ=0
  13935.     DO 6 J=1,N
  13936.     ICOL(J)=J
  13937.     DO 6 I=1,M
  13938.     JJ=JJ+1
  13939.     HOLD=A(JJ)
  13940.     IF(DABS(PIV)-DABS(HOLD))5,6,6
  13941. 5    PIV=HOLD
  13942.     IR=I
  13943.     IC=J
  13944. 6    CONTINUE
  13945. C
  13946. C       INITIALIZE ROW INDEX VECTOR
  13947.     DO 7 I=1,M
  13948. 7    IROW(I)=I
  13949. C
  13950. C       SET UP INTERNAL TOLERANCE
  13951.     TOL=ABS(EPS*SNGL(PIV))
  13952. C
  13953. C       INITIALIZE ELIMINATION LOOP
  13954.     NM=N*M
  13955.     DO 19 NCOL=M,NM,M
  13956. C
  13957. C       TEST FOR FEASIBILITY OF PIVOT ELEMENT
  13958. 8    IF(ABS(SNGL(PIV))-TOL)20,20,9
  13959. C
  13960. C       UPDATE RANK
  13961. 9    IRANK=IRANK+1
  13962. C
  13963. C       INTERCHANGE ROWS IF NECESSARY
  13964.     JJ=IR-IRANK
  13965.     IF(JJ)12,12,10
  13966. 10    DO 11 J=IRANK,NM,M
  13967.     I=J+JJ
  13968.     SAVE=A(J)
  13969.     A(J)=A(I)
  13970. 11    A(I)=SAVE
  13971. C
  13972. C       UPDATE ROW INDEX VECTOR
  13973.     JJ=IROW(IR)
  13974.     IROW(IR)=IROW(IRANK)
  13975.     IROW(IRANK)=JJ
  13976. C
  13977. C       INTERCHANGE COLUMNS IF NECESSARY
  13978. 12    JJ=(IC-IRANK)*M
  13979.     IF(JJ)15,15,13
  13980. 13    KK=NCOL
  13981.     DO 14 J=1,M
  13982.     I=KK+JJ
  13983.     SAVE=A(KK)
  13984.     A(KK)=A(I)
  13985.     KK=KK-1
  13986. 14    A(I)=SAVE
  13987. C
  13988. C       UPDATE COLUMN INDEX VECTOR
  13989.     JJ=ICOL(IC)
  13990.     ICOL(IC)=ICOL(IRANK)
  13991.     ICOL(IRANK)=JJ
  13992. 15    KK=IRANK+1
  13993.     MM=IRANK-M
  13994.     LL=NCOL+MM
  13995. C
  13996. C       TEST FOR LAST ROW
  13997.     IF(MM)16,25,25
  13998. C
  13999. C       TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT
  14000. 16    JJ=LL
  14001.     SAVE=PIV
  14002.     PIV=0.D0
  14003.     DO 19 J=KK,M
  14004.     JJ=JJ+1
  14005.     HOLD=A(JJ)/SAVE
  14006.     A(JJ)=HOLD
  14007.     L=J-IRANK
  14008. C
  14009. C       TEST FOR LAST COLUMN
  14010.     IF(IRANK-N)17,19,19
  14011. 17    II=JJ
  14012.     DO 19 I=KK,N
  14013.     II=II+M
  14014.     MM=II-L
  14015.     A(II)=A(II)-HOLD*A(MM)
  14016.     IF(DABS(A(II))-DABS(PIV))19,19,18
  14017. 18    PIV=A(II)
  14018.     IR=J
  14019.     IC=I
  14020. 19    CONTINUE
  14021. C
  14022. C       SET UP MATRIX EXPRESSING ROW DEPENDENCIES
  14023. 20    IF(IRANK-1)3,25,21
  14024. 21    IR=LL
  14025.     DO 24 J=2,IRANK
  14026.     II=J-1
  14027.     IR=IR-M
  14028.     JJ=LL
  14029.     DO 23 I=KK,M
  14030.     HOLD=0.D0
  14031.     JJ=JJ+1
  14032.     MM=JJ
  14033.     IC=IR
  14034.     DO 22 L=1,II
  14035.     HOLD=HOLD+A(MM)*A(IC)
  14036.     IC=IC-1
  14037. 22    MM=MM-M
  14038. 23    A(MM)=A(MM)-HOLD
  14039. 24    CONTINUE
  14040. C
  14041. C       TEST FOR COLUMN REGULARITY
  14042. 25    IF(N-IRANK)3,3,26
  14043. C
  14044. C       SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE
  14045. C       PARAMETERS (HOMOGENEOUS SOLUTION).
  14046. 26    IR=LL
  14047.     KK=LL+M
  14048.     DO 30 J=1,IRANK
  14049.     DO 29 I=KK,NM,M
  14050.     JJ=IR
  14051.     LL=I
  14052.     HOLD=0.D0
  14053.     II=J
  14054. 27    II=II-1
  14055.     IF(II)29,29,28
  14056. 28    HOLD=HOLD-A(JJ)*A(LL)
  14057.     JJ=JJ-M
  14058.     LL=LL-1
  14059.     GOTO 27
  14060. 29    A(LL)=(HOLD-A(LL))/A(JJ)
  14061. 30    IR=IR-1
  14062.     RETURN
  14063.     END
  14064. C
  14065. C    ..................................................................
  14066. C
  14067. C       SUBROUTINE DMFSD
  14068. C
  14069. C       PURPOSE
  14070. C          FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX
  14071. C
  14072. C       USAGE
  14073. C          CALL DMFSD(A,N,EPS,IER)
  14074. C
  14075. C       DESCRIPTION OF PARAMETERS
  14076. C          A      - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN
  14077. C                   SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT
  14078. C                   MATRIX.
  14079. C                   ON RETURN A CONTAINS THE RESULTANT UPPER
  14080. C                   TRIANGULAR MATRIX IN DOUBLE PRECISION.
  14081. C          N      - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX.
  14082. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED
  14083. C                   AS RELATIVE TOLERANCE FOR TEST ON LOSS OF
  14084. C                   SIGNIFICANCE.
  14085. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  14086. C                   IER=0  - NO ERROR
  14087. C                   IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
  14088. C                            TER N OR BECAUSE SOME RADICAND IS NON-
  14089. C                            POSITIVE (MATRIX A IS NOT POSITIVE
  14090. C                            DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI-
  14091. C                            FICANCE)
  14092. C                   IER=K  - WARNING WHICH INDICATES LOSS OF SIGNIFI-
  14093. C                            CANCE. THE RADICAND FORMED AT FACTORIZA-
  14094. C                            TION STEP K+1 WAS STILL POSITIVE BUT NO
  14095. C                            LONGER GREATER THAN ABS(EPS*A(K+1,K+1)).
  14096. C
  14097. C       REMARKS
  14098. C          THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE
  14099. C          STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS.
  14100. C          IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU-
  14101. C          LAR MATRIX IS STORED COLUMNWISE TOO.
  14102. C          THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL
  14103. C          CALCULATED RADICANDS ARE POSITIVE.
  14104. C          THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE
  14105. C          SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX.
  14106. C
  14107. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  14108. C          NONE
  14109. C
  14110. C       METHOD
  14111. C          SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY.
  14112. C          THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR
  14113. C          MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF
  14114. C          THE RETURNED RIGHT HAND FACTOR.
  14115. C
  14116. C    ..................................................................
  14117. C
  14118.     SUBROUTINE DMFSD(A,N,EPS,IER)
  14119. C
  14120. C
  14121.     DIMENSION A(1)
  14122.     DOUBLE PRECISION DPIV,DSUM,A
  14123. C
  14124. C       TEST ON WRONG INPUT PARAMETER N
  14125.     IF(N-1) 12,1,1
  14126. 1    IER=0
  14127. C
  14128. C       INITIALIZE DIAGONAL-LOOP
  14129.     KPIV=0
  14130.     DO 11 K=1,N
  14131.     KPIV=KPIV+K
  14132.     IND=KPIV
  14133.     LEND=K-1
  14134. C
  14135. C       CALCULATE TOLERANCE
  14136.     TOL=ABS(EPS*SNGL(A(KPIV)))
  14137. C
  14138. C       START FACTORIZATION-LOOP OVER K-TH ROW
  14139.     DO 11 I=K,N
  14140.     DSUM=0.D0
  14141.     IF(LEND) 2,4,2
  14142. C
  14143. C       START INNER LOOP
  14144. 2    DO 3 L=1,LEND
  14145.     LANF=KPIV-L
  14146.     LIND=IND-L
  14147. 3    DSUM=DSUM+A(LANF)*A(LIND)
  14148. C       END OF INNER LOOP
  14149. C
  14150. C       TRANSFORM ELEMENT A(IND)
  14151. 4    DSUM=A(IND)-DSUM
  14152.     IF(I-K) 10,5,10
  14153. C
  14154. C       TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE
  14155. 5    IF(SNGL(DSUM)-TOL) 6,6,9
  14156. 6    IF(DSUM) 12,12,7
  14157. 7    IF(IER) 8,8,9
  14158. 8    IER=K-1
  14159. C
  14160. C       COMPUTE PIVOT ELEMENT
  14161. 9    DPIV=DSQRT(DSUM)
  14162.     A(KPIV)=DPIV
  14163.     DPIV=1.D0/DPIV
  14164.     GO TO 11
  14165. C
  14166. C       CALCULATE TERMS IN ROW
  14167. 10    A(IND)=DSUM*DPIV
  14168. 11    IND=IND+I
  14169. C       END OF DIAGONAL-LOOP
  14170. C
  14171.     RETURN
  14172. 12    IER=-1
  14173.     RETURN
  14174.     END
  14175. C
  14176. C    ..................................................................
  14177. C
  14178. C       SUBROUTINE DMFSS
  14179. C
  14180. C       PURPOSE
  14181. C          GIVEN A SYMMETRIC POSITIVE SEMI DEFINITE MATRIX ,DMFSS WILL
  14182. C          (1) DETERMINE THE RANK AND LINEARLY INDEPENDENT ROWS AND
  14183. C              COLUMNS
  14184. C          (2) FACTOR A SYMMETRIC SUBMATRIX OF MAXIMAL RANK
  14185. C          (3) EXPRESS NONBASIC ROWS IN TERMS OF BASIC ONES,
  14186. C              EXPRESS NONBASIC COLUMNS IN TERMS OF BASIC ONES
  14187. C              EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES
  14188. C          SUBROUTINE DMFSS MAY BE USED AS A PREPARATORY STEP FOR THE
  14189. C          CALCULATION OF THE LEAST SQUARES SOLUTION OF MINIMAL
  14190. C          LENGTH OF A SYSTEM OF LINEAR EQUATIONS WITH SYMMETRIC
  14191. C          POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX
  14192. C
  14193. C       USAGE
  14194. C          CALL DMFSS(A,N,EPS,IRANK,TRAC)
  14195. C
  14196. C       DESCRIPTION OF PARAMETERS
  14197. C          A     - UPPER TRIANGULAR PART OF GIVEN SYMMETRIC SEMI-
  14198. C                  DEFINITE MATRIX STORED COLUMNWISE IN COMPRESSED FORM
  14199. C                  ON RETURN A CONTAINS THE MATRIX T AND, IF IRANK IS
  14200. C                  LESS THAN N, THE MATRICES U AND TU
  14201. C                  A MUST BE OF DOUBLE PRECISION
  14202. C          N     - DIMENSION OF GIVEN MATRIX A
  14203. C          EPS   - TESTVALUE FOR ZERO AFFECTED BY ROUND-OFF NOISE
  14204. C          IRANK - RESULTANT VARIABLE, CONTAINING THE RANK OF GIVEN
  14205. C                  MATRIX A IF A IS SEMI-DEFINITE
  14206. C                  IRANK = 0 MEANS A HAS NO POSITIVE DIAGONAL ELEMENT
  14207. C                            AND/OR EPS IS NOT ABSOLUTELY LESS THAN ONE
  14208. C                  IRANK =-1 MEANS DIMENSION N IS NOT POSITIVE
  14209. C                  IRANK =-2 MEANS COMPLETE FAILURE, POSSIBLY DUE TO
  14210. C                            INADEQUATE RELATIVE TOLERANCE EPS
  14211. C          TRAC  - VECTOR OF DIMENSION N CONTAINING THE
  14212. C                  SOURCE INDEX OF THE I-TH PIVOT ROW IN ITS I-TH
  14213. C                  LOCATION, THIS MEANS THAT TRAC CONTAINS THE
  14214. C                  PRODUCT REPRESENTATION OF THE PERMUTATION WHICH
  14215. C                  IS APPLIED TO ROWS AND COLUMNS OF A IN TERMS OF
  14216. C                  TRANSPOSITIONS
  14217. C                  TRAC MUST BE OF DOUBLE PRECISION
  14218. C
  14219. C       REMARKS
  14220. C          EPS MUST BE ABSOLUTELY LESS THAN ONE. A SENSIBLE VALUE IS
  14221. C          SOMEWHERE IN BETWEEN 10**(-4) AND 10**(-6)
  14222. C          THE ABSOLUTE VALUE OF INPUT PARAMETER EPS IS USED AS
  14223. C          RELATIVE TOLERANCE.
  14224. C          IN ORDER TO PRESERVE SYMMETRY ONLY PIVOTING ALONG THE
  14225. C          DIAGONAL IS BUILT IN.
  14226. C          ALL PIVOTELEMENTS MUST BE GREATER THAN THE ABSOLUTE VALUE
  14227. C          OF EPS TIMES ORIGINAL DIAGONAL ELEMENT
  14228. C          OTHERWISE THEY ARE TREATED AS IF THEY WERE ZERO
  14229. C          MATRIX A REMAINS UNCHANGED IF THE RESULTANT VALUE IRANK
  14230. C          EQUALS ZERO
  14231. C
  14232. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  14233. C          NONE
  14234. C
  14235. C       METHOD
  14236. C          THE SQUARE ROOT METHOD WITH DIAGONAL PIVOTING IS USED FOR
  14237. C          CALCULATION OF THE RIGHT HAND TRIANGULAR FACTOR.
  14238. C          IN CASE OF AN ONLY SEMI-DEFINITE MATRIX THE SUBROUTINE
  14239. C          RETURNS THE IRANK X IRANK UPPER TRIANGULAR FACTOR T OF A
  14240. C          SUBMATRIX OF MAXIMAL RANK, THE IRANK X (N-IRANK) MATRIX U
  14241. C          AND THE (N-IRANK) X (N-IRANK) UPPER TRIANGULAR TU SUCH
  14242. C          THAT TRANSPOSE(TU)*TU=I+TRANSPOSE(U)*U
  14243. C
  14244. C    ..................................................................
  14245. C
  14246.     SUBROUTINE DMFSS(A,N,EPS,IRANK,TRAC)
  14247. C
  14248. C
  14249. C       DIMENSIONED DUMMY VARIABLES
  14250.     DIMENSION A(1),TRAC(1)
  14251.     DOUBLE PRECISION SUM,A,TRAC,PIV,HOLD
  14252. C
  14253. C       TEST OF SPECIFIED DIMENSION
  14254.     IF(N)36,36,1
  14255. C
  14256. C       INITIALIZE TRIANGULAR FACTORIZATION
  14257. 1    IRANK=0
  14258.     ISUB=0
  14259.     KPIV=0
  14260.     J=0
  14261.     PIV=0.D0
  14262. C
  14263. C       SEARCH FIRST PIVOT ELEMENT
  14264.     DO 3 K=1,N
  14265.     J=J+K
  14266.     TRAC(K)=A(J)
  14267.     IF(A(J)-PIV)3,3,2
  14268. 2    PIV=A(J)
  14269.     KSUB=J
  14270.     KPIV=K
  14271. 3    CONTINUE
  14272. C
  14273. C       START LOOP OVER ALL ROWS OF A
  14274.     DO 32 I=1,N
  14275.     ISUB=ISUB+I
  14276.     IM1=I-1
  14277. 4    KMI=KPIV-I
  14278.     IF(KMI)35,9,5
  14279. C
  14280. C       PERFORM PARTIAL COLUMN INTERCHANGE
  14281. 5    JI=KSUB-KMI
  14282.     IDC=JI-ISUB
  14283.     JJ=ISUB-IM1
  14284.     DO 6 K=JJ,ISUB
  14285.     KK=K+IDC
  14286.     HOLD=A(K)
  14287.     A(K)=A(KK)
  14288. 6    A(KK)=HOLD
  14289. C
  14290. C       PERFORM PARTIAL ROW INTERCHANGE
  14291.     KK=KSUB
  14292.     DO 7 K=KPIV,N
  14293.     II=KK-KMI
  14294.     HOLD=A(KK)
  14295.     A(KK)=A(II)
  14296.     A(II)=HOLD
  14297. 7    KK=KK+K
  14298. C
  14299. C       PERFORM REMAINING INTERCHANGE
  14300.     JJ=KPIV-1
  14301.     II=ISUB
  14302.     DO 8 K=I,JJ
  14303.     HOLD=A(II)
  14304.     A(II)=A(JI)
  14305.     A(JI)=HOLD
  14306.     II=II+K
  14307. 8    JI=JI+1
  14308. 9    IF(IRANK)22,10,10
  14309. C
  14310. C       RECORD INTERCHANGE IN TRANSPOSITION VECTOR
  14311. 10    TRAC(KPIV)=TRAC(I)
  14312.     TRAC(I)=KPIV
  14313. C
  14314. C       MODIFY CURRENT PIVOT ROW
  14315.     KK=IM1-IRANK
  14316.     KMI=ISUB-KK
  14317.     PIV=0.D0
  14318.     IDC=IRANK+1
  14319.     JI=ISUB-1
  14320.     JK=KMI
  14321.     JJ=ISUB-I
  14322.     DO 19 K=I,N
  14323.     SUM=0.D0
  14324. C
  14325. C       BUILD UP SCALAR PRODUCT IF NECESSARY
  14326.     IF(KK)13,13,11
  14327. 11    DO 12 J=KMI,JI
  14328.     SUM=SUM-A(J)*A(JK)
  14329. 12    JK=JK+1
  14330. 13    JJ=JJ+K
  14331.     IF(K-I)14,14,16
  14332. 14    SUM=A(ISUB)+SUM
  14333. C
  14334. C       TEST RADICAND FOR LOSS OF SIGNIFICANCE
  14335.     IF(SUM-DABS(A(ISUB)*DBLE(EPS)))20,20,15
  14336. 15    A(ISUB)=DSQRT(SUM)
  14337.     KPIV=I+1
  14338.     GOTO 19
  14339. 16    SUM=(A(JK)+SUM)/A(ISUB)
  14340.     A(JK)=SUM
  14341. C
  14342. C       SEARCH FOR NEXT PIVOT ROW
  14343.     IF(A(JJ))19,19,17
  14344. 17    TRAC(K)=TRAC(K)-SUM*SUM
  14345.     HOLD=TRAC(K)/A(JJ)
  14346.     IF(PIV-HOLD)18,19,19
  14347. 18    PIV=HOLD
  14348.     KPIV=K
  14349.     KSUB=JJ
  14350. 19    JK=JJ+IDC
  14351.     GOTO 32
  14352. C
  14353. C       CALCULATE MATRIX OF DEPENDENCIES U
  14354. 20    IF(IRANK)21,21,37
  14355. 21    IRANK=-1
  14356.     GOTO 4
  14357. 22    IRANK=IM1
  14358.     II=ISUB-IRANK
  14359.     JI=II
  14360.     DO 26 K=1,IRANK
  14361.     JI=JI-1
  14362.     JK=ISUB-1
  14363.     JJ=K-1
  14364.     DO 26 J=I,N
  14365.     IDC=IRANK
  14366.     SUM=0.D0
  14367.     KMI=JI
  14368.     KK=JK
  14369.     IF(JJ)25,25,23
  14370. 23    DO 24 L=1,JJ
  14371.     IDC=IDC-1
  14372.     SUM=SUM-A(KMI)*A(KK)
  14373.     KMI=KMI-IDC
  14374. 24    KK=KK-1
  14375. 25    A(KK)=(SUM+A(KK))/A(KMI)
  14376. 26    JK=JK+J
  14377. C
  14378. C       CALCULATE I+TRANSPOSE(U)*U
  14379.     JJ=ISUB-I
  14380.     PIV=0.D0
  14381.     KK=ISUB-1
  14382.     DO 31 K=I,N
  14383.     JJ=JJ+K
  14384.     IDC=0
  14385.     DO 28 J=K,N
  14386.     SUM=0.D0
  14387.     KMI=JJ+IDC
  14388.     DO 27 L=II,KK
  14389.     JK=L+IDC
  14390. 27    SUM=SUM+A(L)*A(JK)
  14391.     A(KMI)=SUM
  14392. 28    IDC=IDC+J
  14393.     A(JJ)=A(JJ)+1.D0
  14394.     TRAC(K)=A(JJ)
  14395. C
  14396. C       SEARCH NEXT DIAGONAL ELEMENT
  14397.     IF(PIV-A(JJ))29,30,30
  14398. 29    KPIV=K
  14399.     KSUB=JJ
  14400.     PIV=A(JJ)
  14401. 30    II=II+K
  14402.     KK=KK+K
  14403. 31    CONTINUE
  14404.     GOTO 4
  14405. 32    CONTINUE
  14406. 33    IF(IRANK)35,34,35
  14407. 34    IRANK=N
  14408. 35    RETURN
  14409. C
  14410. C       ERROR RETURNS
  14411. C
  14412. C       RETURN IN CASE OF ILLEGAL DIMENSION
  14413. 36    IRANK=-1
  14414.     RETURN
  14415. C
  14416. C       INSTABLE FACTORIZATION OF I+TRANSPOSE(U)*U
  14417. 37    IRANK=-2
  14418.     RETURN
  14419.     END
  14420. C
  14421. C    ..................................................................
  14422. C
  14423. C       SUBROUTINE DMLSS
  14424. C
  14425. C       PURPOSE
  14426. C          SUBROUTINE DMLSS IS THE SECOND STEP IN THE PROCEDURE FOR
  14427. C          CALCULATING THE LEAST SQUARES SOLUTION OF MINIMAL LENGTH
  14428. C          OF A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH SYMMETRIC
  14429. C          POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX.
  14430. C
  14431. C       USAGE
  14432. C          CALL DMLSS(A,N,IRANK,TRAC,INC,RHS,IER)
  14433. C
  14434. C       DESCRIPTION OF PARAMETERS
  14435. C          A     - COEFFICIENT MATRIX IN FACTORED FORM AS GENERATED
  14436. C                  BY SUBROUTINE MFSS FROM INITIALLY GIVEN SYMMETRIC
  14437. C                  COEFFICIENT MATRIX A STORED IN N*(N+1)/2 LOCATIONS
  14438. C                  A REMAINS UNCHANGED
  14439. C                  A MUST BE OF DOUBLE PRECISION
  14440. C          N     - DIMENSION OF COEFFICIENT MATRIX
  14441. C          IRANK - RANK OF COEFFICIENT MATRIX, CALCULATED BY MEANS OF
  14442. C                  SUBROUTINE DMFSS
  14443. C          TRAC  - VECTOR OF DIMENSION N CONTAINING THE
  14444. C                  SUBSCRIPTS OF PIVOT ROWS AND COLUMNS, I.E. THE
  14445. C                  PRODUCT REPRESENTATION IN TRANSPOSITIONS OF THE
  14446. C                  PERMUTATION WHICH WAS APPLIED TO ROWS AND COLUMNS
  14447. C                  OF A IN THE FACTORIZATION PROCESS
  14448. C                  TRAC IS A RESULTANT ARRAY OF SUBROUTINE MFSS
  14449. C                  TRAC MUST BE OF DOUBLE PRECISION
  14450. C          INC   - INPUT VARIABLE WHICH SHOULD CONTAIN THE VALUE ZERO
  14451. C                  IF THE SYSTEM OF SIMULTANEOUS EQUATIONS IS KNOWN
  14452. C                  TO BE COMPATIBLE AND A NONZERO VALUE OTHERWISE
  14453. C          RHS   - VECTOR OF DIMENSION N CONTAINING THE RIGHT HAND SIDE
  14454. C                  ON RETURN RHS CONTAINS THE MINIMAL LENGTH SOLUTION
  14455. C                  RHS MUST BE OF DOUBLE PRECISION
  14456. C          IER   - RESULTANT ERROR PARAMETER
  14457. C                  IER = 0 MEANS NO ERRORS
  14458. C                  IER =-1 MEANS N AND/OR IRANK IS NOT POSITIVE AND/OR
  14459. C                          IRANK IS GREATER THAN N
  14460. C                  IER = 1 MEANS THE FACTORIZATION CONTAINED IN A HAS
  14461. C                          ZERO DIVISORS AND/OR TRAC CONTAINS
  14462. C                          VALUES OUTSIDE THE FEASIBLE RANGE 1 UP TO N
  14463. C
  14464. C       REMARKS
  14465. C          THE MINIMAL LENGTH SOLUTION IS PRODUCED IN THE STORAGE
  14466. C          LOCATIONS OCCUPIED BY THE RIGHT HAND SIDE.
  14467. C          SUBROUTINE DMLSS DOES TAKE CARE OF THE PERMUTATION
  14468. C          WHICH WAS APPLIED TO ROWS AND COLUMNS OF A.
  14469. C          OPERATION IS BYPASSED IN CASE OF A NON POSITIVE VALUE
  14470. C          OF IRANK
  14471. C
  14472. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  14473. C          NONE
  14474. C
  14475. C       METHOD
  14476. C          LET T, U, TU BE THE COMPONENTS OF THE FACTORIZATION OF A,
  14477. C          AND LET THE RIGHT HAND SIDE BE PARTITIONED INTO A FIRST
  14478. C          PART X1 OF DIMENSION IRANK AND A SECOND PART X2 OF DIMENSION
  14479. C          N-IRANK. THEN THE FOLLOWING OPERATIONS ARE APPLIED IN
  14480. C          SEQUENCE
  14481. C          (1) INTERCHANGE RIGHT HAND SIDE
  14482. C          (2) X1 = X1 + U * X2
  14483. C          (3) X2 =-TRANSPOSE(U) * X1
  14484. C          (4) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
  14485. C          (5) X1 = X1 + U * X2
  14486. C          (6) X1 = INVERSE(T) * INVERSE(TRANSPOSE(T)) * X1
  14487. C          (7) X2 =-TRANSPOSE(U) * X1
  14488. C          (8) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
  14489. C          (9) X1 = X1 + U * X2
  14490. C          (10)X2 = TRANSPOSE(U) * X1
  14491. C          (11) REINTERCHANGE CALCULATED SOLUTION
  14492. C          IF THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS IS SPECIFIED
  14493. C          TO BE COMPATIBLE THEN STEPS (2), (3), (4) AND (5) ARE
  14494. C          CANCELLED.
  14495. C          IF THE COEFFICIENT MATRIX HAS RANK N, THEN THE ONLY STEPS
  14496. C          PERFORMED ARE (1), (6) AND (11).
  14497. C
  14498. C    ..................................................................
  14499. C
  14500.     SUBROUTINE DMLSS(A,N,IRANK,TRAC,INC,RHS,IER)
  14501. C
  14502. C
  14503. C       DIMENSIONED DUMMY VARIABLES
  14504.     DIMENSION A(1),TRAC(1),RHS(1)
  14505.     DOUBLE PRECISION SUM,A,RHS,TRAC,HOLD
  14506. C
  14507. C       TEST OF SPECIFIED DIMENSIONS
  14508.     IDEF=N-IRANK
  14509.     IF(N)33,33,1
  14510. 1    IF(IRANK)33,33,2
  14511. 2    IF(IDEF)33,3,3
  14512. C
  14513. C       CALCULATE AUXILIARY VALUES
  14514. 3    ITE=IRANK*(IRANK+1)/2
  14515.     IX2=IRANK+1
  14516.     NP1=N+1
  14517.     IER=0
  14518. C
  14519. C       INTERCHANGE RIGHT HAND SIDE
  14520.     JJ=1
  14521.     II=1
  14522. 4    DO 6 I=1,N
  14523.     J=TRAC(II)
  14524.     IF(J)31,31,5
  14525. 5    HOLD=RHS(II)
  14526.     RHS(II)=RHS(J)
  14527.     RHS(J)=HOLD
  14528. 6    II=II+JJ
  14529.     IF(JJ)32,7,7
  14530. C
  14531. C       PERFORM STEP 2 IF NECESSARY
  14532. 7    ISW=1
  14533.     IF(INC*IDEF)8,28,8
  14534. C
  14535. C       CALCULATE X1 = X1 + U * X2
  14536. 8    ISTA=ITE
  14537.     DO 10 I=1,IRANK
  14538.     ISTA=ISTA+1
  14539.     JJ=ISTA
  14540.     SUM=0.D0
  14541.     DO 9 J=IX2,N
  14542.     SUM=SUM+A(JJ)*RHS(J)
  14543. 9    JJ=JJ+J
  14544. 10    RHS(I)=RHS(I)+SUM
  14545.     GOTO(11,28,11),ISW
  14546. C
  14547. C       CALCULATE X2 = TRANSPOSE(U) * X1
  14548. 11    ISTA=ITE
  14549.     DO 15 I=IX2,N
  14550.     JJ=ISTA
  14551.     SUM=0.D0
  14552.     DO 12 J=1,IRANK
  14553.     JJ=JJ+1
  14554. 12    SUM=SUM+A(JJ)*RHS(J)
  14555.     GOTO(13,13,14),ISW
  14556. 13    SUM=-SUM
  14557. 14    RHS(I)=SUM
  14558. 15    ISTA=ISTA+I
  14559.     GOTO(16,29,30),ISW
  14560. C
  14561. C       INITIALIZE STEP (4) OR STEP (8)
  14562. 16    ISTA=IX2
  14563.     IEND=N
  14564.     JJ=ITE+ISTA
  14565. C
  14566. C       DIVISION OF X1 BY TRANSPOSE OF TRIANGULAR MATRIX
  14567. 17    SUM=0.D0
  14568.     DO 20 I=ISTA,IEND
  14569.     IF(A(JJ))18,31,18
  14570. 18    RHS(I)=(RHS(I)-SUM)/A(JJ)
  14571.     IF(I-IEND)19,21,21
  14572. 19    JJ=JJ+ISTA
  14573.     SUM=0.D0
  14574.     DO 20 J=ISTA,I
  14575.     SUM=SUM+A(JJ)*RHS(J)
  14576. 20    JJ=JJ+1
  14577. C
  14578. C       DIVISION OF X1 BY TRIANGULAR MATRIX
  14579. 21    SUM=0.D0
  14580.     II=IEND
  14581.     DO 24 I=ISTA,IEND
  14582.     RHS(II)=(RHS(II)-SUM)/A(JJ)
  14583.     IF(II-ISTA)25,25,22
  14584. 22    KK=JJ-1
  14585.     SUM=0.D0
  14586.     DO 23 J=II,IEND
  14587.     SUM=SUM+A(KK)*RHS(J)
  14588. 23    KK=KK+J
  14589.     JJ=JJ-II
  14590. 24    II=II-1
  14591. 25    IF(IDEF)26,30,26
  14592. 26    GOTO(27,11,8),ISW
  14593. C
  14594. C       PERFORM STEP (5)
  14595. 27    ISW=2
  14596.     GOTO 8
  14597. C
  14598. C       PERFORM STEP (6)
  14599. 28    ISTA=1
  14600.     IEND=IRANK
  14601.     JJ=1
  14602.     ISW=2
  14603.     GOTO 17
  14604. C
  14605. C       PERFORM STEP (8)
  14606. 29    ISW=3
  14607.     GOTO 16
  14608. C
  14609. C       REINTERCHANGE CALCULATED SOLUTION
  14610. 30    II=N
  14611.     JJ=-1
  14612.     GOTO 4
  14613. C
  14614. C       ERROR RETURN IN CASE OF ZERO DIVISOR
  14615. 31    IER=1
  14616. 32    RETURN
  14617. C
  14618. C       ERROR RETURN IN CASE OF ILLEGAL DIMENSION
  14619. 33    IER=-1
  14620.     RETURN
  14621.     END
  14622. C
  14623. C    ..................................................................
  14624. C
  14625. C       SUBROUTINE DMPRC
  14626. C
  14627. C       PURPOSE
  14628. C          TO PERMUTE THE ROWS OR COLUMNS OF A GIVEN MATRIX ACCORDING
  14629. C          TO A GIVEN TRANSPOSITION VECTOR OR ITS INVERSE.  (SEE THE
  14630. C          DISCUSSION ON PERMUTATIONS FOR DEFINITIONS AND NOTATION.)
  14631. C
  14632. C       USAGE
  14633. C          CALL DMPRC(A,M,N,ITRA,INV,IROCO,IER)
  14634. C
  14635. C       DESCRIPTION OF PARAMETERS
  14636. C          A     - GIVEN DOUBLE PRECISION M BY N MATRIX AND RESULTING
  14637. C                  PERMUTED MATRIX
  14638. C          M     - NUMBER OF ROWS OF A
  14639. C          N     - NUMBER OF COLUMNS OF A
  14640. C          ITRA  - GIVEN TRANSPOSITION VECTOR (DIMENSION M IF ROWS ARE
  14641. C                  PERMUTED, N IF COLUMNS ARE PERMUTED)
  14642. C          INV   - INPUT PARAMETER
  14643. C                  INV NON-ZERO  -  PERMUTE ACCORDING TO ITRA
  14644. C                  INV    =   0  -  PERMUTE ACCORDING TO ITRA INVERSE
  14645. C          IROCO - INPUT PARAMETER
  14646. C                  IROCO NON-ZERO  -  PERMUTE THE COLUMNS OF A
  14647. C                  IROCO    =   0  -  PERMUTE THE ROWS OF A
  14648. C          IER   - RESULTING ERROR PARAMETER
  14649. C                  IER = -1  -  M AND N ARE NOT BOTH POSITIVE
  14650. C                  IER =  0  -  NO ERROR
  14651. C                  IER =  1  -  ITRA IS NOT A TRANSPOSITION VECTOR ON
  14652. C                               1,...,M IF ROWS ARE PERMUTED, 1,...,N
  14653. C                               IF COLUMNS ARE PERMUTED
  14654. C
  14655. C       REMARKS
  14656. C          (1)  IF IER=-1 THERE IS NO COMPUTATION.
  14657. C          (2)  IF IER= 1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE
  14658. C               TO ERROR, BUT THE MATRIX A WILL REFLECT THE ROW OR
  14659. C               COLUMN INTERCHANGES PERFORMED BEFORE THE ERROR WAS
  14660. C               DETECTED.
  14661. C          (3)  THE MATRIX A IS ASSUMED TO BE STORED COLUMNWISE.
  14662. C
  14663. C       SUBROUTINES AND SUBPROGRAMS REQUIRED
  14664. C          NONE
  14665. C
  14666. C       METHOD
  14667. C          THE ROWS OR COLUMNS ARE PERMUTED ELEMENTWISE, INTERCHANGING
  14668. C          ROW OR COLUMN 1 AND ITRA(1),...,ROW OR COLUMN K AND ITRA(K)
  14669. C          IN THAT ORDER IF INV=0, AND OTHERWISE INTERCHANGING ROW OR
  14670. C          COLUMN K AND ITRA(K),...,ROW OR COLUMN 1 AND ITRA(1), WHERE
  14671. C          K IS M OR N DEPENDING ON WHETHER WE PERMUTE ROWS OR COLUMNS.
  14672. C
  14673. C    ..................................................................
  14674. C
  14675.     SUBROUTINE DMPRC(A,M,N,ITRA,INV,IROCO,IER)
  14676. C
  14677. C
  14678.     DIMENSION A(1),ITRA(1)
  14679.     DOUBLE PRECISION A,SAVE
  14680. C
  14681. C       TEST OF DIMENSIONS
  14682.     IF(M)14,14,1
  14683. 1    IF(N)14,14,2
  14684. C
  14685. C       DETERMINE WHICH ARE TO BE PERMUTED-THE ROWS OR THE COLUMNS
  14686. 2    IF(IROCO)3,4,3
  14687. C
  14688. C       INITIALIZE FOR COLUMN INTERCHANGES
  14689. 3    MM=M
  14690.     MMM=-1
  14691.     L=M
  14692.     LL=N
  14693.     GO TO 5
  14694. C
  14695. C       INITIALIZE FOR ROW INTERCHANGES
  14696. 4    MM=1
  14697.     MMM=M
  14698.     L=N
  14699.     LL=M
  14700. C
  14701. C       INITIALIZE LOOP OVER ALL ROWS OR COLUMNS
  14702. 5    IA=1
  14703.     ID=1
  14704. C
  14705. C       TEST FOR INVERSE OPERATION
  14706.     IF(INV)6,7,6
  14707. 6    IA=LL
  14708.     ID=-1
  14709. 7    DO 12 I=1,LL
  14710.     K=ITRA(IA)
  14711.     IF(K-IA)8,12,9
  14712. 8    IF(K)13,13,10
  14713. 9    IF(LL-K)13,10,10
  14714. C
  14715. C       INITIALIZE ROW OR COLUMN INTERCHANGE
  14716. 10    IL=IA*MM
  14717.     K=K*MM
  14718. C
  14719. C       PERFORM ROW OR COLUMN INTERCHANGE
  14720.     DO 11 J=1,L
  14721.     SAVE=A(IL)
  14722.     A(IL)=A(K)
  14723.     A(K)=SAVE
  14724.     K=K+MMM
  14725. 11    IL=IL+MMM
  14726. C
  14727. C       ADDRESS NEXT INTERCHANGE STEP
  14728. 12    IA=IA+ID
  14729. C
  14730. C       NORMAL EXIT
  14731.     IER=0
  14732.     RETURN
  14733. C
  14734. C       ERROR RETURN IN CASE ITRA IS NOT A TRANSPOSITION VECTOR
  14735. 13    IER=1
  14736.     RETURN
  14737. C
  14738. C       ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
  14739. 14    IER=-1
  14740.     RETURN
  14741.     END
  14742. C
  14743. C    ..................................................................
  14744. C
  14745. C       SUBROUTINE DMTDS
  14746. C
  14747. C       PURPOSE
  14748. C          MULTIPLY A GENERAL MATRIX A ON THE LEFT OR RIGHT BY
  14749. C          INVERSE(T),INVERSE(TRANSPOSE(T)) OR INVERSE(TRANSPOSE(T*T))
  14750. C          THE TRIANGULAR MATRIX T IS STORED COLUMNWISE IN COMPRESSED
  14751. C          FORM, I.E. UPPER TRIANGULAR PART ONLY.
  14752. C
  14753. C       USAGE
  14754. C          CALL DMTDS(A,M,N,T,IOP,IER)
  14755. C
  14756. C       DESCRIPTION OF PARAMETERS
  14757. C          A     - GIVEN GENERAL MATRIX WITH  M ROWS AND N COLUMNS.
  14758. C                  A MUST BE OF DOUBLE PRECISION
  14759. C          M     - NUMBER OF ROWS OF MATRIX A
  14760. C          N     - NUMBER OF COLUMNS OF MATRIX A
  14761. C          T     - GIVEN TRIANGULAR MATRIX STORED COLUMNWISE UPPER
  14762. C                  TRIANGULAR PART ONLY. ITS NUMBER OF ROWS AND
  14763. C                  COLUMNS K IS IMPLIED BY COMPATIBILITY.
  14764. C                  K = M IF IOP IS POSITIVE,
  14765. C                  K = N IF IOP IS NEGATIVE.
  14766. C                  T OCCUPIES K*(K+1)/2 STORAGE POSITIONS.
  14767. C                  T MUST BE OF DOUBLE PRECISION
  14768. C          IOP   - INPUT VARIABLE FOR SELECTION OF OPERATION
  14769. C                  IOP = 1 - A IS REPLACED BY INVERSE(T)*A
  14770. C                  IOP =-1 - A IS REPLACED BY A*INVERSE(T)
  14771. C                  IOP = 2 - A IS REPLACED BY INVERSE(TRANSPOSE(T))*A
  14772. C                  IOP =-2 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T))
  14773. C                  IOP = 3 - A IS REPLACED BY INVERSE(TRANSPOSE(T)*T)*A
  14774. C                  IOP =-3 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)*T)
  14775. C          IER   - RESULTING ERROR PARAMETER
  14776. C                  IER =-1 MEANS M AND N ARE NOT BOTH POSITIVE
  14777. C                                AND/OR IOP IS ILLEGAL
  14778. C                  IER = 0 MEANS OPERATION WAS SUCCESSFUL
  14779. C                  IER = 1 MEANS TRIANGULAR MATRIX T IS SINGULAR
  14780. C
  14781. C       REMARKS
  14782. C          SUBROUTINE DMTDS MAY BE USED TO CALCULATE THE SOLUTION OF
  14783. C          A SYSTEM OF EQUATIONS WITH SYMMETRIC POSITIVE DEFINITE
  14784. C          COEFFICIENT MATRIX. THE FIRST STEP TOWARDS THE SOLUTION
  14785. C          IS TRIANGULAR FACTORIZATION BY MEANS OF DMFSD, THE SECOND
  14786. C          STEP IS APPLICATION OF DMTDS.
  14787. C          SUBROUTINES DMFSD AND DMTDS MAY BE USED IN ORDER TO
  14788. C          CACULATE THE PRODUCT TRANSPOSE(A)*INVERSE(B)*A WITH GIVEN
  14789. C          SYMMETRIC POSITIVE DEFINITE B AND GIVEN A IN THREE STEPS
  14790. C          1) TRIANGULAR FACTORIZATION OF B (B=TRANSPOSE(T)*T)
  14791. C          2) MULTIPLICATION OF A ON THE LEFT BY INVERSE(TRANSPOSE(T))
  14792. C             A IS REPLACED BY C=INVERSE(TRANSPOSE(T))*A
  14793. C          3) CALCULATION OF THE RESULT FORMING TRANSPOSE(C)*C
  14794. C
  14795. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  14796. C          NONE
  14797. C
  14798. C       METHOD
  14799. C          CALCULATION OF X = INVERSE(T)*A IS DONE USING BACKWARD
  14800. C          SUBSTITUTION TO OBTAIN X FROM T*X = A.
  14801. C          CALCULATION OF Y = INVERSE(TRANSPOSE(T))*A IS DONE USING
  14802. C          FORWARD SUBSTITUTION TO OBTAIN Y FROM TRANSPOSE(T)*Y = A.
  14803. C          CALCULATION OF Z = INVERSE(TRANSPOSE(T)*T)*A IS DONE
  14804. C          SOLVING FIRST TRANSPOSE(T)*Y = A AND THEN T*Z = Y, IE.
  14805. C          USING THE ABOVE TWO STEPS IN REVERSE ORDER
  14806. C
  14807. C    ..................................................................
  14808. C
  14809.     SUBROUTINE DMTDS(A,M,N,T,IOP,IER)
  14810. C
  14811. C
  14812.     DIMENSION A(1),T(1)
  14813.     DOUBLE PRECISION DSUM,A,T
  14814. C
  14815. C       TEST OF DIMENSION
  14816.     IF(M)2,2,1
  14817. 1    IF(N)2,2,4
  14818. C
  14819. C       ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
  14820. 2    IER=-1
  14821.     RETURN
  14822. C
  14823. C       ERROR RETURN IN CASE OF SINGULAR MATRIX T
  14824. 3    IER=1
  14825.     RETURN
  14826. C
  14827. C       INITIALIZE DIVISION PROCESS
  14828. 4    MN=M*N
  14829.     MM=M*(M+1)/2
  14830.     MM1=M-1
  14831.     IER=0
  14832.     ICS=M
  14833.     IRS=1
  14834.     IMEND=M
  14835. C
  14836. C       TEST SPECIFIED OPERATION
  14837.     IF(IOP)5,2,6
  14838. 5    MM=N*(N+1)/2
  14839.     MM1=N-1
  14840.     IRS=M
  14841.     ICS=1
  14842.     IMEND=MN-M+1
  14843.     MN=M
  14844. 6    IOPE=MOD(IOP+3,3)
  14845.     IF(IABS(IOP)-3)7,7,2
  14846. 7    IF(IOPE-1)8,18,8
  14847. C
  14848. C       INITIALIZE SOLUTION OF TRANSPOSE(T)*X = A
  14849. 8    MEND=1
  14850.     LLD=IRS
  14851.     MSTA=1
  14852.     MDEL=1
  14853.     MX=1
  14854.     LD=1
  14855.     LX=0
  14856. C
  14857. C       TEST FOR NONZERO DIAGONAL TERM IN T
  14858. 9    IF(T(MSTA))10,3,10
  14859. 10    DO 11 I=MEND,MN,ICS
  14860. 11    A(I)=A(I)/T(MSTA)
  14861. C
  14862. C       IS M EQUAL 1
  14863.     IF(MM1)2,15,12
  14864. 12    DO 14 J=1,MM1
  14865.     MSTA=MSTA+MDEL
  14866.     MDEL=MDEL+MX
  14867.     DO 14 I=MEND,MN,ICS
  14868.     DSUM=0.D0
  14869.     L=MSTA
  14870.     LDX=LD
  14871.     LL=I
  14872.     DO 13 K=1,J
  14873.     DSUM=DSUM-T(L)*A(LL)
  14874.     LL=LL+LLD
  14875.     L=L+LDX
  14876. 13    LDX=LDX+LX
  14877.     IF(T(L))14,3,14
  14878. 14    A(LL)=(DSUM+A(LL))/T(L)
  14879. C
  14880. C       TEST END OF OPERATION
  14881. 15    IF(IER)16,17,16
  14882. 16    IER=0
  14883.     RETURN
  14884. 17    IF(IOPE)18,18,16
  14885. C
  14886. C       INITIALIZE SOLUTION OF T*X = A
  14887. 18    IER=1
  14888.     MEND=IMEND
  14889.     MN=M*N
  14890.     LLD=-IRS
  14891.     MSTA=MM
  14892.     MDEL=-1
  14893.     MX=0
  14894.     LD=-MM1
  14895.     LX=1
  14896.     GOTO 9
  14897.     END
  14898. C
  14899. C    ..................................................................
  14900. C
  14901. C       SUBROUTINE DPECN
  14902. C
  14903. C       PURPOSE
  14904. C          ECONOMIZE A POLYNOMIAL FOR SYMMETRIC RANGE
  14905. C
  14906. C       USAGE
  14907. C          CALL DPECN(P,N,BOUND,EPS,TOL,WORK)
  14908. C
  14909. C       DESCRIPTION OF PARAMETERS
  14910. C          P     - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN
  14911. C                  POLYNOMIAL
  14912. C                  ON RETURN P CONTAINS THE ECONOMIZED POLYNOMIAL
  14913. C          N     - DIMENSION OF COEFFICIENT VECTOR P
  14914. C                  ON RETURN N CONTAINS DIMENSION OF ECONOMIZED
  14915. C                  POLYNOMIAL
  14916. C          BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF RANGE
  14917. C          EPS   - SINGLE PRECISION INITIAL ERROR BOUND
  14918. C                  ON RETURN EPS CONTAINS AN ERROR BOUND FOR THE
  14919. C                  ECONOMIZED POLYNOMIAL
  14920. C          TOL   - SINGLE PRECISION TOLERANCE FOR ERROR
  14921. C                  FINAL VALUE OF EPS MUST BE LESS THAN TOL
  14922. C          WORK  - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N
  14923. C                  (STARTING VALUE OF N RATHER THAN FINAL VALUE)
  14924. C
  14925. C       REMARKS
  14926. C          THE OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
  14927. C          IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
  14928. C          FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
  14929. C          WITH ARGUMENT X IN POWERS OF T = (X-(XR-XL)/2).
  14930. C          THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD.
  14931. C
  14932. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  14933. C          NONE
  14934. C
  14935. C       METHOD
  14936. C          SUBROUTINE DPECN TAKES AN (N-1)ST DEGREE POLYNOMIAL
  14937. C          APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
  14938. C          EPS OVER THE INTERVAL (-BOUND,BOUND) AND REDUCES IT IF
  14939. C          POSSIBLE TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN
  14940. C          THE GIVEN TOLERANCE TOL.
  14941. C          THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE FINAL
  14942. C          VECTOR. THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
  14943. C          ERROR BOUND.
  14944. C          N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
  14945. C          THE COEFFICIENT VECTOR OF THE N-TH CHEBYSHEV POLYNOMIAL
  14946. C          IS CALCULATED FROM THE RECURSION FORMULA
  14947. C          A(K-1)=-A(K+1)*K*L*L*(K-1)/((N+K-2)*(N-K+2))
  14948. C          REFERENCE
  14949. C          K. A. BRONS, ALGORITHM 38, TELESCOPE 2, CACM VOL. 4, 1961,
  14950. C          NO. 3, PP. 151-152.
  14951. C
  14952. C    ..................................................................
  14953. C
  14954.     SUBROUTINE DPECN(P,N,BOUND,EPS,TOL,WORK)
  14955. C
  14956.     DIMENSION P(1),WORK(1)
  14957.     DOUBLE PRECISION P,WORK
  14958. C
  14959.     FL=BOUND*BOUND
  14960. C
  14961. C       TEST OF DIMENSION
  14962. C
  14963. 1    IF(N-1)2,3,6
  14964. 2    RETURN
  14965. C
  14966. 3    IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5
  14967. 4    N=0
  14968.     EPS=EPS+ABS(SNGL(P(1)))
  14969. 5    RETURN
  14970. C
  14971. C       CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
  14972. C
  14973. 6    NEND=N-2
  14974.     WORK(N)=-P(N)
  14975.     DO 7 J=1,NEND,2
  14976.     K=N-J
  14977.     FN=(NEND-1+K)*(NEND+3-K)
  14978.     FK=K*(K-1)
  14979. 7    WORK(K-1)=-WORK(K+1)*DBLE(FK*FL/FN)
  14980. C
  14981. C       TEST FOR FEASIBILITY OF REDUCTION
  14982. C
  14983.     IF(K-2)8,8,9
  14984. 8    FN=DABS(WORK(1))
  14985.     GOTO 10
  14986. 9    FN=N-1
  14987.     FN=ABS(SNGL(WORK(2))/FN)
  14988. 10    IF(EPS+FN-TOL)11,11,5
  14989. C
  14990. C       REDUCE POLYNOMIAL
  14991. C
  14992. 11    EPS=EPS+FN
  14993.     N=N-1
  14994.     DO 12 J=K,N,2
  14995. 12    P(J-1)=P(J-1)+WORK(J-1)
  14996.     GOTO 1
  14997.     END
  14998. C
  14999. C    ..................................................................
  15000. C
  15001. C       SUBROUTINE DPECS
  15002. C
  15003. C       PURPOSE
  15004. C          ECONOMIZATION OF A POLYNOMIAL FOR UNSYMMETRIC RANGE
  15005. C
  15006. C       USAGE
  15007. C          CALL DPECS(P,N,BOUND,EPS,TOL,WORK)
  15008. C
  15009. C       DESCRIPTION OF PARAMETERS
  15010. C          P     - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN
  15011. C                  POLYNOMIAL
  15012. C          N     - DIMENSION OF COEFFICIENT VECTOR P
  15013. C          BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF INTERVAL
  15014. C          EPS   - SINGLE PRECISION INITIAL ERROR BOUND
  15015. C          TOL   - SINGLE PRECISION TOLERANCE FOR ERROR
  15016. C          WORK  - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N
  15017. C
  15018. C       REMARKS
  15019. C          THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE
  15020. C          ECONOMIZED VECTOR.
  15021. C          THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
  15022. C          ERROR BOUND.
  15023. C          N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
  15024. C          IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
  15025. C          FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
  15026. C          WITH ARGUMENT X IN POWERS OF T = (X-XL).
  15027. C          THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD.
  15028. C          OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
  15029. C
  15030. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  15031. C          NONE
  15032. C
  15033. C       METHOD
  15034. C          SUBROUTINE DPECS TAKES AN (N-1)ST DEGREE POLYNOMIAL
  15035. C          APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
  15036. C          EPS OVER THE INTERVAL (0,BOUND) AND REDUCES IT IF POSSIBLE
  15037. C          TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN TOLERANCE
  15038. C          TOL.
  15039. C          THE COEFFICIENT VECTOR OF THE N-TH SHIFTED CHEBYSHEV
  15040. C          POLYNOMIAL IS CALCULATED FROM THE RECURSION FORMULA
  15041. C          A(K) = -A(K+1)*K*L*(2*K-1)/(2*(N+K-1)*(N-K+1)).
  15042. C          REFERENCE
  15043. C          K. A. BRONS, ALGORITHM 37, TELESCOPE 1, CACM VOL. 4, 1961,
  15044. C          NO. 3, PP. 151.
  15045. C
  15046. C    ..................................................................
  15047. C
  15048.     SUBROUTINE DPECS(P,N,BOUND,EPS,TOL,WORK)
  15049. C
  15050.     DIMENSION P(1),WORK(1)
  15051.     DOUBLE PRECISION P,WORK
  15052. C
  15053.     FL=BOUND*0.5
  15054. C
  15055. C       TEST OF DIMENSION
  15056. C
  15057. 1    IF(N-1)2,3,6
  15058. 2    RETURN
  15059. C
  15060. 3    IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5
  15061. 4    N=0
  15062.     EPS=EPS+ABS(SNGL(P(1)))
  15063. 5    RETURN
  15064. C
  15065. C       CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
  15066. C
  15067. 6    NEND=N-1
  15068.     WORK(N)=-P(N)
  15069.     DO 7 J=1,NEND
  15070.     K=N-J
  15071.     FN=(NEND-1+K)*(N-K)
  15072.     FK=K*(K+K-1)
  15073. 7    WORK(K)=-WORK(K+1)*DBLE(FK)*DBLE(FL)/DBLE(FN)
  15074. C
  15075. C       TEST FOR FEASIBILITY OF REDUCTION
  15076. C
  15077.     FN=DABS(WORK(1))
  15078.     IF(EPS+FN-TOL)8,8,5
  15079. C
  15080. C       REDUCE POLYNOMIAL
  15081. C
  15082. 8    EPS=EPS+FN
  15083.     N=NEND
  15084.     DO 9 J=1,NEND
  15085. 9    P(J)=P(J)+WORK(J)
  15086.     GOTO 1
  15087.     END
  15088. C
  15089. C    ..................................................................
  15090. C
  15091. C       SUBROUTINE DPQFB
  15092. C
  15093. C       PURPOSE
  15094. C          TO FIND AN APPROXIMATION Q(X)=Q1+Q2*X+X*X TO A QUADRATIC
  15095. C          FACTOR OF A GIVEN POLYNOMIAL P(X) WITH REAL COEFFICIENTS.
  15096. C
  15097. C       USAGE
  15098. C          CALL DPQFB(C,IC,Q,LIM,IER)
  15099. C
  15100. C       DESCRIPTION OF PARAMETERS
  15101. C          C   - DOUBLE PRECISION INPUT VECTOR CONTAINING THE
  15102. C                COEFFICIENTS OF P(X) - C(1) IS THE CONSTANT TERM
  15103. C                (DIMENSION IC)
  15104. C          IC  - DIMENSION OF C
  15105. C          Q   - DOUBLE PRECISION VECTOR OF DIMENSION 4 - ON INPUT Q(1)
  15106. C                AND Q(2) CONTAIN INITIAL GUESSES FOR Q1 AND Q2 - ON
  15107. C                RETURN Q(1) AND Q(2) CONTAIN THE REFINED COEFFICIENTS
  15108. C                Q1 AND Q2 OF Q(X), WHILE Q(3) AND Q(4) CONTAIN THE
  15109. C                COEFFICIENTS A AND B OF A+B*X, WHICH IS THE REMAINDER
  15110. C                OF THE QUOTIENT OF P(X) BY Q(X)
  15111. C          LIM - INPUT VALUE SPECIFYING THE MAXIMUM NUMBER OF
  15112. C                ITERATIONS TO BE PERFORMED
  15113. C          IER - RESULTING ERROR PARAMETER (SEE REMARKS)
  15114. C                IER= 0 - NO ERROR
  15115. C                IER= 1 - NO CONVERGENCE WITHIN LIM ITERATIONS
  15116. C                IER=-1 - THE POLYNOMIAL P(X) IS CONSTANT OR UNDEFINED
  15117. C                         - OR OVERFLOW OCCURRED IN NORMALIZING P(X)
  15118. C                IER=-2 - THE POLYNOMIAL P(X) IS OF DEGREE 1
  15119. C                IER=-3 - NO FURTHER REFINEMENT OF THE APPROXIMATION TO
  15120. C                         A QUADRATIC FACTOR IS FEASIBLE, DUE TO EITHER
  15121. C                         DIVISION BY 0, OVERFLOW OR AN INITIAL GUESS
  15122. C                         THAT IS NOT SUFFICIENTLY CLOSE TO A FACTOR OF
  15123. C                         P(X)
  15124. C
  15125. C       REMARKS
  15126. C          (1)  IF IER=-1 THERE IS NO COMPUTATION OTHER THAN THE
  15127. C               POSSIBLE NORMALIZATION OF C.
  15128. C          (2)  IF IER=-2 THERE IS NO COMPUTATION OTHER THAN THE
  15129. C               NORMALIZATION OF C.
  15130. C          (3)  IF IER =-3  IT IS SUGGESTED THAT A NEW INITIAL GUESS BE
  15131. C               MADE FOR A QUADRATIC FACTOR.  Q, HOWEVER, WILL CONTAIN
  15132. C               THE VALUES ASSOCIATED WITH THE ITERATION THAT YIELDED
  15133. C               THE SMALLEST NORM OF THE MODIFIED LINEAR REMAINDER.
  15134. C          (4)  IF IER=1, THEN, ALTHOUGH THE NUMBER OF ITERATIONS LIM
  15135. C               WAS TOO SMALL TO INDICATE CONVERGENCE, NO OTHER PROB-
  15136. C               LEMS HAVE BEEN DETECTED, AND Q WILL CONTAIN THE VALUES
  15137. C               ASSOCIATED WITH THE ITERATION THAT YIELDED THE SMALLEST
  15138. C               NORM OF THE MODIFIED LINEAR REMAINDER.
  15139. C          (5)  FOR COMPLETE DETAIL SEE THE DOCUMENTATION FOR
  15140. C               SUBROUTINES PQFB AND DPQFB.
  15141. C
  15142. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  15143. C          NONE
  15144. C
  15145. C       METHOD
  15146. C          COMPUTATION IS BASED ON BAIRSTOW'S ITERATIVE METHOD.  (SEE
  15147. C          WILKINSON, J.H., THE EVALUATION OF THE ZEROS OF ILL-CON-
  15148. C          DITIONED POLYNOMIALS (PART ONE AND TWO), NUMERISCHE MATHE-
  15149. C          MATIK, VOL.1 (1959), PP. 150-180, OR HILDEBRAND, F.B.,
  15150. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  15151. C          TORONTO/LONDON, 1956, PP. 472-476.)
  15152. C
  15153. C    ..................................................................
  15154. C
  15155.     SUBROUTINE DPQFB(C,IC,Q,LIM,IER)
  15156. C
  15157. C
  15158.     DIMENSION C(1),Q(1)
  15159.     DOUBLE PRECISION A,B,AA,BB,CA,CB,CC,CD,A1,B1,C1,H,HH,Q1,Q2,QQ1,
  15160.      1                 QQ2,QQQ1,QQQ2,DQ1,DQ2,EPS,EPS1,C,Q
  15161. C
  15162. C       TEST ON LEADING ZERO COEFFICIENTS
  15163.     IER=0
  15164.     J=IC+1
  15165. 1    J=J-1
  15166.     IF(J-1)40,40,2
  15167. 2    IF(C(J))3,1,3
  15168. C
  15169. C       NORMALIZATION OF REMAINING COEFFICIENTS
  15170. 3    A=C(J)
  15171.     IF(A-1.D0)4,6,4
  15172. 4    DO 5 I=1,J
  15173.     C(I)=C(I)/A
  15174.     CALL OVERFL(N)
  15175.     IF(N-2)40,5,5
  15176. 5    CONTINUE
  15177. C
  15178. C       TEST ON NECESSITY OF BAIRSTOW ITERATION
  15179. 6    IF(J-3)41,38,7
  15180. C
  15181. C       PREPARE BAIRSTOW ITERATION
  15182. 7    EPS=1.D-14
  15183.     EPS1=1.D-6
  15184.     L=0
  15185.     LL=0
  15186.     Q1=Q(1)
  15187.     Q2=Q(2)
  15188.     QQ1=0.D0
  15189.     QQ2=0.D0
  15190.     AA=C(1)
  15191.     BB=C(2)
  15192.     CB=DABS(AA)
  15193.     CA=DABS(BB)
  15194.     IF(CB-CA)8,9,10
  15195. 8    CC=CB+CB
  15196.     CB=CB/CA
  15197.     CA=1.D0
  15198.     GO TO 11
  15199. 9    CC=CA+CA
  15200.     CA=1.D0
  15201.     CB=1.D0
  15202.     GO TO 11
  15203. 10    CC=CA+CA
  15204.     CA=CA/CB
  15205.     CB=1.D0
  15206. 11    CD=CC*.1D0
  15207. C
  15208. C       START BAIRSTOW ITERATION
  15209. C       PREPARE NESTED MULTIPLICATION
  15210. 12    A=0.D0
  15211.     B=A
  15212.     A1=A
  15213.     B1=A
  15214.     I=J
  15215.     QQQ1=Q1
  15216.     QQQ2=Q2
  15217.     DQ1=HH
  15218.     DQ2=H
  15219. C
  15220. C       START NESTED MULTIPLICATION
  15221. 13    H=-Q1*B-Q2*A+C(I)
  15222.     CALL OVERFL(N)
  15223.     IF(N-2)42,14,14
  15224. 14    B=A
  15225.     A=H
  15226.     I=I-1
  15227.     IF(I-1)18,15,16
  15228. 15    H=0.D0
  15229. 16    H=-Q1*B1-Q2*A1+H
  15230.     CALL OVERFL(N)
  15231.     IF(N-2)42,17,17
  15232. 17    C1=B1
  15233.     B1=A1
  15234.     A1=H
  15235.     GO TO 13
  15236. C       END OF NESTED MULTIPLICATION
  15237. C
  15238. C       TEST ON SATISFACTORY ACCURACY
  15239. 18    H=CA*DABS(A)+CB*DABS(B)
  15240.     IF(LL)19,19,39
  15241. 19    L=L+1
  15242.     IF(DABS(A)-EPS*DABS(C(1)))20,20,21
  15243. 20    IF(DABS(B)-EPS*DABS(C(2)))39,39,21
  15244. C
  15245. C       TEST ON LINEAR REMAINDER OF MINIMUM NORM
  15246. 21    IF(H-CC)22,22,23
  15247. 22    AA=A
  15248.     BB=B
  15249.     CC=H
  15250.     QQ1=Q1
  15251.     QQ2=Q2
  15252. C
  15253. C       TEST ON LAST ITERATION STEP
  15254. 23    IF(L-LIM)28,28,24
  15255. C
  15256. C       TEST ON RESTART OF BAIRSTOW ITERATION WITH ZERO INITIAL GUESS
  15257. 24    IF(H-CD)43,43,25
  15258. 25    IF(Q(1))27,26,27
  15259. 26    IF(Q(2))27,42,27
  15260. 27    Q(1)=0.D0
  15261.     Q(2)=0.D0
  15262.     GO TO 7
  15263. C
  15264. C       PERFORM ITERATION STEP
  15265. 28    HH=DMAX1(DABS(A1),DABS(B1),DABS(C1))
  15266.     IF(HH)42,42,29
  15267. 29    A1=A1/HH
  15268.     B1=B1/HH
  15269.     C1=C1/HH
  15270.     H=A1*C1-B1*B1
  15271.     IF(H)30,42,30
  15272. 30    A=A/HH
  15273.     B=B/HH
  15274.     HH=(B*A1-A*B1)/H
  15275.     H=(A*C1-B*B1)/H
  15276.     Q1=Q1+HH
  15277.     Q2=Q2+H
  15278. C       END OF ITERATION STEP
  15279. C
  15280. C       TEST ON SATISFACTORY RELATIVE ERROR OF ITERATED VALUES
  15281.     IF(DABS(HH)-EPS*DABS(Q1))31,31,33
  15282. 31    IF(DABS(H)-EPS*DABS(Q2))32,32,33
  15283. 32    LL=1
  15284.     GO TO 12
  15285. C
  15286. C       TEST ON DECREASING RELATIVE ERRORS
  15287. 33    IF(L-1)12,12,34
  15288. 34    IF(DABS(HH)-EPS1*DABS(Q1))35,35,12
  15289. 35    IF(DABS(H)-EPS1*DABS(Q2))36,36,12
  15290. 36    IF(DABS(QQQ1*HH)-DABS(Q1*DQ1))37,44,44
  15291. 37    IF(DABS(QQQ2*H)-DABS(Q2*DQ2))12,44,44
  15292. C       END OF BAIRSTOW ITERATION
  15293. C
  15294. C       EXIT IN CASE OF QUADRATIC POLYNOMIAL
  15295. 38    Q(1)=C(1)
  15296.     Q(2)=C(2)
  15297.     Q(3)=0.D0
  15298.     Q(4)=0.D0
  15299.     RETURN
  15300. C
  15301. C       EXIT IN CASE OF SUFFICIENT ACCURACY
  15302. 39    Q(1)=Q1
  15303.     Q(2)=Q2
  15304.     Q(3)=A
  15305.     Q(4)=B
  15306.     RETURN
  15307. C
  15308. C       ERROR EXIT IN CASE OF ZERO OR CONSTANT POLYNOMIAL
  15309. 40    IER=-1
  15310.     RETURN
  15311. C
  15312. C       ERROR EXIT IN CASE OF LINEAR POLYNOMIAL
  15313. 41    IER=-2
  15314.     RETURN
  15315. C
  15316. C       ERROR EXIT IN CASE OF NONREFINED QUADRATIC FACTOR
  15317. 42    IER=-3
  15318.     GO TO 44
  15319. C
  15320. C       ERROR EXIT IN CASE OF UNSATISFACTORY ACCURACY
  15321. 43    IER=1
  15322. 44    Q(1)=QQ1
  15323.     Q(2)=QQ2
  15324.     Q(3)=AA
  15325.     Q(4)=BB
  15326.     RETURN
  15327.     END
  15328. C
  15329. C    ..................................................................
  15330. C
  15331. C       SUBROUTINE DPRBM
  15332. C
  15333. C       PURPOSE
  15334. C          TO CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN
  15335. C          POLYNOMIAL WITH REAL COEFFICIENTS.
  15336. C
  15337. C       USAGE
  15338. C          CALL DPRBM (C,IC,RR,RC,POL,IR,IER)
  15339. C
  15340. C       DESCRIPTION OF PARAMETERS
  15341. C          C      - DOUBLE PRECISION INPUT VECTOR CONTAINING THE
  15342. C                   COEFFICIENTS OF THE GIVEN POLYNOMIAL. COEFFICIENTS
  15343. C                   ARE ORDERED FROM LOW TO HIGH. ON RETURN COEFFI-
  15344. C                   CIENTS ARE DIVIDED BY THE LAST NONZERO TERM.
  15345. C          IC     - DIMENSION OF VECTORS C, RR, RC, AND POL.
  15346. C          RR     - RESULTANT DOUBLE PRECISION VECTOR OF REAL PARTS
  15347. C                   OF THE ROOTS.
  15348. C          RC     - RESULTANT DOUBLE PRECISION VECTOR OF COMPLEX PARTS
  15349. C                   OF THE ROOTS.
  15350. C          POL    - RESULTANT DOUBLE PRECISION VECTOR OF COEFFICIENTS
  15351. C                   OF THE POLYNOMIAL WITH CALCULATED ROOTS.
  15352. C                   COEFFICIENTS ARE ORDERED FROM LOW TO HIGH (SEE
  15353. C                   REMARK 4).
  15354. C          IR     - OUTPUT VALUE SPECIFYING THE NUMBER OF CALCULATED
  15355. C                   ROOTS. NORMALLY IR IS EQUAL TO IC-1.
  15356. C          IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
  15357. C                    IER=0  - NO ERROR,
  15358. C                    IER=1  - SUBROUTINE DPQFB RECORDS POOR CONVERGENCE
  15359. C                             AT SOME QUADRATIC FACTORIZATION WITHIN
  15360. C                             100 ITERATION STEPS,
  15361. C                    IER=2  - POLYNOMIAL IS DEGENERATE, I.E. ZERO OR
  15362. C                             CONSTANT,
  15363. C                             OR OVERFLOW IN NORMALIZATION OF GIVEN
  15364. C                             POLYNOMIAL,
  15365. C                    IER=3  - THE SUBROUTINE IS BYPASSED DUE TO
  15366. C                             SUCCESSIVE ZERO DIVISORS OR OVERFLOWS
  15367. C                             IN QUADRATIC FACTORIZATION OR DUE TO
  15368. C                             COMPLETELY UNSATISFACTORY ACCURACY,
  15369. C                    IER=-1 - CALCULATED COEFFICIENT VECTOR HAS LESS
  15370. C                             THAN SIX CORRECT SIGNIFICANT DIGITS.
  15371. C                             THIS REVEALS POOR ACCURACY OF CALCULATED
  15372. C                             ROOTS.
  15373. C
  15374. C       REMARKS
  15375. C          (1) REAL PARTS OF THE ROOTS ARE STORED IN RR(1) UP TO RR(IR)
  15376. C              AND CORRESPONDING COMPLEX PARTS IN RC(1) UP TO RC(IR).
  15377. C          (2) ERROR MESSAGE IER=1 INDICATES POOR CONVERGENCE WITHIN
  15378. C              100 ITERATION STEPS AT SOME QUADRATIC FACTORIZATION
  15379. C              PERFORMED BY SUBROUTINE DPQFB.
  15380. C          (3) NO ACTION BESIDES ERROR MESSAGE IER=2 IN CASE OF A ZERO
  15381. C              OR CONSTANT POLYNOMIAL. THE SAME ERROR MESSAGE IS GIVEN
  15382. C              IN CASE OF AN OVERFLOW IN NORMALIZATION OF GIVEN
  15383. C              POLYNOMIAL.
  15384. C          (4) ERROR MESSAGE IER=3 INDICATES SUCCESSIVE ZERO DIVISORS
  15385. C              OR OVERFLOWS OR COMPLETELY UNSATISFACTORY ACCURACY AT
  15386. C              ANY QUADRATIC FACTORIZATION PERFORMED BY
  15387. C              SUBROUTINE DPQFB. IN THIS CASE CALCULATION IS BYPASSED.
  15388. C              IR RECORDS THE NUMBER OF CALCULATED ROOTS.
  15389. C              POL(1),...,POL(J-IR) ARE THE COEFFICIENTS OF THE
  15390. C              REMAINING POLYNOMIAL, WHERE J IS THE ACTUAL NUMBER OF
  15391. C              COEFFICIENTS IN VECTOR C (NORMALLY J=IC).
  15392. C          (5) IF CALCULATED COEFFICIENT VECTOR HAS LESS THAN SIX
  15393. C              CORRECT SIGNIFICANT DIGITS THOUGH ALL QUADRATIC
  15394. C              FACTORIZATIONS SHOWED SATISFACTORY ACCURACY, THE ERROR
  15395. C              MESSAGE IER=-1 IS GIVEN.
  15396. C          (6) THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
  15397. C              COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE
  15398. C              BEEN CALCULATED. IN THIS CASE THE NUMBER OF ROOTS IR IS
  15399. C              EQUAL TO THE ACTUAL DEGREE OF THE POLYNOMIAL (NORMALLY
  15400. C              IR=IC-1). THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT
  15401. C              VECTOR IS RECORDED IN RR(IR+1).
  15402. C
  15403. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  15404. C          SUBROUTINE DPQFB    QUADRATIC FACTORIZATION OF A POLYNOMIAL
  15405. C                              BY BAIRSTOW ITERATION.
  15406. C
  15407. C       METHOD
  15408. C          THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
  15409. C          SUCCESSIVE QUADRATIC FACTORIZATION PERFORMED BY BAIRSTOW
  15410. C          ITERATION. X**2 IS USED AS INITIAL GUESS FOR THE FIRST
  15411. C          QUADRATIC FACTOR, AND FURTHER EACH CALCULATED QUADRATIC
  15412. C          FACTOR IS USED AS INITIAL GUESS FOR THE NEXT ONE. AFTER
  15413. C          COMPUTATION OF ALL ROOTS THE COEFFICIENT VECTOR IS
  15414. C          CALCULATED AND COMPARED WITH THE GIVEN ONE.
  15415. C          FOR REFERENCE, SEE J. H. WILKINSON, THE EVALUATION OF THE
  15416. C          ZEROS OF ILL-CONDITIONED POLYNOMIALS (PART ONE AND TWO),
  15417. C          NUMERISCHE MATHEMATIK, VOL.1 (1959), PP.150-180.
  15418. C
  15419. C    ..................................................................
  15420. C
  15421.     SUBROUTINE DPRBM(C,IC,RR,RC,POL,IR,IER)
  15422. C
  15423. C
  15424.     DIMENSION C(1),RR(1),RC(1),POL(1),Q(4)
  15425.     DOUBLE PRECISION C,RR,RC,POL,Q,EPS,A,B,H,Q1,Q2
  15426. C
  15427. C       TEST ON LEADING ZERO COEFFICIENTS
  15428.     EPS=1.D-6
  15429.     LIM=100
  15430.     IR=IC+1
  15431. 1    IR=IR-1
  15432.     IF(IR-1)42,42,2
  15433. 2    IF(C(IR))3,1,3
  15434. C
  15435. C       WORK UP ZERO ROOTS AND NORMALIZE REMAINING POLYNOMIAL
  15436. 3    IER=0
  15437.     J=IR
  15438.     L=0
  15439.     A=C(IR)
  15440.     DO 8 I=1,IR
  15441.     IF(L)4,4,7
  15442. 4    IF(C(I))6,5,6
  15443. 5    RR(I)=0.D0
  15444.     RC(I)=0.D0
  15445.     POL(J)=0.D0
  15446.     J=J-1
  15447.     GO TO 8
  15448. 6    L=1
  15449.     IST=I
  15450.     J=0
  15451. 7    J=J+1
  15452.     C(I)=C(I)/A
  15453.     POL(J)=C(I)
  15454.     CALL OVERFL(N)
  15455.     IF(N-2)42,8,8
  15456. 8    CONTINUE
  15457. C
  15458. C       START BAIRSTOW ITERATION
  15459.     Q1=0.D0
  15460.     Q2=0.D0
  15461. 9    IF(J-2)33,10,14
  15462. C
  15463. C       DEGREE OF RESTPOLYNOMIAL IS EQUAL TO ONE
  15464. 10    A=POL(1)
  15465.     RR(IST)=-A
  15466.     RC(IST)=0.D0
  15467.     IR=IR-1
  15468.     Q2=0.D0
  15469.     IF(IR-1)13,13,11
  15470. 11    DO 12 I=2,IR
  15471.     Q1=Q2
  15472.     Q2=POL(I+1)
  15473. 12    POL(I)=A*Q2+Q1
  15474. 13    POL(IR+1)=A+Q2
  15475.     GO TO 34
  15476. C       THIS IS BRANCH TO COMPARISON OF COEFFICIENT VECTORS C AND POL
  15477. C
  15478. C       DEGREE OF RESTPOLYNOMIAL IS GREATER THAN ONE
  15479. 14    DO 22 L=1,10
  15480.     N=1
  15481. 15    Q(1)=Q1
  15482.     Q(2)=Q2
  15483.     CALL DPQFB(POL,J,Q,LIM,I)
  15484.     IF(I)16,24,23
  15485. 16    IF(Q1)18,17,18
  15486. 17    IF(Q2)18,21,18
  15487. 18    GO TO (19,20,19,21),N
  15488. 19    Q1=-Q1
  15489.     N=N+1
  15490.     GO TO 15
  15491. 20    Q2=-Q2
  15492.     N=N+1
  15493.     GO TO 15
  15494. 21    Q1=1.D0+Q1
  15495. 22    Q2=1.D0-Q2
  15496. C
  15497. C       ERROR EXIT DUE TO UNSATISFACTORY RESULTS OF FACTORIZATION
  15498.     IER=3
  15499.     IR=IR-J
  15500.     RETURN
  15501. C
  15502. C       WORK UP RESULTS OF QUADRATIC FACTORIZATION
  15503. 23    IER=1
  15504. 24    Q1=Q(1)
  15505.     Q2=Q(2)
  15506. C
  15507. C       PERFORM DIVISION OF FACTORIZED POLYNOMIAL BY QUADRATIC FACTOR
  15508.     B=0.D0
  15509.     A=0.D0
  15510.     I=J
  15511. 25    H=-Q1*B-Q2*A+POL(I)
  15512.     POL(I)=B
  15513.     B=A
  15514.     A=H
  15515.     I=I-1
  15516.     IF(I-2)26,26,25
  15517. 26    POL(2)=B
  15518.     POL(1)=A
  15519. C
  15520. C       MULTIPLY POLYNOMIAL WITH CALCULATED ROOTS BY QUADRATIC FACTOR
  15521.     L=IR-1
  15522.     IF(J-L)27,27,29
  15523. 27    DO 28 I=J,L
  15524. 28    POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1
  15525. 29    POL(L)=POL(L)+POL(L+1)*Q2+Q1
  15526.     POL(IR)=POL(IR)+Q2
  15527. C
  15528. C       CALCULATE ROOT-PAIR FROM QUADRATIC FACTOR X*X+Q2*X+Q1
  15529.     H=-.5D0*Q2
  15530.     A=H*H-Q1
  15531.     B=DSQRT(DABS(A))
  15532.     IF(A)30,30,31
  15533. 30    RR(IST)=H
  15534.     RC(IST)=B
  15535.     IST=IST+1
  15536.     RR(IST)=H
  15537.     RC(IST)=-B
  15538.     GO TO 32
  15539. 31    B=H+DSIGN(B,H)
  15540.     RR(IST)=Q1/B
  15541.     RC(IST)=0.D0
  15542.     IST=IST+1
  15543.     RR(IST)=B
  15544.     RC(IST)=0.D0
  15545. 32    IST=IST+1
  15546.     J=J-2
  15547.     GO TO 9
  15548. C
  15549. C       SHIFT BACK ELEMENTS OF POL BY 1 AND COMPARE VECTORS POL AND C
  15550. 33    IR=IR-1
  15551. 34    A=0.D0
  15552.     DO 38 I=1,IR
  15553.     Q1=C(I)
  15554.     Q2=POL(I+1)
  15555.     POL(I)=Q2
  15556.     IF(Q1)35,36,35
  15557. 35    Q2=(Q1-Q2)/Q1
  15558. 36    Q2=DABS(Q2)
  15559.     IF(Q2-A)38,38,37
  15560. 37    A=Q2
  15561. 38    CONTINUE
  15562.     I=IR+1
  15563.     POL(I)=1.D0
  15564.     RR(I)=A
  15565.     RC(I)=0.D0
  15566.     IF(IER)39,39,41
  15567. 39    IF(A-EPS)41,41,40
  15568. C
  15569. C       WARNING DUE TO POOR ACCURACY OF CALCULATED COEFFICIENT VECTOR
  15570. 40    IER=-1
  15571. 41    RETURN
  15572. C
  15573. C       ERROR EXIT DUE TO DEGENERATE POLYNOMIAL OR OVERFLOW IN
  15574. C       NORMALIZATION
  15575. 42    IER=2
  15576.     IR=0
  15577.     RETURN
  15578.     END
  15579. C
  15580. C    ..................................................................
  15581. C
  15582. C       SUBROUTINE DPRQD
  15583. C
  15584. C       PURPOSE
  15585. C          CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN POLYNOMIAL
  15586. C          WITH REAL COEFFICIENTS.
  15587. C
  15588. C       USAGE
  15589. C          CALL DPRQD(C,IC,Q,E,POL,IR,IER)
  15590. C
  15591. C       DESCRIPTION OF PARAMETERS
  15592. C          C     - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL
  15593. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  15594. C                  THE GIVEN COEFFICIENT VECTOR GETS DIVIDED BY THE
  15595. C                  LAST NONZERO TERM
  15596. C                  DOUBLE PRECISION ARRAY
  15597. C          IC    - DIMENSION OF VECTOR C
  15598. C          Q     - WORKING STORAGE OF DIMENSION IC
  15599. C                  ON RETURN Q CONTAINS REAL PARTS OF ROOTS
  15600. C                  DOUBLE PRECISION ARRAY
  15601. C          E     - WORKING STORAGE OF DIMENSION IC
  15602. C                  ON RETURN E CONTAINS COMPLEX PARTS OF ROOTS
  15603. C                  DOUBLE PRECISION ARRAY
  15604. C          POL   - WORKING STORAGE OF DIMENSION IC
  15605. C                  ON RETURN POL CONTAINS THE COEFFICIENTS OF THE
  15606. C                  POLYNOMIAL WITH CALCULATED ROOTS
  15607. C                  THIS RESULTING COEFFICIENT VECTOR HAS DIMENSION IR+1
  15608. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  15609. C                  DOUBLE PRECISION ARRAY
  15610. C          IR    - NUMBER OF CALCULATED ROOTS
  15611. C                  NORMALLY IR IS EQUAL TO DIMENSION IC MINUS ONE
  15612. C          IER   - RESULTING ERROR PARAMETER. SEE REMARKS
  15613. C
  15614. C       REMARKS
  15615. C          THE REAL PART OF THE ROOTS IS STORED IN Q(1) UP TO Q(IR)
  15616. C          CORRESPONDING COMPLEX PARTS ARE STORED IN E(1) UP TO E(IR).
  15617. C          IER = 0 MEANS NO ERRORS
  15618. C          IER = 1 MEANS NO CONVERGENCE WITH FEASIBLE TOLERANCE
  15619. C          IER = 2 MEANS POLYNOMIAL IS DEGENERATE (CONSTANT OR ZERO)
  15620. C          IER = 3 MEANS SUBROUTINE WAS ABANDONED DUE TO ZERO DIVISOR
  15621. C          IER = 4 MEANS THERE EXISTS NO S-FRACTION
  15622. C          IER =-1 MEANS CALCULATED COEFFICIENT VECTOR REVEALS POOR
  15623. C                  ACCURACY OF THE CALCULATED ROOTS.
  15624. C                  THE CALCULATED COEFFICIENT VECTOR HAS LESS THAN
  15625. C                  6 CORRECT DIGITS.
  15626. C          THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
  15627. C          COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE BEEN
  15628. C          CALCULATED.
  15629. C          THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT VECTOR IS
  15630. C          RECORDED IN Q(IR+1).
  15631. C
  15632. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  15633. C          NONE
  15634. C
  15635. C       METHOD
  15636. C          THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
  15637. C          THE QUOTIENT-DIFFERENCE ALGORITHM WITH DISPLACEMENT.
  15638. C          REFERENCE
  15639. C          H.RUTISHAUSER, DER QUOTIENTEN-DIFFERENZEN-ALGORITHMUS,
  15640. C          BIRKHAEUSER, BASEL/STUTTGART, 1957.
  15641. C
  15642. C    ..................................................................
  15643. C
  15644.     SUBROUTINE DPRQD(C,IC,Q,E,POL,IR,IER)
  15645. C
  15646. C     DIMENSIONED DUMMY VARIABLES
  15647.     DIMENSION E(1),Q(1),C(1),POL(1)
  15648.     DOUBLE PRECISION Q,E,O,P,T,EXPT,ESAV,U,V,W,C,POL,EPS
  15649. C
  15650. C       NORMALIZATION OF GIVEN POLYNOMIAL
  15651. C          TEST OF DIMENSION
  15652. C       IR CONTAINS INDEX OF HIGHEST COEFFICIENT
  15653.     IR=IC
  15654.     IER=0
  15655.     EPS=1.D-16
  15656.     TOL=1.E-6
  15657.     LIMIT=10*IC
  15658.     KOUNT=0
  15659. 1    IF(IR-1)79,79,2
  15660. C
  15661. C       DROP TRAILING ZERO COEFFICIENTS
  15662. 2    IF(C(IR))4,3,4
  15663. 3    IR=IR-1
  15664.     GOTO 1
  15665. C
  15666. C          REARRANGEMENT OF GIVEN POLYNOMIAL
  15667. C       EXTRACTION OF ZERO ROOTS
  15668. 4    O=1.0D0/C(IR)
  15669.     IEND=IR-1
  15670.     ISTA=1
  15671.     NSAV=IR+1
  15672.     JBEG=1
  15673. C
  15674. C       Q(J)=1.
  15675. C       Q(J+I)=C(IR-I)/C(IR)
  15676. C       Q(IR)=C(J)/C(IR)
  15677. C       WHERE J IS THE INDEX OF THE LOWEST NONZERO COEFFICIENT
  15678.     DO 9 I=1,IR
  15679.     J=NSAV-I
  15680.     IF(C(I))7,5,7
  15681. 5    GOTO(6,8),JBEG
  15682. 6    NSAV=NSAV+1
  15683.     Q(ISTA)=0.D0
  15684.     E(ISTA)=0.D0
  15685.     ISTA=ISTA+1
  15686.     GOTO 9
  15687. 7    JBEG=2
  15688. 8    Q(J)=C(I)*O
  15689.     C(I)=Q(J)
  15690. 9    CONTINUE
  15691. C
  15692. C          INITIALIZATION
  15693.     ESAV=0.D0
  15694.     Q(ISTA)=0.D0
  15695. 10    NSAV=IR
  15696. C
  15697. C       COMPUTATION OF DERIVATIVE
  15698.     EXPT=IR-ISTA
  15699.     E(ISTA)=EXPT
  15700.     DO 11 I=ISTA,IEND
  15701.     EXPT=EXPT-1.0D0
  15702.     POL(I+1)=EPS*DABS(Q(I+1))+EPS
  15703. 11    E(I+1)=Q(I+1)*EXPT
  15704. C
  15705. C       TEST OF REMAINING DIMENSION
  15706.     IF(ISTA-IEND)12,20,60
  15707. 12    JEND=IEND-1
  15708. C
  15709. C       COMPUTATION OF S-FRACTION
  15710.     DO 19 I=ISTA,JEND
  15711.     IF(I-ISTA)13,16,13
  15712. 13    IF(DABS(E(I))-POL(I+1))14,14,16
  15713. C
  15714. C       THE GIVEN POLYNOMIAL HAS MULTIPLE ROOTS, THE COEFFICIENTS OF
  15715. C       THE COMMON FACTOR ARE STORED FROM Q(NSAV) UP TO Q(IR)
  15716. 14    NSAV=I
  15717.     DO 15 K=I,JEND
  15718.     IF(DABS(E(K))-POL(K+1))15,15,80
  15719. 15    CONTINUE
  15720.     GOTO 21
  15721. C
  15722. C          EUCLIDEAN ALGORITHM
  15723. 16    DO 19 K=I,IEND
  15724.     E(K+1)=E(K+1)/E(I)
  15725.     Q(K+1)=E(K+1)-Q(K+1)
  15726.     IF(K-I)18,17,18
  15727. C
  15728. C       TEST FOR SMALL DIVISOR
  15729. 17    IF(DABS(Q(I+1))-POL(I+1))80,80,19
  15730. 18    Q(K+1)=Q(K+1)/Q(I+1)
  15731.     POL(K+1)=POL(K+1)/DABS(Q(I+1))
  15732.     E(K)=Q(K+1)-E(K)
  15733. 19    CONTINUE
  15734. 20    Q(IR)=-Q(IR)
  15735. C
  15736. C          THE DISPLACEMENT EXPT IS SET TO 0 AUTOMATICALLY.
  15737. C          E(ISTA)=0.,Q(ISTA+1),...,E(NSAV-1),Q(NSAV),E(NSAV)=0.,
  15738. C          FORM A DIAGONAL OF THE QD-ARRAY.
  15739. C       INITIALIZATION OF BOUNDARY VALUES
  15740. 21    E(ISTA)=0.D0
  15741.     NRAN=NSAV-1
  15742. 22    E(NRAN+1)=0.D0
  15743. C
  15744. C          TEST FOR LINEAR OR CONSTANT FACTOR
  15745. C       NRAN-ISTA IS DEGREE-1
  15746.     IF(NRAN-ISTA)24,23,31
  15747. C
  15748. C       LINEAR FACTOR
  15749. 23    Q(ISTA+1)=Q(ISTA+1)+EXPT
  15750.     E(ISTA+1)=0.D0
  15751. C
  15752. C       TEST FOR UNFACTORED COMMON DIVISOR
  15753. 24    E(ISTA)=ESAV
  15754.     IF(IR-NSAV)60,60,25
  15755. C
  15756. C       INITIALIZE QD-ALGORITHM FOR COMMON DIVISOR
  15757. 25    ISTA=NSAV
  15758.     ESAV=E(ISTA)
  15759.     GOTO 10
  15760. C
  15761. C       COMPUTATION OF ROOT PAIR
  15762. 26    P=P+EXPT
  15763. C
  15764. C       TEST FOR REALITY
  15765.     IF(O)27,28,28
  15766. C
  15767. C       COMPLEX ROOT PAIR
  15768. 27    Q(NRAN)=P
  15769.     Q(NRAN+1)=P
  15770.     E(NRAN)=T
  15771.     E(NRAN+1)=-T
  15772.     GOTO 29
  15773. C
  15774. C       REAL ROOT PAIR
  15775. 28    Q(NRAN)=P-T
  15776.     Q(NRAN+1)=P+T
  15777.     E(NRAN)=0.D0
  15778. C
  15779. C          REDUCTION OF DEGREE BY 2 (DEFLATION)
  15780. 29    NRAN=NRAN-2
  15781.     GOTO 22
  15782. C
  15783. C       COMPUTATION OF REAL ROOT
  15784. 30    Q(NRAN+1)=EXPT+P
  15785. C
  15786. C          REDUCTION OF DEGREE BY 1 (DEFLATION)
  15787.     NRAN=NRAN-1
  15788.     GOTO 22
  15789. C
  15790. C       START QD-ITERATION
  15791. 31    JBEG=ISTA+1
  15792.     JEND=NRAN-1
  15793.     TEPS=EPS
  15794.     TDELT=1.E-2
  15795. 32    KOUNT=KOUNT+1
  15796.     P=Q(NRAN+1)
  15797.     R=ABS(SNGL(E(NRAN)))
  15798. C
  15799. C          TEST FOR CONVERGENCE
  15800.     IF(R-TEPS)30,30,33
  15801. 33    S=ABS(SNGL(E(JEND)))
  15802. C
  15803. C       IS THERE A REAL ROOT NEXT
  15804.     IF(S-R)38,38,34
  15805. C
  15806. C       IS DISPLACEMENT SMALL ENOUGH
  15807. 34    IF(R-TDELT)36,35,35
  15808. 35    P=0.D0
  15809. 36    O=P
  15810.     DO 37 J=JBEG,NRAN
  15811.     Q(J)=Q(J)+E(J)-E(J-1)-O
  15812. C
  15813. C          TEST FOR SMALL DIVISOR
  15814.     IF(DABS(Q(J))-POL(J))81,81,37
  15815. 37    E(J)=Q(J+1)*E(J)/Q(J)
  15816.     Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O
  15817.     GOTO 54
  15818. C
  15819. C       CALCULATE DISPLACEMENT FOR DOUBLE ROOTS
  15820. C          QUADRATIC EQUATION FOR DOUBLE ROOTS
  15821. C          X**2-(Q(NRAN)+Q(NRAN+1)+E(NRAN))*X+Q(NRAN)*Q(NRAN+1)=0
  15822. 38    P=0.5D0*(Q(NRAN)+E(NRAN)+Q(NRAN+1))
  15823.     O=P*P-Q(NRAN)*Q(NRAN+1)
  15824.     T=DSQRT(DABS(O))
  15825. C
  15826. C       TEST FOR CONVERGENCE
  15827.     IF(S-TEPS)26,26,39
  15828. C
  15829. C       ARE THERE COMPLEX ROOTS
  15830. 39    IF(O)43,40,40
  15831. 40    IF(P)42,41,41
  15832. 41    T=-T
  15833. 42    P=P+T
  15834.     R=S
  15835.     GOTO 34
  15836. C
  15837. C       MODIFICATION FOR COMPLEX ROOTS
  15838. C       IS DISPLACEMENT SMALL ENOUGH
  15839. 43    IF(S-TDELT)44,35,35
  15840. C
  15841. C          INITIALIZATION
  15842. 44    O=Q(JBEG)+E(JBEG)-P
  15843. C
  15844. C          TEST FOR SMALL DIVISOR
  15845.     IF(DABS(O)-POL(JBEG))81,81,45
  15846. 45    T=(T/O)**2
  15847.     U=E(JBEG)*Q(JBEG+1)/(O*(1.0D0+T))
  15848.     V=O+U
  15849. C
  15850. C       THREEFOLD LOOP FOR COMPLEX DISPLACEMENT
  15851.     KOUNT=KOUNT+2
  15852.     DO 53 J=JBEG,NRAN
  15853.     O=Q(J+1)+E(J+1)-U-P
  15854. C
  15855. C          TEST FOR SMALL DIVISOR
  15856.     IF(DABS(V)-POL(J))46,46,49
  15857. 46    IF(J-NRAN)81,47,81
  15858. 47    EXPT=EXPT+P
  15859.     IF(ABS(SNGL(E(JEND)))-TOL)48,48,81
  15860. 48    P=0.5D0*(V+O-E(JEND))
  15861.     O=P*P-(V-U)*(O-U*T-O*W*(1.D0+T)/Q(JEND))
  15862.     T=DSQRT(DABS(O))
  15863.     GOTO 26
  15864. C
  15865. C          TEST FOR SMALL DIVISOR
  15866. 49    IF(DABS(O)-POL(J+1))46,46,50
  15867. 50    W=U*O/V
  15868.     T=T*(V/O)**2
  15869.     Q(J)=V+W-E(J-1)
  15870.     U=0.D0
  15871.     IF(J-NRAN)51,52,52
  15872. 51    U=Q(J+2)*E(J+1)/(O*(1.D0+T))
  15873. 52    V=O+U-W
  15874. C
  15875. C          TEST FOR SMALL DIVISOR
  15876.     IF(DABS(Q(J))-POL(J))81,81,53
  15877. 53    E(J)=W*V*(1.0D0+T)/Q(J)
  15878.     Q(NRAN+1)=V-E(NRAN)
  15879. 54    EXPT=EXPT+P
  15880.     TEPS=TEPS*1.1
  15881.     TDELT=TDELT*1.1
  15882.     IF(KOUNT-LIMIT)32,55,55
  15883. C
  15884. C       NO CONVERGENCE WITH FEASIBLE TOLERANCE
  15885. C          ERROR RETURN IN CASE OF UNSATISFACTORY CONVERGENCE
  15886. 55    IER=1
  15887. C
  15888. C       REARRANGE CALCULATED ROOTS
  15889. 56    IEND=NSAV-NRAN-1
  15890.     E(ISTA)=ESAV
  15891.     IF(IEND)59,59,57
  15892. 57    DO 58 I=1,IEND
  15893.     J=ISTA+I
  15894.     K=NRAN+1+I
  15895.     E(J)=E(K)
  15896. 58    Q(J)=Q(K)
  15897. 59    IR=ISTA+IEND
  15898. C
  15899. C       NORMAL RETURN
  15900. 60    IR=IR-1
  15901.     IF(IR)78,78,61
  15902. C
  15903. C       REARRANGE CALCULATED ROOTS
  15904. 61    DO 62 I=1,IR
  15905.     Q(I)=Q(I+1)
  15906. 62    E(I)=E(I+1)
  15907. C
  15908. C       CALCULATE COEFFICIENT VECTOR FROM ROOTS
  15909.     POL(IR+1)=1.D0
  15910.     IEND=IR-1
  15911.     JBEG=1
  15912.     DO 69 J=1,IR
  15913.     ISTA=IR+1-J
  15914.     O=0.D0
  15915.     P=Q(ISTA)
  15916.     T=E(ISTA)
  15917.     IF(T)65,63,65
  15918. C
  15919. C       MULTIPLY WITH LINEAR FACTOR
  15920. 63    DO 64 I=ISTA,IR
  15921.     POL(I)=O-P*POL(I+1)
  15922. 64    O=POL(I+1)
  15923.     GOTO 69
  15924. 65    GOTO(66,67),JBEG
  15925. 66    JBEG=2
  15926.     POL(ISTA)=0.D0
  15927.     GOTO 69
  15928. C
  15929. C       MULTIPLY WITH QUADRATIC FACTOR
  15930. 67    JBEG=1
  15931.     U=P*P+T*T
  15932.     P=P+P
  15933.     DO 68 I=ISTA,IEND
  15934.     POL(I)=O-P*POL(I+1)+U*POL(I+2)
  15935. 68    O=POL(I+1)
  15936.     POL(IR)=O-P
  15937. 69    CONTINUE
  15938.     IF(IER)78,70,78
  15939. C
  15940. C       COMPARISON OF COEFFICIENT VECTORS, IE. TEST OF ACCURACY
  15941. 70    P=0.D0
  15942.     DO 75 I=1,IR
  15943.     IF(C(I))72,71,72
  15944. 71    O=DABS(POL(I))
  15945.     GOTO 73
  15946. 72    O=DABS((POL(I)-C(I))/C(I))
  15947. 73    IF(P-O)74,75,75
  15948. 74    P=O
  15949. 75    CONTINUE
  15950.     IF(SNGL(P)-TOL)77,76,76
  15951. 76    IER=-1
  15952. 77    Q(IR+1)=P
  15953.     E(IR+1)=0.D0
  15954. 78    RETURN
  15955. C
  15956. C       ERROR RETURNS
  15957. C          ERROR RETURN FOR POLYNOMIALS OF DEGREE LESS THAN 1
  15958. 79    IER=2
  15959.     IR=0
  15960.     RETURN
  15961. C
  15962. C          ERROR RETURN IF THERE EXISTS NO S-FRACTION
  15963. 80    IER=4
  15964.     IR=ISTA
  15965.     GOTO 60
  15966. C
  15967. C          ERROR RETURN IN CASE OF INSTABLE QD-ALGORITHM
  15968. 81    IER=3
  15969.     GOTO 56
  15970.     END
  15971. C
  15972. C    ..................................................................
  15973. C
  15974. C       SUBROUTINE DQA12
  15975. C
  15976. C       PURPOSE
  15977. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  15978. C                              FROM 0 TO INFINITY).
  15979. C
  15980. C       USAGE
  15981. C          CALL DQA12 (FCT,Y)
  15982. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  15983. C
  15984. C       DESCRIPTION OF PARAMETERS
  15985. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  15986. C                   SUBPROGRAM USED.
  15987. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  15988. C
  15989. C       REMARKS
  15990. C          NONE
  15991. C
  15992. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  15993. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  15994. C          MUST BE FURNISHED BY THE USER.
  15995. C
  15996. C       METHOD
  15997. C          EVALUATION IS DONE BY MEANS OF 12-POINT GENERALIZED GAUSS-
  15998. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  15999. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23.
  16000. C          FOR REFERENCE, SEE
  16001. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16002. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16003. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16004. C          TR00.1100 (MARCH 1964), PP.15-16.
  16005. C
  16006. C    ..................................................................
  16007. C
  16008.     SUBROUTINE DQA12(FCT,Y)
  16009. C
  16010. C
  16011.     DOUBLE PRECISION X,Y,FCT
  16012. C
  16013.     X=.36191360360615602D2
  16014.     Y=.33287369929782177D-15*FCT(X)
  16015.     X=.27661108779846090D2
  16016.     Y=Y+.13169240486156340D-11*FCT(X)
  16017.     X=.21396755936166109D2
  16018.     Y=Y+.60925085399751278D-9*FCT(X)
  16019.     X=.16432195087675313D2
  16020.     Y=Y+.8037942349882859D-7*FCT(X)
  16021.     X=.12390447963809471D2
  16022.     Y=Y+.43164914098046673D-5*FCT(X)
  16023.     X=.9075434230961203D1
  16024.     Y=Y+.11377383272808760D-3*FCT(X)
  16025.     X=.63699753880306349D1
  16026.     Y=Y+.16473849653768349D-2*FCT(X)
  16027.     X=.41984156448784132D1
  16028.     Y=Y+.14096711620145342D-1*FCT(X)
  16029.     X=.25098480972321280D1
  16030.     Y=Y+.7489094100646149D-1*FCT(X)
  16031.     X=.12695899401039615D1
  16032.     Y=Y+.25547924356911832D0*FCT(X)
  16033.     X=.45450668156378028D0
  16034.     Y=Y+.57235907069288604D0*FCT(X)
  16035.     X=.50361889117293951D-1
  16036.     Y=Y+.8538623277373985D0*FCT(X)
  16037.     RETURN
  16038.     END
  16039. C
  16040. C    ..................................................................
  16041. C
  16042. C       SUBROUTINE DQA16
  16043. C
  16044. C       PURPOSE
  16045. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  16046. C                              FROM 0 TO INFINITY).
  16047. C
  16048. C       USAGE
  16049. C          CALL DQA16 (FCT,Y)
  16050. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16051. C
  16052. C       DESCRIPTION OF PARAMETERS
  16053. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16054. C                   SUBPROGRAM USED.
  16055. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16056. C
  16057. C       REMARKS
  16058. C          NONE
  16059. C
  16060. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16061. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16062. C          MUST BE FURNISHED BY THE USER.
  16063. C
  16064. C       METHOD
  16065. C          EVALUATION IS DONE BY MEANS OF 16-POINT GENERALIZED GAUSS-
  16066. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  16067. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
  16068. C          FOR REFERENCE, SEE
  16069. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16070. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16071. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16072. C          TR00.1100 (MARCH 1964), PP.15-16.
  16073. C
  16074. C    ..................................................................
  16075. C
  16076.     SUBROUTINE DQA16(FCT,Y)
  16077. C
  16078. C
  16079.     DOUBLE PRECISION X,Y,FCT
  16080. C
  16081.     X=.50777223877537080D2
  16082.     Y=.14621352854768325D-21*FCT(X)
  16083.     X=.41081666525491202D2
  16084.     Y=Y+.18463473073036584D-17*FCT(X)
  16085.     X=.33781970488226166D2
  16086.     Y=Y+.23946880341856973D-14*FCT(X)
  16087.     X=.27831438211328676D2
  16088.     Y=Y+.8430020422652895D-12*FCT(X)
  16089.     X=.22821300693525208D2
  16090.     Y=Y+.11866582926793277D-9*FCT(X)
  16091.     X=.18537743178606694D2
  16092.     Y=Y+.8197664329541793D-8*FCT(X)
  16093.     X=.14851431341801250D2
  16094.     Y=Y+.31483355850911881D-6*FCT(X)
  16095.     X=.11677033673975957D2
  16096.     Y=Y+.7301170259124752D-5*FCT(X)
  16097.     X=.8955001337723390D1
  16098.     Y=Y+.10833168123639965D-3*FCT(X)
  16099.     X=.66422151797414440D1
  16100.     Y=Y+.10725367310559441D-2*FCT(X)
  16101.     X=.47067267076675872D1
  16102.     Y=Y+.7309780653308856D-2*FCT(X)
  16103.     X=.31246010507021443D1
  16104.     Y=Y+.35106857663146861D-1*FCT(X)
  16105.     X=.18779315076960743D1
  16106.     Y=Y+.12091626191182523D0*FCT(X)
  16107.     X=.9535531553908655D0
  16108.     Y=Y+.30253946815328497D0*FCT(X)
  16109.     X=.34220015601094768D0
  16110.     Y=Y+.55491628460505980D0*FCT(X)
  16111.     X=.37962914575313455D-1
  16112.     Y=Y+.7504767051856048D0*FCT(X)
  16113.     RETURN
  16114.     END
  16115. C
  16116. C    ..................................................................
  16117. C
  16118. C       SUBROUTINE DQA24
  16119. C
  16120. C       PURPOSE
  16121. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  16122. C                              FROM 0 TO INFINITY).
  16123. C
  16124. C       USAGE
  16125. C          CALL DQA24 (FCT,Y)
  16126. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16127. C
  16128. C       DESCRIPTION OF PARAMETERS
  16129. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16130. C                   SUBPROGRAM USED.
  16131. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16132. C
  16133. C       REMARKS
  16134. C          NONE
  16135. C
  16136. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16137. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16138. C          MUST BE FURNISHED BY THE USER.
  16139. C
  16140. C       METHOD
  16141. C          EVALUATION IS DONE BY MEANS OF 24-POINT GENERALIZED GAUSS-
  16142. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  16143. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
  16144. C          FOR REFERENCE, SEE
  16145. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16146. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16147. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16148. C          TR00.1100 (MARCH 1964), PP.15-16.
  16149. C
  16150. C    ..................................................................
  16151. C
  16152.     SUBROUTINE DQA24(FCT,Y)
  16153. C
  16154. C
  16155.     DOUBLE PRECISION X,Y,FCT
  16156. C
  16157.     X=.8055628081995041D2
  16158.     Y=.15871102921547994D-34*FCT(X)
  16159.     X=.69068601975304369D2
  16160.     Y=Y+.11969225386627757D-29*FCT(X)
  16161.     X=.60206666963057223D2
  16162.     Y=Y+.7370072160301340D-26*FCT(X)
  16163.     X=.52795432527283630D2
  16164.     Y=Y+.11129154937804570D-22*FCT(X)
  16165.     X=.46376979557540133D2
  16166.     Y=Y+.63767746470102769D-20*FCT(X)
  16167.     X=.40711598185543107D2
  16168.     Y=Y+.17460319202373353D-17*FCT(X)
  16169.     X=.35653703516328212D2
  16170.     Y=Y+.26303192453168170D-15*FCT(X)
  16171.     X=.31106464709046565D2
  16172.     Y=Y+.23951797309583587D-13*FCT(X)
  16173.     X=.27001406056472356D2
  16174.     Y=Y+.14093865163091778D-11*FCT(X)
  16175.     X=.23287932824879917D2
  16176.     Y=Y+.56305930756763382D-10*FCT(X)
  16177.     X=.19927425875242462D2
  16178.     Y=Y+.15860934990330765D-8*FCT(X)
  16179.     X=.16889671928527108D2
  16180.     Y=Y+.32450282717915397D-7*FCT(X)
  16181.     X=.14150586187285759D2
  16182.     Y=Y+.49373179873395010D-6*FCT(X)
  16183.     X=.11690695926056073D2
  16184.     Y=Y+.56945173834696962D-5*FCT(X)
  16185.     X=.9494095330026488D1
  16186.     Y=Y+.50571980554969778D-4*FCT(X)
  16187.     X=.7547704680023454D1
  16188.     Y=Y+.35030086360234566D-3*FCT(X)
  16189.     X=.58407332713236080D1
  16190.     Y=Y+.19127846396388306D-2*FCT(X)
  16191.     X=.43642830769353062D1
  16192.     Y=Y+.8306009823955105D-2*FCT(X)
  16193.     X=.31110524551477130D1
  16194.     Y=Y+.28889923149962199D-1*FCT(X)
  16195.     X=.20751129098523806D1
  16196.     Y=Y+.8095935396920770D-1*FCT(X)
  16197.     X=.12517406323627464D1
  16198.     Y=Y+.18364459415857036D0*FCT(X)
  16199.     X=.63729027873266879D0
  16200.     Y=Y+.33840894389128221D0*FCT(X)
  16201.     X=.22910231649262433D0
  16202.     Y=Y+.50792308532951820D0*FCT(X)
  16203.     X=.25437996585689359D-1
  16204.     Y=Y+.62200206075592616D0*FCT(X)
  16205.     RETURN
  16206.     END
  16207. C
  16208. C    ..................................................................
  16209. C
  16210. C       SUBROUTINE DQA32
  16211. C
  16212. C       PURPOSE
  16213. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  16214. C                              FROM 0 TO INFINITY).
  16215. C
  16216. C       USAGE
  16217. C          CALL DQA32 (FCT,Y)
  16218. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16219. C
  16220. C       DESCRIPTION OF PARAMETERS
  16221. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16222. C                   SUBPROGRAM USED.
  16223. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16224. C
  16225. C       REMARKS
  16226. C          NONE
  16227. C
  16228. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16229. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16230. C          MUST BE FURNISHED BY THE USER.
  16231. C
  16232. C       METHOD
  16233. C          EVALUATION IS DONE BY MEANS OF 32-POINT GENERALIZED GAUSS-
  16234. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  16235. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
  16236. C          FOR REFERENCE, SEE
  16237. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16238. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16239. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16240. C          TR00.1100 (MARCH 1964), PP.15-16.
  16241. C
  16242. C    ..................................................................
  16243. C
  16244.     SUBROUTINE DQA32(FCT,Y)
  16245. C
  16246. C
  16247.     DOUBLE PRECISION X,Y,FCT
  16248. C
  16249.     X=.11079926894707576D3
  16250.     Y=.11071413071713886D-27*FCT(X)
  16251.     X=.9791671642606276D2
  16252.     Y=Y+.33594959802163184D-22*FCT(X)
  16253.     X=.8785611994313352D22
  16254.     Y=Y+.68422760225114810D-18*FCT(X)
  16255.     X=.7933908652882320D2
  16256.     Y=Y+.31147812492595276D-14*FCT(X)
  16257.     X=.71868499359551422D2
  16258.     Y=Y+.50993217982259985D-11*FCT(X)
  16259.     X=.65184426376135782D2
  16260.     Y=Y+.38582071909299337D-8*FCT(X)
  16261.     X=.59129027934391951D2
  16262.     Y=Y+.15723595577851821D-5*FCT(X)
  16263.     X=.53597231826148512D2
  16264.     Y=Y+.38234137666012857D-3*FCT(X)
  16265.     X=.48514583867416048D2
  16266.     Y=Y+.59657255685597023D-1*FCT(X)
  16267.     X=.43825886369903902D2
  16268.     Y=Y+.63045091330075628D1*FCT(X)
  16269.     X=.39488797123368127D2
  16270.     Y=Y+.47037694213516382D3*FCT(X)
  16271.     X=.35469961396173283D2
  16272.     Y=Y+.25601867826448761D5*FCT(X)
  16273.     X=.31742543790616606D2
  16274.     Y=Y+.10437247453181695D7*FCT(X)
  16275.     X=.28284583194970531D2
  16276.     Y=Y+.32566814614194407D8*FCT(X)
  16277.     X=.25077856544198053D2
  16278.     Y=Y+.7918355533895448D9*FCT(X)
  16279.     X=.22107070382206007D2
  16280.     Y=Y+.15230434500290903D11*FCT(X)
  16281.     X=.19359271087268714D2
  16282.     Y=Y+.23472334846430987D12*FCT(X)
  16283.     X=.16823405362953694D2
  16284.     Y=Y+.29302506329522187D13*FCT(X)
  16285.     X=.14489986690780274D2
  16286.     Y=Y+.29910658734544941D14*FCT(X)
  16287.     X=.12350838217714770D2
  16288.     Y=Y+.25166805020623692D15*FCT(X)
  16289.     X=.10398891905552624D2
  16290.     Y=Y+.17576998461700718D16*FCT(X)
  16291.     X=.8628029857405929D1
  16292.     Y=Y+.10251858271572549D17*FCT(X)
  16293.     X=.70329577982838936D1
  16294.     Y=Y+.50196739702612497D17*FCT(X)
  16295.     X=.56091034574961513D1
  16296.     Y=Y+.20726581990151553D18*FCT(X)
  16297.     X=.43525345293301410D1
  16298.     Y=Y+.7245173957068918D18*FCT(X)
  16299.     X=.32598922564569419D1
  16300.     Y=Y+.21512081019758274D19*FCT(X)
  16301.     X=.23283376682103970D1
  16302.     Y=Y+.54406257907377837D19*FCT(X)
  16303.     X=.15555082314789380D1
  16304.     Y=Y+.11747996392819887D20*FCT(X)
  16305.     X=.9394832145007343D0
  16306.     Y=Y+.21699669861237368D20*FCT(X)
  16307.     X=.47875647727748885D0
  16308.     Y=Y+.34337168469816740D20*FCT(X)
  16309.     X=.17221572414539558D0
  16310.     Y=Y+.46598957212535609D20*FCT(X)
  16311.     X=.19127510968446856D-1
  16312.     Y=Y+.54275484988260796D20*FCT(X)
  16313.     Y=Y*1.D-20
  16314.     RETURN
  16315.     END
  16316. C
  16317. C    ..................................................................
  16318. C
  16319. C       SUBROUTINE DQA4
  16320. C
  16321. C       PURPOSE
  16322. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  16323. C                              FROM 0 TO INFINITY).
  16324. C
  16325. C       USAGE
  16326. C          CALL DQA4 (FCT,Y)
  16327. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16328. C
  16329. C       DESCRIPTION OF PARAMETERS
  16330. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16331. C                   SUBPROGRAM USED.
  16332. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16333. C
  16334. C       REMARKS
  16335. C          NONE
  16336. C
  16337. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16338. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16339. C          MUST BE FURNISHED BY THE USER.
  16340. C
  16341. C       METHOD
  16342. C          EVALUATION IS DONE BY MEANS OF 4-POINT GENERALIZED GAUSS-
  16343. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  16344. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
  16345. C          FOR REFERENCE, SEE
  16346. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16347. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16348. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16349. C          TR00.1100 (MARCH 1964), PP.15-16.
  16350. C
  16351. C    ..................................................................
  16352. C
  16353.     SUBROUTINE DQA4(FCT,Y)
  16354. C
  16355. C
  16356.     DOUBLE PRECISION X,Y,FCT
  16357. C
  16358.     X=.8588635689012034D1
  16359.     Y=.39920814442273524D-3*FCT(X)
  16360.     X=.39269635013582872D1
  16361.     Y=Y+.34155966014826951D-1*FCT(X)
  16362.     X=.13390972881263614D1
  16363.     Y=Y+.41560465162978376D0*FCT(X)
  16364.     X=.14530352150331709D0
  16365.     Y=Y+.13222940251164826D1*FCT(X)
  16366.     RETURN
  16367.     END
  16368. C
  16369. C    ..................................................................
  16370. C
  16371. C       SUBROUTINE DQA8
  16372. C
  16373. C       PURPOSE
  16374. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
  16375. C                              FROM 0 TO INFINITY).
  16376. C
  16377. C       USAGE
  16378. C          CALL DQA8 (FCT,Y)
  16379. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16380. C
  16381. C       DESCRIPTION OF PARAMETERS
  16382. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16383. C                   SUBPROGRAM USED.
  16384. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16385. C
  16386. C       REMARKS
  16387. C          NONE
  16388. C
  16389. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16390. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16391. C          MUST BE FURNISHED BY THE USER.
  16392. C
  16393. C       METHOD
  16394. C          EVALUATION IS DONE BY MEANS OF 8-POINT GENERALIZED GAUSS-
  16395. C          LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
  16396. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
  16397. C          FOR REFERENCE, SEE
  16398. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16399. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16400. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16401. C          TR00.1100 (MARCH 1964), PP.15-16.
  16402. C
  16403. C    ..................................................................
  16404. C
  16405.     SUBROUTINE DQA8(FCT,Y)
  16406. C
  16407. C
  16408.     DOUBLE PRECISION X,Y,FCT
  16409. C
  16410.     X=.21984272840962651D2
  16411.     Y=.53096149480223645D-9*FCT(X)
  16412.     X=.14972627088426393D2
  16413.     Y=Y+.46419616897304213D-6*FCT(X)
  16414.     X=.10093323675221343D2
  16415.     Y=Y+.54237201850757630D-4*FCT(X)
  16416.     X=.64831454286271704D1
  16417.     Y=Y+.18645680172483611D-2*FCT(X)
  16418.     X=.38094763614849071D1
  16419.     Y=Y+.25760623071019947D-1*FCT(X)
  16420.     X=.19051136350314284D1
  16421.     Y=Y+.16762008279797166D0*FCT(X)
  16422.     X=.67724908764928915D0
  16423.     Y=Y+.56129491705706735D0*FCT(X)
  16424.     X=.7479188259681827D-1
  16425.     Y=Y+.10158589580332275D1*FCT(X)
  16426.     RETURN
  16427.     END
  16428. C
  16429. C    ..................................................................
  16430. C
  16431. C       SUBROUTINE DQATR
  16432. C
  16433. C
  16434. C       PURPOSE
  16435. C          TO COMPUTE AN APPROXIMATION FOR INTEGRAL(FCT(X), SUMMED
  16436. C          OVER X FROM XL TO XU).
  16437. C
  16438. C       USAGE
  16439. C          CALL DQATR (XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
  16440. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
  16441. C
  16442. C       DESCRIPTION OF PARAMETERS
  16443. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16444. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16445. C          EPS    - SINGLE PRECISION UPPER BOUND OF THE ABSOLUTE ERROR.
  16446. C          NDIM   - THE DIMENSION OF THE AUXILIARY STORAGE ARRAY AUX.
  16447. C                   NDIM-1 IS THE MAXIMAL NUMBER OF BISECTIONS OF
  16448. C                   THE INTERVAL (XL,XU).
  16449. C          FCT    - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
  16450. C                   SUBPROGRAM USED.
  16451. C          Y      - RESULTING DOUBLE PRECISION APPROXIMATION FOR THE
  16452. C                   INTEGRAL VALUE.
  16453. C          IER    - A RESULTING ERROR PARAMETER.
  16454. C          AUX    - AUXILIARY DOUBLE PRECISION STORAGE ARRAY WITH
  16455. C                   DIMENSION NDIM.
  16456. C
  16457. C       REMARKS
  16458. C          ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
  16459. C          IER=0  - IT WAS POSSIBLE TO REACH THE REQUIRED ACCURACY.
  16460. C                   NO ERROR.
  16461. C          IER=1  - IT IS IMPOSSIBLE TO REACH THE REQUIRED ACCURACY
  16462. C                   BECAUSE OF ROUNDING ERRORS.
  16463. C          IER=2  - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE NDIM
  16464. C                   IS LESS THAN 5, OR THE REQUIRED ACCURACY COULD NOT
  16465. C                   BE REACHED WITHIN NDIM-1 STEPS. NDIM SHOULD BE
  16466. C                   INCREASED.
  16467. C
  16468. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16469. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16470. C          MUST BE CODED BY THE USER. ITS DOUBLE PRECISION ARGUMENT X
  16471. C          SHOULD NOT BE DESTROYED.
  16472. C
  16473. C       METHOD
  16474. C          EVALUATION OF Y IS DONE BY MEANS OF TRAPEZOIDAL RULE IN
  16475. C          CONNECTION WITH ROMBERGS PRINCIPLE. ON RETURN Y CONTAINS
  16476. C          THE BEST POSSIBLE APPROXIMATION OF THE INTEGRAL VALUE AND
  16477. C          VECTOR AUX THE UPWARD DIAGONAL OF ROMBERG SCHEME.
  16478. C          COMPONENTS AUX(I) (I=1,2,...,IEND, WITH IEND LESS THAN OR
  16479. C          EQUAL TO NDIM) BECOME APPROXIMATIONS TO INTEGRAL VALUE WITH
  16480. C          DECREASING ACCURACY BY MULTIPLICATION WITH (XU-XL).
  16481. C          FOR REFERENCE, SEE
  16482. C          (1) FILIPPI, DAS VERFAHREN VON ROMBERG-STIEFEL-BAUER ALS
  16483. C              SPEZIALFALL DES ALLGEMEINEN PRINZIPS VON RICHARDSON,
  16484. C              MATHEMATIK-TECHNIK-WIRTSCHAFT, VOL.11, ISS.2 (1964),
  16485. C              PP.49-54.
  16486. C          (2) BAUER, ALGORITHM 60, CACM, VOL.4, ISS.6 (1961), PP.255.
  16487. C
  16488. C    ..................................................................
  16489. C
  16490.     SUBROUTINE DQATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
  16491. C
  16492. C
  16493.     DIMENSION AUX(1)
  16494.     DOUBLE PRECISION AUX,XL,XU,X,Y,H,HH,HD,P,Q,SM,FCT
  16495. C
  16496. C    PREPARATIONS OF ROMBERG-LOOP
  16497.     AUX(1)=.5D0*(FCT(XL)+FCT(XU))
  16498.     H=XU-XL
  16499.     IF(NDIM-1)8,8,1
  16500. 1    IF(H)2,10,2
  16501. C
  16502. C    NDIM IS GREATER THAN 1 AND H IS NOT EQUAL TO 0.
  16503. 2    HH=H
  16504.     E=EPS/DABS(H)
  16505.     DELT2=0.
  16506.     P=1.D0
  16507.     JJ=1
  16508.     DO 7 I=2,NDIM
  16509.     Y=AUX(1)
  16510.     DELT1=DELT2
  16511.     HD=HH
  16512.     HH=.5D0*HH
  16513.     P=.5D0*P
  16514.     X=XL+HH
  16515.     SM=0.D0
  16516.     DO 3 J=1,JJ
  16517.     SM=SM+FCT(X)
  16518. 3    X=X+HD
  16519.     AUX(I)=.5D0*AUX(I-1)+P*SM
  16520. C    A NEW APPROXIMATION OF INTEGRAL VALUE IS COMPUTED BY MEANS OF
  16521. C    TRAPEZOIDAL RULE.
  16522. C
  16523. C    START OF ROMBERGS EXTRAPOLATION METHOD.
  16524.     Q=1.D0
  16525.     JI=I-1
  16526.     DO 4 J=1,JI
  16527.     II=I-J
  16528.     Q=Q+Q
  16529.     Q=Q+Q
  16530. 4    AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.D0)
  16531. C    END OF ROMBERG-STEP
  16532. C
  16533.     DELT2=DABS(Y-AUX(1))
  16534.     IF(I-5)7,5,5
  16535. 5    IF(DELT2-E)10,10,6
  16536. 6    IF(DELT2-DELT1)7,11,11
  16537. 7    JJ=JJ+JJ
  16538. 8    IER=2
  16539. 9    Y=H*AUX(1)
  16540.     RETURN
  16541. 10    IER=0
  16542.     GO TO 9
  16543. 11    IER=1
  16544.     Y=H*Y
  16545.     RETURN
  16546.     END
  16547. C
  16548. C    ..................................................................
  16549. C
  16550. C       SUBROUTINE DQG12
  16551. C
  16552. C       PURPOSE
  16553. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16554. C
  16555. C       USAGE
  16556. C          CALL DQG12 (XL,XU,FCT,Y)
  16557. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16558. C
  16559. C       DESCRIPTION OF PARAMETERS
  16560. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16561. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16562. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16563. C                   SUBPROGRAM USED.
  16564. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16565. C
  16566. C       REMARKS
  16567. C          NONE
  16568. C
  16569. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16570. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16571. C          MUST BE FURNISHED BY THE USER.
  16572. C
  16573. C       METHOD
  16574. C          EVALUATION IS DONE BY MEANS OF 12-POINT GAUSS QUADRATURE
  16575. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 23
  16576. C          EXACTLY. FOR REFERENCE, SEE
  16577. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16578. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16579. C
  16580. C    ..................................................................
  16581. C
  16582.     SUBROUTINE DQG12(XL,XU,FCT,Y)
  16583. C
  16584. C
  16585.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16586. C
  16587.     A=.5D0*(XU+XL)
  16588.     B=XU-XL
  16589.     C=.49078031712335963D0*B
  16590.     Y=.23587668193255914D-1*(FCT(A+C)+FCT(A-C))
  16591.     C=.45205862818523743D0*B
  16592.     Y=Y+.53469662997659215D-1*(FCT(A+C)+FCT(A-C))
  16593.     C=.38495133709715234D0*B
  16594.     Y=Y+.8003916427167311D-1*(FCT(A+C)+FCT(A-C))
  16595.     C=.29365897714330872D0*B
  16596.     Y=Y+.10158371336153296D0*(FCT(A+C)+FCT(A-C))
  16597.     C=.18391574949909010D0*B
  16598.     Y=Y+.11674626826917740D0*(FCT(A+C)+FCT(A-C))
  16599.     C=.62616704255734458D-1*B
  16600.     Y=B*(Y+.12457352290670139D0*(FCT(A+C)+FCT(A-C)))
  16601.     RETURN
  16602.     END
  16603. C
  16604. C    ..................................................................
  16605. C
  16606. C       SUBROUTINE DQG16
  16607. C
  16608. C       PURPOSE
  16609. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16610. C
  16611. C       USAGE
  16612. C          CALL DQG16 (XL,XU,FCT,Y)
  16613. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16614. C
  16615. C       DESCRIPTION OF PARAMETERS
  16616. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16617. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16618. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16619. C                   SUBPROGRAM USED.
  16620. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16621. C
  16622. C       REMARKS
  16623. C          NONE
  16624. C
  16625. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16626. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16627. C          MUST BE FURNISHED BY THE USER.
  16628. C
  16629. C       METHOD
  16630. C          EVALUATION IS DONE BY MEANS OF 16-POINT GAUSS QUADRATURE
  16631. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 31
  16632. C          EXACTLY. FOR REFERENCE, SEE
  16633. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16634. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16635. C
  16636. C    ..................................................................
  16637. C
  16638.     SUBROUTINE DQG16(XL,XU,FCT,Y)
  16639. C
  16640. C
  16641.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16642. C
  16643.     A=.5D0*(XU+XL)
  16644.     B=XU-XL
  16645.     C=.49470046749582497D0*B
  16646.     Y=.13576229705877047D-1*(FCT(A+C)+FCT(A-C))
  16647.     C=.47228751153661629D0*B
  16648.     Y=Y+.31126761969323946D-1*(FCT(A+C)+FCT(A-C))
  16649.     C=.43281560119391587D0*B
  16650.     Y=Y+.47579255841246392D-1*(FCT(A+C)+FCT(A-C))
  16651.     C=.37770220417750152D0*B
  16652.     Y=Y+.62314485627766936D-1*(FCT(A+C)+FCT(A-C))
  16653.     C=.30893812220132187D0*B
  16654.     Y=Y+.7479799440828837D-1*(FCT(A+C)+FCT(A-C))
  16655.     C=.22900838882861369D0*B
  16656.     Y=Y+.8457825969750127D-1*(FCT(A+C)+FCT(A-C))
  16657.     C=.14080177538962946D0*B
  16658.     Y=Y+.9130170752246179D-1*(FCT(A+C)+FCT(A-C))
  16659.     C=.47506254918818720D-1*B
  16660.     Y=B*(Y+.9472530522753425D-1*(FCT(A+C)+FCT(A-C)))
  16661.     RETURN
  16662.     END
  16663. C
  16664. C    ..................................................................
  16665. C
  16666. C       SUBROUTINE DQG24
  16667. C
  16668. C       PURPOSE
  16669. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16670. C
  16671. C       USAGE
  16672. C          CALL DQG24 (XL,XU,FCT,Y)
  16673. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16674. C
  16675. C       DESCRIPTION OF PARAMETERS
  16676. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16677. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16678. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16679. C                   SUBPROGRAM USED.
  16680. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16681. C
  16682. C       REMARKS
  16683. C          NONE
  16684. C
  16685. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16686. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16687. C          MUST BE FURNISHED BY THE USER.
  16688. C
  16689. C       METHOD
  16690. C          EVALUATION IS DONE BY MEANS OF 24-POINT GAUSS QUADRATURE
  16691. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 47
  16692. C          EXACTLY. FOR REFERENCE, SEE
  16693. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16694. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16695. C
  16696. C    ..................................................................
  16697. C
  16698.     SUBROUTINE DQG24(XL,XU,FCT,Y)
  16699. C
  16700. C
  16701.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16702. C
  16703.     A=.5D0*(XU+XL)
  16704.     B=XU-XL
  16705.     C=.49759360999851068D0*B
  16706.     Y=.61706148999935998D-2*(FCT(A+C)+FCT(A-C))
  16707.     C=.48736427798565475D0*B
  16708.     Y=Y+.14265694314466832D-1*(FCT(A+C)+FCT(A-C))
  16709.     C=.46913727600136638D0*B
  16710.     Y=Y+.22138719408709903D-1*(FCT(A+C)+FCT(A-C))
  16711.     C=.44320776350220052D0*B
  16712.     Y=Y+.29649292457718390D-1*(FCT(A+C)+FCT(A-C))
  16713.     C=.41000099298695146D0*B
  16714.     Y=Y+.36673240705540153D-1*(FCT(A+C)+FCT(A-C))
  16715.     C=.37006209578927718D0*B
  16716.     Y=Y+.43095080765976638D-1*(FCT(A+C)+FCT(A-C))
  16717.     C=.32404682596848778D0*B
  16718.     Y=Y+.48809326052056944D-1*(FCT(A+C)+FCT(A-C))
  16719.     C=.27271073569441977D0*B
  16720.     Y=Y+.53722135057982817D-1*(FCT(A+C)+FCT(A-C))
  16721.     C=.21689675381302257D0*B
  16722.     Y=Y+.57752834026862801D-1*(FCT(A+C)+FCT(A-C))
  16723.     C=.15752133984808169D0*B
  16724.     Y=Y+.60835236463901696D-1*(FCT(A+C)+FCT(A-C))
  16725.     C=.9555943373680815D-1*B
  16726.     Y=Y+.62918728173414148D-1*(FCT(A+C)+FCT(A-C))
  16727.     C=.32028446431302813D-1*B
  16728.     Y=B*(Y+.63969097673376078D-1*(FCT(A+C)+FCT(A-C)))
  16729.     RETURN
  16730.     END
  16731. C
  16732. C    ..................................................................
  16733. C
  16734. C       SUBROUTINE DQG32
  16735. C
  16736. C       PURPOSE
  16737. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16738. C
  16739. C       USAGE
  16740. C          CALL DQG32 (XL,XU,FCT,Y)
  16741. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16742. C
  16743. C       DESCRIPTION OF PARAMETERS
  16744. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16745. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16746. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16747. C                   SUBPROGRAM USED.
  16748. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16749. C
  16750. C       REMARKS
  16751. C          NONE
  16752. C
  16753. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16754. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16755. C          MUST BE FURNISHED BY THE USER.
  16756. C
  16757. C       METHOD
  16758. C          EVALUATION IS DONE BY MEANS OF 32-POINT GAUSS QUADRATURE
  16759. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 63
  16760. C          EXACTLY. FOR REFERENCE, SEE
  16761. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16762. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16763. C
  16764. C    ..................................................................
  16765. C
  16766.     SUBROUTINE DQG32(XL,XU,FCT,Y)
  16767. C
  16768. C
  16769.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16770. C
  16771.     A=.5D0*(XU+XL)
  16772.     B=XU-XL
  16773.     C=.49863193092474078D0*B
  16774.     Y=.35093050047350483D-2*(FCT(A+C)+FCT(A-C))
  16775.     C=.49280575577263417D0*B
  16776.     Y=Y+.8137197365452835D-2*(FCT(A+C)+FCT(A-C))
  16777.     C=.48238112779375322D0*B
  16778.     Y=Y+.12696032654631030D-1*(FCT(A+C)+FCT(A-C))
  16779.     C=.46745303796886984D0*B
  16780.     Y=Y+.17136931456510717D-1*(FCT(A+C)+FCT(A-C))
  16781.     C=.44816057788302606D0*B
  16782.     Y=Y+.21417949011113340D-1*(FCT(A+C)+FCT(A-C))
  16783.     C=.42468380686628499D0*B
  16784.     Y=Y+.25499029631188088D-1*(FCT(A+C)+FCT(A-C))
  16785.     C=.39724189798397120D0*B
  16786.     Y=Y+.29342046739267774D-1*(FCT(A+C)+FCT(A-C))
  16787.     C=.36609105937014484D0*B
  16788.     Y=Y+.32911111388180923D-1*(FCT(A+C)+FCT(A-C))
  16789.     C=.33152213346510760D0*B
  16790.     Y=Y+.36172897054424253D-1*(FCT(A+C)+FCT(A-C))
  16791.     C=.29385787862038116D0*B
  16792.     Y=Y+.39096947893535153D-1*(FCT(A+C)+FCT(A-C))
  16793.     C=.25344995446611470D0*B
  16794.     Y=Y+.41655962113473378D-1*(FCT(A+C)+FCT(A-C))
  16795.     C=.21067563806531767D0*B
  16796.     Y=Y+.43826046502201906D-1*(FCT(A+C)+FCT(A-C))
  16797.     C=.16593430114106382D0*B
  16798.     Y=Y+.45586939347881942D-1*(FCT(A+C)+FCT(A-C))
  16799.     C=.11964368112606854D0*B
  16800.     Y=Y+.46922199540402283D-1*(FCT(A+C)+FCT(A-C))
  16801.     C=.7223598079139825D-1*B
  16802.     Y=Y+.47819360039637430D-1*(FCT(A+C)+FCT(A-C))
  16803.     C=.24153832843869158D-1*B
  16804.     Y=B*(Y+.48270044257363900D-1*(FCT(A+C)+FCT(A-C)))
  16805.     RETURN
  16806.     END
  16807. C
  16808. C    ..................................................................
  16809. C
  16810. C       SUBROUTINE DQG4
  16811. C
  16812. C       PURPOSE
  16813. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16814. C
  16815. C       USAGE
  16816. C          CALL DQG4 (XL,XU,FCT,Y)
  16817. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16818. C
  16819. C       DESCRIPTION OF PARAMETERS
  16820. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16821. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16822. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16823. C                   SUBPROGRAM USED.
  16824. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16825. C
  16826. C       REMARKS
  16827. C          NONE
  16828. C
  16829. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16830. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16831. C          MUST BE FURNISHED BY THE USER.
  16832. C
  16833. C       METHOD
  16834. C          EVALUATION IS DONE BY MEANS OF 4-POINT GAUSS QUADRATURE
  16835. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 7
  16836. C          EXACTLY. FOR REFERENCE, SEE
  16837. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16838. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16839. C
  16840. C    ..................................................................
  16841. C
  16842.     SUBROUTINE DQG4(XL,XU,FCT,Y)
  16843. C
  16844. C
  16845.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16846. C
  16847.     A=.5D0*(XU+XL)
  16848.     B=XU-XL
  16849.     C=.43056815579702629D0*B
  16850.     Y=.17392742256872693D0*(FCT(A+C)+FCT(A-C))
  16851.     C=.16999052179242813D0*B
  16852.     Y=B*(Y+.32607257743127307D0*(FCT(A+C)+FCT(A-C)))
  16853.     RETURN
  16854.     END
  16855. C
  16856. C    ..................................................................
  16857. C
  16858. C       SUBROUTINE DQG8
  16859. C
  16860. C       PURPOSE
  16861. C          TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
  16862. C
  16863. C       USAGE
  16864. C          CALL DQG8 (XL,XU,FCT,Y)
  16865. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16866. C
  16867. C       DESCRIPTION OF PARAMETERS
  16868. C          XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
  16869. C          XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
  16870. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16871. C                   SUBPROGRAM USED.
  16872. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16873. C
  16874. C       REMARKS
  16875. C          NONE
  16876. C
  16877. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16878. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16879. C          MUST BE FURNISHED BY THE USER.
  16880. C
  16881. C       METHOD
  16882. C          EVALUATION IS DONE BY MEANS OF 8-POINT GAUSS QUADRATURE
  16883. C          FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 15
  16884. C          EXACTLY. FOR REFERENCE, SEE
  16885. C          V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
  16886. C          MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
  16887. C
  16888. C    ..................................................................
  16889. C
  16890.     SUBROUTINE DQG8(XL,XU,FCT,Y)
  16891. C
  16892. C
  16893.     DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
  16894. C
  16895.     A=.5D0*(XU+XL)
  16896.     B=XU-XL
  16897.     C=.48014492824876812D0*B
  16898.     Y=.50614268145188130D-1*(FCT(A+C)+FCT(A-C))
  16899.     C=.39833323870681337D0*B
  16900.     Y=Y+.11119051722668724D0*(FCT(A+C)+FCT(A-C))
  16901.     C=.26276620495816449D0*B
  16902.     Y=Y+.15685332293894364D0*(FCT(A+C)+FCT(A-C))
  16903.     C=.9171732124782490D-1*B
  16904.     Y=B*(Y+.18134189168918099D0*(FCT(A+C)+FCT(A-C)))
  16905.     RETURN
  16906.     END
  16907. C
  16908. C    ..................................................................
  16909. C
  16910. C       SUBROUTINE DQH16
  16911. C
  16912. C       PURPOSE
  16913. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  16914. C                              -INFINITY TO +INFINITY).
  16915. C
  16916. C       USAGE
  16917. C          CALL DQH16 (FCT,Y)
  16918. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16919. C
  16920. C       DESCRIPTION OF PARAMETERS
  16921. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16922. C                   SUBPROGRAM USED.
  16923. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16924. C
  16925. C       REMARKS
  16926. C          NONE
  16927. C
  16928. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16929. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16930. C          MUST BE FURNISHED BY THE USER.
  16931. C
  16932. C       METHOD
  16933. C          EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-HERMITE
  16934. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  16935. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
  16936. C          FOR REFERENCE, SEE
  16937. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  16938. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  16939. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  16940. C          TR00.1100 (MARCH 1964), PP.213-214.
  16941. C
  16942. C    ..................................................................
  16943. C
  16944.     SUBROUTINE DQH16(FCT,Y)
  16945. C
  16946. C
  16947.     DOUBLE PRECISION X,Y,Z,FCT
  16948. C
  16949.     X=.46887389393058184D1
  16950.     Z=-X
  16951.     Y=.26548074740111822D-9*(FCT(X)+FCT(Z))
  16952.     X=.38694479048601227D1
  16953.     Z=-X
  16954.     Y=Y+.23209808448652107D-6*(FCT(X)+FCT(Z))
  16955.     X=.31769991619799560D1
  16956.     Z=-X
  16957.     Y=Y+.27118600925378815D-4*(FCT(X)+FCT(Z))
  16958.     X=.25462021578474814D1
  16959.     Z=-X
  16960.     Y=Y+.9322840086241805D-3*(FCT(X)+FCT(Z))
  16961.     X=.19517879909162540D1
  16962.     Z=-X
  16963.     Y=Y+.12880311535509974D-1*(FCT(X)+FCT(Z))
  16964.     X=.13802585391988808D1
  16965.     Z=-X
  16966.     Y=Y+.8381004139898583D-1*(FCT(X)+FCT(Z))
  16967.     X=.8229514491446559D0
  16968.     Z=-X
  16969.     Y=Y+.28064745852853368D0*(FCT(X)+FCT(Z))
  16970.     X=.27348104613815245D0
  16971.     Z=-X
  16972.     Y=Y+.50792947901661374D0*(FCT(X)+FCT(Z))
  16973.     RETURN
  16974.     END
  16975. C
  16976. C    ..................................................................
  16977. C
  16978. C       SUBROUTINE DQH24
  16979. C
  16980. C       PURPOSE
  16981. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  16982. C                              -INFINITY TO +INFINITY).
  16983. C
  16984. C       USAGE
  16985. C          CALL DQH24 (FCT,Y)
  16986. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  16987. C
  16988. C       DESCRIPTION OF PARAMETERS
  16989. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  16990. C                   SUBPROGRAM USED.
  16991. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  16992. C
  16993. C       REMARKS
  16994. C          NONE
  16995. C
  16996. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  16997. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  16998. C          MUST BE FURNISHED BY THE USER.
  16999. C
  17000. C       METHOD
  17001. C          EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-HERMITE
  17002. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  17003. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
  17004. C          FOR REFERENCE, SEE
  17005. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17006. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17007. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17008. C          TR00.1100 (MARCH 1964), PP.213-214.
  17009. C
  17010. C    ..................................................................
  17011. C
  17012.     SUBROUTINE DQH24(FCT,Y)
  17013. C
  17014. C
  17015.     DOUBLE PRECISION X,Y,Z,FCT
  17016. C
  17017.     X=.60159255614257397D1
  17018.     Z=-X
  17019.     Y=.16643684964891089D-15*(FCT(X)+FCT(Z))
  17020.     X=.52593829276680444D1
  17021.     Z=-X
  17022.     Y=Y+.65846202430781701D-12*(FCT(X)+FCT(Z))
  17023.     X=.46256627564237873D1
  17024.     Z=-X
  17025.     Y=Y+.30462542699875639D-9*(FCT(X)+FCT(Z))
  17026.     X=.40536644024481495D1
  17027.     Z=-X
  17028.     Y=Y+.40189711749414297D-7*(FCT(X)+FCT(Z))
  17029.     X=.35200068130345247D1
  17030.     Z=-X
  17031.     Y=Y+.21582457049023336D-5*(FCT(X)+FCT(Z))
  17032.     X=.30125461375655648D1
  17033.     Z=-X
  17034.     Y=Y+.56886916364043798D-4*(FCT(X)+FCT(Z))
  17035.     X=.25238810170114270D1
  17036.     Z=-X
  17037.     Y=Y+.8236924826884175D-3*(FCT(X)+FCT(Z))
  17038.     X=.20490035736616989D1
  17039.     Z=-X
  17040.     Y=Y+.70483558100726710D-2*(FCT(X)+FCT(Z))
  17041.     X=.15842500109616941D1
  17042.     Z=-X
  17043.     Y=Y+.37445470503230746D-1*(FCT(X)+FCT(Z))
  17044.     X=.11267608176112451D1
  17045.     Z=-X
  17046.     Y=Y+.12773962178455916D0*(FCT(X)+FCT(Z))
  17047.     X=.67417110703721224D0
  17048.     Z=-X
  17049.     Y=Y+.28617953534644302D0*(FCT(X)+FCT(Z))
  17050.     X=.22441454747251559D0
  17051.     Z=-X
  17052.     Y=Y+.42693116386869925D0*(FCT(X)+FCT(Z))
  17053.     RETURN
  17054.     END
  17055. C
  17056. C    ..................................................................
  17057. C
  17058. C       SUBROUTINE DQH32
  17059. C
  17060. C       PURPOSE
  17061. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  17062. C                              -INFINITY TO +INFINITY).
  17063. C
  17064. C       USAGE
  17065. C          CALL DQH32 (FCT,Y)
  17066. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17067. C
  17068. C       DESCRIPTION OF PARAMETERS
  17069. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17070. C                   SUBPROGRAM USED.
  17071. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17072. C
  17073. C       REMARKS
  17074. C          NONE
  17075. C
  17076. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17077. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17078. C          MUST BE FURNISHED BY THE USER.
  17079. C
  17080. C       METHOD
  17081. C          EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-HERMITE
  17082. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  17083. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
  17084. C          FOR REFERENCE, SEE
  17085. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17086. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17087. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17088. C          TR00.1100 (MARCH 1964), PP.213-214.
  17089. C
  17090. C    ..................................................................
  17091. C
  17092.     SUBROUTINE DQH32(FCT,Y)
  17093. C
  17094. C
  17095.     DOUBLE PRECISION X,Y,Z,FCT
  17096. C
  17097.     X=.71258139098307276D1
  17098.     Z=-X
  17099.     Y=.7310676427384162D-22*(FCT(X)+FCT(Z))
  17100.     X=.64094981492696604D1
  17101.     Z=-X
  17102.     Y=Y+.9231736536518292D-18*(FCT(X)+FCT(Z))
  17103.     X=.58122259495159138D1
  17104.     Z=-X
  17105.     Y=Y+.11973440170928487D-14*(FCT(X)+FCT(Z))
  17106.     X=.52755509865158801D1
  17107.     Z=-X
  17108.     Y=Y+.42150102113264476D-12*(FCT(X)+FCT(Z))
  17109.     X=.47771645035025964D1
  17110.     Z=-X
  17111.     Y=Y+.59332914633966386D-10*(FCT(X)+FCT(Z))
  17112.     X=.43055479533511984D1
  17113.     Z=-X
  17114.     Y=Y+.40988321647708966D-8*(FCT(X)+FCT(Z))
  17115.     X=.38537554854714446D1
  17116.     Z=-X
  17117.     Y=Y+.15741677925455940D-6*(FCT(X)+FCT(Z))
  17118.     X=.34171674928185707D1
  17119.     Z=-X
  17120.     Y=Y+.36505851295623761D-5*(FCT(X)+FCT(Z))
  17121.     X=.29924908250023742D1
  17122.     Z=-X
  17123.     Y=Y+.54165840618199826D-4*(FCT(X)+FCT(Z))
  17124.     X=.25772495377323175D1
  17125.     Z=-X
  17126.     Y=Y+.53626836552797205D-3*(FCT(X)+FCT(Z))
  17127.     X=.21694991836061122D1
  17128.     Z=-X
  17129.     Y=Y+.36548903266544281D-2*(FCT(X)+FCT(Z))
  17130.     X=.17676541094632016D1
  17131.     Z=-X
  17132.     Y=Y+.17553428831573430D-1*(FCT(X)+FCT(Z))
  17133.     X=.13703764109528718D1
  17134.     Z=-X
  17135.     Y=Y+.60458130955912614D-1*(FCT(X)+FCT(Z))
  17136.     X=.9765004635896828D0
  17137.     Z=-X
  17138.     Y=Y+.15126973407664248D0*(FCT(X)+FCT(Z))
  17139.     X=.58497876543593245D0
  17140.     Z=-X
  17141.     Y=Y+.27745814230252990D0*(FCT(X)+FCT(Z))
  17142.     X=.19484074156939933D0
  17143.     Z=-X
  17144.     Y=Y+.37523835259280239D0*(FCT(X)+FCT(Z))
  17145.     RETURN
  17146.     END
  17147. C
  17148. C    ..................................................................
  17149. C
  17150. C       SUBROUTINE DQH48
  17151. C
  17152. C       PURPOSE
  17153. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  17154. C                              -INFINITY TO +INFINITY).
  17155. C
  17156. C       USAGE
  17157. C          CALL DQH48 (FCT,Y)
  17158. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17159. C
  17160. C       DESCRIPTION OF PARAMETERS
  17161. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17162. C                   SUBPROGRAM USED.
  17163. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17164. C
  17165. C       REMARKS
  17166. C          NONE
  17167. C
  17168. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17169. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17170. C          MUST BE FURNISHED BY THE USER.
  17171. C
  17172. C       METHOD
  17173. C          EVALUATION IS DONE BY MEANS OF 48-POINT GAUSSIAN-HERMITE
  17174. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  17175. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 95.
  17176. C          FOR REFERENCE, SEE
  17177. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17178. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17179. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17180. C          TR00.1100 (MARCH 1964), PP.213-214.
  17181. C
  17182. C    ..................................................................
  17183. C
  17184.     SUBROUTINE DQH48(FCT,Y)
  17185. C
  17186. C
  17187.     DOUBLE PRECISION X,Y,Z,FCT
  17188. C
  17189.     X=.8975315081931687D1
  17190.     Z=-X
  17191.     Y=.7935551460773997D-35*(FCT(X)+FCT(Z))
  17192.     X=.8310752190704784D1
  17193.     Z=-X
  17194.     Y=Y+.59846126933138784D-30*(FCT(X)+FCT(Z))
  17195.     X=.7759295519765775D1
  17196.     Z=-X
  17197.     Y=Y+.36850360801506699D-26*(FCT(X)+FCT(Z))
  17198.     X=.7266046554164350D1
  17199.     Z=-X
  17200.     Y=Y+.55645774689022848D-23*(FCT(X)+FCT(Z))
  17201.     X=.68100645780741414D1
  17202.     Z=-X
  17203.     Y=Y+.31883873235051384D-20*(FCT(X)+FCT(Z))
  17204.     X=.63805640961864106D1
  17205.     Z=-X
  17206.     Y=Y+.8730159601186677D-18*(FCT(X)+FCT(Z))
  17207.     X=.59710722250135454D1
  17208.     Z=-X
  17209.     Y=Y+.13151596226584085D-15*(FCT(X)+FCT(Z))
  17210.     X=.55773169812237286D1
  17211.     Z=-X
  17212.     Y=Y+.11975898654791794D-13*(FCT(X)+FCT(Z))
  17213.     X=.51962877187923645D1
  17214.     Z=-X
  17215.     Y=Y+.70469325815458891D-12*(FCT(X)+FCT(Z))
  17216.     X=.48257572281332095D1
  17217.     Z=-X
  17218.     Y=Y+.28152965378381691D-10*(FCT(X)+FCT(Z))
  17219.     X=.44640145469344589D1
  17220.     Z=-X
  17221.     Y=Y+.7930467495165382D-9*(FCT(X)+FCT(Z))
  17222.     X=.41097046035605902D1
  17223.     Z=-X
  17224.     Y=Y+.16225141358957698D-7*(FCT(X)+FCT(Z))
  17225.     X=.37617264902283578D1
  17226.     Z=-X
  17227.     Y=Y+.24686589936697505D-6*(FCT(X)+FCT(Z))
  17228.     X=.34191659693638846D1
  17229.     Z=-X
  17230.     Y=Y+.28472586917348481D-5*(FCT(X)+FCT(Z))
  17231.     X=.30812489886451058D1
  17232.     Z=-X
  17233.     Y=Y+.25285990277484889D-4*(FCT(X)+FCT(Z))
  17234.     X=.27473086248223832D1
  17235.     Z=-X
  17236.     Y=Y+.17515043180117283D-3*(FCT(X)+FCT(Z))
  17237.     X=.24167609048732165D1
  17238.     Z=-X
  17239.     Y=Y+.9563923198194153D-3*(FCT(X)+FCT(Z))
  17240.     X=.20890866609442764D1
  17241.     Z=-X
  17242.     Y=Y+.41530049119775525D-2*(FCT(X)+FCT(Z))
  17243.     X=.17638175798953000D1
  17244.     Z=-X
  17245.     Y=Y+.14444961574981099D-1*(FCT(X)+FCT(Z))
  17246.     X=.14405252201375652D1
  17247.     Z=-X
  17248.     Y=Y+.40479676984603849D-1*(FCT(X)+FCT(Z))
  17249.     X=.11188121524021566D1
  17250.     Z=-X
  17251.     Y=Y+.9182229707928518D-1*(FCT(X)+FCT(Z))
  17252.     X=.7983046277785622D0
  17253.     Z=-X
  17254.     Y=Y+.16920447194564111D0*(FCT(X)+FCT(Z))
  17255.     X=.47864633759449610D0
  17256.     Z=-X
  17257.     Y=Y+.25396154266475910D0*(FCT(X)+FCT(Z))
  17258.     X=.15949293584886247D0
  17259.     Z=-X
  17260.     Y=Y+.31100103037796308D0*(FCT(X)+FCT(Z))
  17261.     RETURN
  17262.     END
  17263. C
  17264. C    ..................................................................
  17265. C
  17266. C       SUBROUTINE DQH64
  17267. C
  17268. C       PURPOSE
  17269. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  17270. C                              -INFINITY TO +INFINITY).
  17271. C
  17272. C       USAGE
  17273. C          CALL DQH64 (FCT,Y)
  17274. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17275. C
  17276. C       DESCRIPTION OF PARAMETERS
  17277. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17278. C                   SUBPROGRAM USED.
  17279. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17280. C
  17281. C       REMARKS
  17282. C          NONE
  17283. C
  17284. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17285. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17286. C          MUST BE FURNISHED BY THE USER.
  17287. C
  17288. C       METHOD
  17289. C          EVALUATION IS DONE BY MEANS OF 64-POINT GAUSSIAN-HERMITE
  17290. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  17291. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 127.
  17292. C          FOR REFERENCE, SEE
  17293. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17294. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17295. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17296. C          TR00.1100 (MARCH 1964), PP.213-214.
  17297. C
  17298. C    ..................................................................
  17299. C
  17300.     SUBROUTINE DQH64(FCT,Y)
  17301. C
  17302. C
  17303.     DOUBLE PRECISION X,Y,Z,FCT
  17304. C
  17305.     X=.10526123167960546D2
  17306.     Z=-X
  17307.     Y=.55357065358569428D-28*(FCT(X)+FCT(Z))
  17308.     X=.9895287586829539D1
  17309.     Z=-X
  17310.     Y=Y+.16797479901081592D-22*(FCT(X)+FCT(Z))
  17311.     X=.9373159549646721D21
  17312.     Z=-X
  17313.     Y=Y+.34211380112557405D-18*(FCT(X)+FCT(Z))
  17314.     X=.8907249099964770D1
  17315.     Z=-X
  17316.     Y=Y+.15573906246297638D-14*(FCT(X)+FCT(Z))
  17317.     X=.8477529083379863D1
  17318.     Z=-X
  17319.     Y=Y+.25496608991129993D-11*(FCT(X)+FCT(Z))
  17320.     X=.8073687285010225D1
  17321.     Z=-X
  17322.     Y=Y+.19291035954649669D-8*(FCT(X)+FCT(Z))
  17323.     X=.7689540164040497D1
  17324.     Z=-X
  17325.     Y=Y+.7861797788925910D-6*(FCT(X)+FCT(Z))
  17326.     X=.7321013032780949D1
  17327.     Z=-X
  17328.     Y=Y+.19117068833006428D-3*(FCT(X)+FCT(Z))
  17329.     X=.69652411205511075D1
  17330.     Z=-X
  17331.     Y=Y+.29828627842798512D-1*(FCT(X)+FCT(Z))
  17332.     X=.66201122626360274D1
  17333.     Z=-X
  17334.     Y=Y+.31522545665037814D1*(FCT(X)+FCT(Z))
  17335.     X=.62840112287748282D1
  17336.     Z=-X
  17337.     Y=Y+.23518847106758191D3*(FCT(X)+FCT(Z))
  17338.     X=.59556663267994860D1
  17339.     Z=-X
  17340.     Y=Y+.12800933913224380D5*(FCT(X)+FCT(Z))
  17341.     X=.56340521643499721D1
  17342.     Z=-X
  17343.     Y=Y+.52186237265908475D6*(FCT(X)+FCT(Z))
  17344.     X=.53183252246332709D1
  17345.     Z=-X
  17346.     Y=Y+.16283407307097204D8*(FCT(X)+FCT(Z))
  17347.     X=.50077796021987682D1
  17348.     Z=-X
  17349.     Y=Y+.39591777669477239D9*(FCT(X)+FCT(Z))
  17350.     X=.47018156474074998D1
  17351.     Z=-X
  17352.     Y=Y+.7615217250145451D10*(FCT(X)+FCT(Z))
  17353.     X=.43999171682281376D1
  17354.     Z=-X
  17355.     Y=Y+.11736167423215493D12*(FCT(X)+FCT(Z))
  17356.     X=.41016344745666567D1
  17357.     Z=-X
  17358.     Y=Y+.14651253164761094D13*(FCT(X)+FCT(Z))
  17359.     X=.38065715139453605D1
  17360.     Z=-X
  17361.     Y=Y+.14955329367272471D14*(FCT(X)+FCT(Z))
  17362.     X=.35143759357409062D1
  17363.     Z=-X
  17364.     Y=Y+.12583402510311846D15*(FCT(X)+FCT(Z))
  17365.     X=.32247312919920357D1
  17366.     Z=-X
  17367.     Y=Y+.8788499230850359D15*(FCT(X)+FCT(Z))
  17368.     X=.29373508230046218D1
  17369.     Z=-X
  17370.     Y=Y+.51259291357862747D16*(FCT(X)+FCT(Z))
  17371.     X=.26519724354306350D1
  17372.     Z=-X
  17373.     Y=Y+.25098369851306249D17*(FCT(X)+FCT(Z))
  17374.     X=.23683545886324014D1
  17375.     Z=-X
  17376.     Y=Y+.10363290995075777D18*(FCT(X)+FCT(Z))
  17377.     X=.20862728798817620D1
  17378.     Z=-X
  17379.     Y=Y+.36225869785344588D18*(FCT(X)+FCT(Z))
  17380.     X=.18055171714655449D1
  17381.     Z=-X
  17382.     Y=Y+.10756040509879137D19*(FCT(X)+FCT(Z))
  17383.     X=.15258891402098637D1
  17384.     Z=-X
  17385.     Y=Y+.27203128953688918D19*(FCT(X)+FCT(Z))
  17386.     X=.12472001569431179D1
  17387.     Z=-X
  17388.     Y=Y+.58739981964099435D19*(FCT(X)+FCT(Z))
  17389.     X=.9692694230711780D0
  17390.     Z=-X
  17391.     Y=Y+.10849834930618684D20*(FCT(X)+FCT(Z))
  17392.     X=.69192230581004458D0
  17393.     Z=-X
  17394.     Y=Y+.17168584234908370D20*(FCT(X)+FCT(Z))
  17395.     X=.41498882412107868D0
  17396.     Z=-X
  17397.     Y=Y+.23299478606267805D20*(FCT(X)+FCT(Z))
  17398.     X=.13830224498700972D0
  17399.     Z=-X
  17400.     Y=Y+.27137742494130398D20*(FCT(X)+FCT(Z))
  17401.     Y=Y*1.D-20
  17402.     RETURN
  17403.     END
  17404. C
  17405. C    ..................................................................
  17406. C
  17407. C       SUBROUTINE DQH8
  17408. C
  17409. C       PURPOSE
  17410. C          TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
  17411. C                              -INFINITY TO +INFINITY).
  17412. C
  17413. C       USAGE
  17414. C          CALL DQH8 (FCT,Y)
  17415. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17416. C
  17417. C       DESCRIPTION OF PARAMETERS
  17418. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17419. C                   SUBPROGRAM USED.
  17420. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17421. C
  17422. C       REMARKS
  17423. C          NONE
  17424. C
  17425. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17426. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17427. C          MUST BE FURNISHED BY THE USER.
  17428. C
  17429. C       METHOD
  17430. C          EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-HERMITE
  17431. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
  17432. C          FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
  17433. C          FOR REFERENCE, SEE
  17434. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17435. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17436. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17437. C          TR00.1100 (MARCH 1964), PP.213-214.
  17438. C
  17439. C    ..................................................................
  17440. C
  17441.     SUBROUTINE DQH8(FCT,Y)
  17442. C
  17443. C
  17444.     DOUBLE PRECISION X,Y,Z,FCT
  17445. C
  17446.     X=.29306374202572440D1
  17447.     Z=-X
  17448.     Y=.19960407221136762D-3*(FCT(X)+FCT(Z))
  17449.     X=.19816567566958429D1
  17450.     Z=-X
  17451.     Y=Y+.17077983007413475D-1*(FCT(X)+FCT(Z))
  17452.     X=.11571937124467802D1
  17453.     Z=-X
  17454.     Y=Y+.20780232581489188D0*(FCT(X)+FCT(Z))
  17455.     X=.38118699020732212D0
  17456.     Z=-X
  17457.     Y=Y+.66114701255824129D0*(FCT(X)+FCT(Z))
  17458.     RETURN
  17459.     END
  17460. C
  17461. C    ..................................................................
  17462. C
  17463. C       SUBROUTINE DQHFE
  17464. C
  17465. C       PURPOSE
  17466. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  17467. C          EQUIDISTANT TABLE OF FUNCTION AND DERIVATIVE VALUES.
  17468. C
  17469. C       USAGE
  17470. C          CALL DQHFE (H,Y,DERY,Z,NDIM)
  17471. C
  17472. C       DESCRIPTION OF PARAMETERS
  17473. C          H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
  17474. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  17475. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES.
  17476. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  17477. C                   VALUES. Z MAY BE IDENTICAL WITH Y OR DERY.
  17478. C          NDIM   - THE DIMENSION OF VECTORS Y,DERY,Z.
  17479. C
  17480. C       REMARKS
  17481. C          NO ACTION IN CASE NDIM LESS THAN 1.
  17482. C
  17483. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17484. C          NONE
  17485. C
  17486. C       METHOD
  17487. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  17488. C          MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
  17489. C          FOR REFERENCE, SEE
  17490. C          (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  17491. C              MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
  17492. C          (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  17493. C              PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  17494. C              PP.227-230.
  17495. C
  17496. C    ..................................................................
  17497. C
  17498.     SUBROUTINE DQHFE(H,Y,DERY,Z,NDIM)
  17499. C
  17500. C
  17501.     DIMENSION Y(1),DERY(1),Z(1)
  17502.     DOUBLE PRECISION Y,DERY,Z,H,HH,HS,SUM1,SUM2
  17503. C
  17504.     SUM2=0.D0
  17505.     IF(NDIM-1)4,3,1
  17506. 1    HH=.5D0*H
  17507.     HS=.16666666666666667D0*H
  17508. C
  17509. C    INTEGRATION LOOP
  17510.     DO 2 I=2,NDIM
  17511.     SUM1=SUM2
  17512.     SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I)))
  17513. 2    Z(I-1)=SUM1
  17514. 3    Z(NDIM)=SUM2
  17515. 4    RETURN
  17516.     END
  17517. C
  17518. C    ..................................................................
  17519. C
  17520. C       SUBROUTINE DQHFG
  17521. C
  17522. C       PURPOSE
  17523. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  17524. C          GENERAL TABLE OF ARGUMENT, FUNCTION, AND DERIVATIVE VALUES.
  17525. C
  17526. C       USAGE
  17527. C          CALL DQHFG (X,Y,DERY,Z,NDIM)
  17528. C
  17529. C       DESCRIPTION OF PARAMETERS
  17530. C          X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
  17531. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  17532. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES.
  17533. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  17534. C                   VALUES. Z MAY BE IDENTICAL WITH X, Y OR DERY.
  17535. C          NDIM   - THE DIMENSION OF VECTORS X,Y,DERY,Z.
  17536. C
  17537. C       REMARKS
  17538. C          NO ACTION IN CASE NDIM LESS THAN 1.
  17539. C
  17540. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17541. C          NONE
  17542. C
  17543. C       METHOD
  17544. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  17545. C          MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
  17546. C          FOR REFERENCE, SEE
  17547. C          (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  17548. C              MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
  17549. C          (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  17550. C              PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  17551. C              PP.227-230.
  17552. C
  17553. C    ..................................................................
  17554. C
  17555.     SUBROUTINE DQHFG(X,Y,DERY,Z,NDIM)
  17556. C
  17557. C
  17558.     DIMENSION X(1),Y(1),DERY(1),Z(1)
  17559.     DOUBLE PRECISION X,Y,DERY,Z,SUM1,SUM2
  17560. C
  17561.     SUM2=0.D0
  17562.     IF(NDIM-1)4,3,1
  17563. C
  17564. C    INTEGRATION LOOP
  17565. 1    DO 2 I=2,NDIM
  17566.     SUM1=SUM2
  17567.     SUM2=.5D0*(X(I)-X(I-1))
  17568.     SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.33333333333333333D0*SUM2*
  17569.      1(DERY(I-1)-DERY(I)))
  17570. 2    Z(I-1)=SUM1
  17571. 3    Z(NDIM)=SUM2
  17572. 4    RETURN
  17573.     END
  17574. C
  17575. C    ..................................................................
  17576. C
  17577. C       SUBROUTINE DQHSE
  17578. C
  17579. C       PURPOSE
  17580. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  17581. C          EQUIDISTANT TABLE OF FUNCTION, FIRST DERIVATIVE,
  17582. C          AND SECOND DERIVATIVE VALUES.
  17583. C
  17584. C       USAGE
  17585. C          CALL DQHSE (H,Y,FDY,SDY,Z,NDIM)
  17586. C
  17587. C       DESCRIPTION OF PARAMETERS
  17588. C          H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
  17589. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  17590. C          FDY    - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE.
  17591. C          SDY    - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE.
  17592. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  17593. C                   VALUES. Z MAY BE IDENTICAL WITH Y, FDY OR SDY.
  17594. C          NDIM   - THE DIMENSION OF VECTORS Y,FDY,SDY,Z.
  17595. C
  17596. C       REMARKS
  17597. C          NO ACTION IN CASE NDIM LESS THAN 1.
  17598. C
  17599. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17600. C          NONE
  17601. C
  17602. C       METHOD
  17603. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  17604. C          MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
  17605. C          FOR REFERENCE, SEE
  17606. C          R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  17607. C          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  17608. C          PP.227-230.
  17609. C
  17610. C    ..................................................................
  17611. C
  17612.     SUBROUTINE DQHSE(H,Y,FDY,SDY,Z,NDIM)
  17613. C
  17614. C
  17615.     DIMENSION Y(1),FDY(1),SDY(1),Z(1)
  17616.     DOUBLE PRECISION Y,FDY,SDY,Z,H,HH,HF,HT,SUM1,SUM2
  17617. C
  17618.     SUM2=0.D0
  17619.     IF(NDIM-1)4,3,1
  17620. 1    HH=.5D0*H
  17621.     HF=.2D0*H
  17622.     HT=.08333333333333333D0*H
  17623. C
  17624. C    INTEGRATION LOOP
  17625.     DO 2 I=2,NDIM
  17626.     SUM1=SUM2
  17627.     SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+
  17628.      1              HT*(SDY(I-1)+SDY(I))))
  17629. 2    Z(I-1)=SUM1
  17630. 3    Z(NDIM)=SUM2
  17631. 4    RETURN
  17632.     END
  17633. C
  17634. C    ..................................................................
  17635. C
  17636. C       SUBROUTINE DQHSG
  17637. C
  17638. C       PURPOSE
  17639. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  17640. C          GENERAL TABLE OF ARGUMENT, FUNCTION, FIRST DERIVATIVE,
  17641. C          AND SECOND DERIVATIVE VALUES.
  17642. C
  17643. C       USAGE
  17644. C          CALL DQHSG (X,Y,FDY,SDY,Z,NDIM)
  17645. C
  17646. C       DESCRIPTION OF PARAMETERS
  17647. C          X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
  17648. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  17649. C          FDY    - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE.
  17650. C          SDY    - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE.
  17651. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  17652. C                   VALUES. Z MAY BE IDENTICAL WITH X, Y, FDY OR SDY.
  17653. C          NDIM   - THE DIMENSION OF VECTORS X,Y,FDY,SDY,Z.
  17654. C
  17655. C       REMARKS
  17656. C          NO ACTION IN CASE NDIM LESS THAN 1.
  17657. C
  17658. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17659. C          NONE
  17660. C
  17661. C       METHOD
  17662. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  17663. C          MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
  17664. C          FOR REFERENCE, SEE
  17665. C          R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  17666. C          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  17667. C          PP.227-230.
  17668. C
  17669. C    ..................................................................
  17670. C
  17671.     SUBROUTINE DQHSG(X,Y,FDY,SDY,Z,NDIM)
  17672. C
  17673. C
  17674.     DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1)
  17675.     DOUBLE PRECISION X,Y,FDY,SDY,Z,SUM1,SUM2
  17676. C
  17677.     SUM2=0.D0
  17678.     IF(NDIM-1)4,3,1
  17679. C
  17680. C    INTEGRATION LOOP
  17681. 1    DO 2 I=2,NDIM
  17682.     SUM1=SUM2
  17683.     SUM2=.5D0*(X(I)-X(I-1))
  17684.     SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4D0*SUM2*((FDY(I-1)-FDY(I))+
  17685.      1     .16666666666666667D0*SUM2*(SDY(I-1)+SDY(I))))
  17686. 2    Z(I-1)=SUM1
  17687. 3    Z(NDIM)=SUM2
  17688. 4    RETURN
  17689.     END
  17690. C
  17691. C    ..................................................................
  17692. C
  17693. C       SUBROUTINE DQL12
  17694. C
  17695. C       PURPOSE
  17696. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  17697. C                              FROM 0 TO INFINITY).
  17698. C
  17699. C       USAGE
  17700. C          CALL DQL12 (FCT,Y)
  17701. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17702. C
  17703. C       DESCRIPTION OF PARAMETERS
  17704. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17705. C                   SUBPROGRAM USED.
  17706. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17707. C
  17708. C       REMARKS
  17709. C          NONE
  17710. C
  17711. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17712. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17713. C          MUST BE FURNISHED BY THE USER.
  17714. C
  17715. C       METHOD
  17716. C          EVALUATION IS DONE BY MEANS OF 12-POINT GAUSSIAN-LAGUERRE
  17717. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  17718. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23.
  17719. C          FOR REFERENCE, SEE
  17720. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17721. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17722. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17723. C          TR00.1100 (MARCH 1964), PP.24-25.
  17724. C
  17725. C    ..................................................................
  17726. C
  17727.     SUBROUTINE DQL12(FCT,Y)
  17728. C
  17729. C
  17730.     DOUBLE PRECISION X,Y,FCT
  17731. C
  17732.     X=.37099121044466920D2
  17733.     Y=.8148077467426242D-15*FCT(X)
  17734.     X=.28487967250984000D2
  17735.     Y=Y+.30616016350350208D-11*FCT(X)
  17736.     X=.22151090379397006D2
  17737.     Y=Y+.13423910305150041D-8*FCT(X)
  17738.     X=.17116855187462256D2
  17739.     Y=Y+.16684938765409103D-6*FCT(X)
  17740.     X=.13006054993306348D2
  17741.     Y=Y+.8365055856819799D-5*FCT(X)
  17742.     X=.9621316842456867D1
  17743.     Y=Y+.20323159266299939D-3*FCT(X)
  17744.     X=.68445254531151773D1
  17745.     Y=Y+.26639735418653159D-2*FCT(X)
  17746.     X=.45992276394183485D1
  17747.     Y=Y+.20102381154634097D-1*FCT(X)
  17748.     X=.28337513377435072D1
  17749.     Y=Y+.9044922221168093D-1*FCT(X)
  17750.     X=.15126102697764188D1
  17751.     Y=Y+.24408201131987756D0*FCT(X)
  17752.     X=.61175748451513067D0
  17753.     Y=Y+.37775927587313798D0*FCT(X)
  17754.     X=.11572211735802068D0
  17755.     Y=Y+.26473137105544319D0*FCT(X)
  17756.     RETURN
  17757.     END
  17758. C
  17759. C    ..................................................................
  17760. C
  17761. C       SUBROUTINE DQL16
  17762. C
  17763. C       PURPOSE
  17764. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  17765. C                              FROM 0 TO INFINITY).
  17766. C
  17767. C       USAGE
  17768. C          CALL DQL16 (FCT,Y)
  17769. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17770. C
  17771. C       DESCRIPTION OF PARAMETERS
  17772. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17773. C                   SUBPROGRAM USED.
  17774. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17775. C
  17776. C       REMARKS
  17777. C          NONE
  17778. C
  17779. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17780. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17781. C          MUST BE FURNISHED BY THE USER.
  17782. C
  17783. C       METHOD
  17784. C          EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-LAGUERRE
  17785. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  17786. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
  17787. C          FOR REFERENCE, SEE
  17788. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17789. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17790. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17791. C          TR00.1100 (MARCH 1964), PP.24-25.
  17792. C
  17793. C    ..................................................................
  17794. C
  17795.     SUBROUTINE DQL16(FCT,Y)
  17796. C
  17797. C
  17798.     DOUBLE PRECISION X,Y,FCT
  17799. C
  17800.     X=.51701160339543318D2
  17801.     Y=.41614623703728552D-21*FCT(X)
  17802.     X=.41940452647688333D2
  17803.     Y=Y+.50504737000355128D-17*FCT(X)
  17804.     X=.34583398702286626D2
  17805.     Y=Y+.62979670025178678D-14*FCT(X)
  17806.     X=.28578729742882140D2
  17807.     Y=Y+.21270790332241030D-11*FCT(X)
  17808.     X=.23515905693991909D2
  17809.     Y=Y+.28623502429738816D-9*FCT(X)
  17810.     X=.19180156856753135D2
  17811.     Y=Y+.18810248410796732D-7*FCT(X)
  17812.     X=.15441527368781617D2
  17813.     Y=Y+.68283193308711996D-6*FCT(X)
  17814.     X=.12214223368866159D2
  17815.     Y=Y+.14844586873981299D-4*FCT(X)
  17816.     X=.9438314336391939D1
  17817.     Y=Y+.20427191530827846D-3*FCT(X)
  17818.     X=.70703385350482341D1
  17819.     Y=Y+.18490709435263109D-2*FCT(X)
  17820.     X=.50780186145497679D1
  17821.     Y=Y+.11299900080339453D-1*FCT(X)
  17822.     X=.34370866338932066D1
  17823.     Y=Y+.47328928694125219D-1*FCT(X)
  17824.     X=.21292836450983806D1
  17825.     Y=Y+.13629693429637754D0*FCT(X)
  17826.     X=.11410577748312269D1
  17827.     Y=Y+.26579577764421415D0*FCT(X)
  17828.     X=.46269632891508083D0
  17829.     Y=Y+.33105785495088417D0*FCT(X)
  17830.     X=.8764941047892784D-1
  17831.     Y=Y+.20615171495780099D0*FCT(X)
  17832.     RETURN
  17833.     END
  17834. C
  17835. C    ..................................................................
  17836. C
  17837. C       SUBROUTINE DQL24
  17838. C
  17839. C       PURPOSE
  17840. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  17841. C                              FROM 0 TO INFINITY).
  17842. C
  17843. C       USAGE
  17844. C          CALL DQL24 (FCT,Y)
  17845. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17846. C
  17847. C       DESCRIPTION OF PARAMETERS
  17848. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17849. C                   SUBPROGRAM USED.
  17850. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17851. C
  17852. C       REMARKS
  17853. C          NONE
  17854. C
  17855. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17856. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17857. C          MUST BE FURNISHED BY THE USER.
  17858. C
  17859. C       METHOD
  17860. C          EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-LAGUERRE
  17861. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  17862. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
  17863. C          FOR REFERENCE, SEE
  17864. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17865. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17866. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17867. C          TR00.1100 (MARCH 1964), PP.24-25.
  17868. C
  17869. C    ..................................................................
  17870. C
  17871.     SUBROUTINE DQL24(FCT,Y)
  17872. C
  17873. C
  17874.     DOUBLE PRECISION X,Y,FCT
  17875. C
  17876.     X=.8149827923394889D2
  17877.     Y=.55753457883283568D-34*FCT(X)
  17878.     X=.69962240035105030D2
  17879.     Y=Y+.40883015936806578D-29*FCT(X)
  17880.     X=.61058531447218762D2
  17881.     Y=Y+.24518188458784027D-25*FCT(X)
  17882.     X=.53608574544695070D2
  17883.     Y=Y+.36057658645529590D-22*FCT(X)
  17884.     X=.47153106445156323D2
  17885.     Y=Y+.20105174645555035D-19*FCT(X)
  17886.     X=.41451720484870767D2
  17887.     Y=Y+.53501888130100376D-17*FCT(X)
  17888.     X=.36358405801651622D2
  17889.     Y=Y+.7819800382459448D-15*FCT(X)
  17890.     X=.31776041352374723D2
  17891.     Y=Y+.68941810529580857D-13*FCT(X)
  17892.     X=.27635937174332717D2
  17893.     Y=Y+.39177365150584514D-11*FCT(X)
  17894.     X=.23887329848169733D2
  17895.     Y=Y+.15070082262925849D-9*FCT(X)
  17896.     X=.20491460082616425D2
  17897.     Y=Y+.40728589875499997D-8*FCT(X)
  17898.     X=.17417992646508979D2
  17899.     Y=Y+.7960812959133630D-7*FCT(X)
  17900.     X=.14642732289596674D2
  17901.     Y=Y+.11513158127372799D-5*FCT(X)
  17902.     X=.12146102711729766D2
  17903.     Y=Y+.12544721977993333D-4*FCT(X)
  17904.     X=.9912098015077706D1
  17905.     Y=Y+.10446121465927518D-3*FCT(X)
  17906.     X=.7927539247172152D1
  17907.     Y=Y+.67216256409354789D-3*FCT(X)
  17908.     X=.61815351187367654D1
  17909.     Y=Y+.33693490584783036D-2*FCT(X)
  17910.     X=.46650837034671708D1
  17911.     Y=Y+.13226019405120157D-1*FCT(X)
  17912.     X=.33707742642089977D1
  17913.     Y=Y+.40732478151408646D-1*FCT(X)
  17914.     X=.22925620586321903D1
  17915.     Y=Y+.9816627262991889D-1*FCT(X)
  17916.     X=.14255975908036131D1
  17917.     Y=Y+.18332268897777802D0*FCT(X)
  17918.     X=.7660969055459366D0
  17919.     Y=Y+.25880670727286980D0*FCT(X)
  17920.     X=.31123914619848373D0
  17921.     Y=Y+.25877410751742390D0*FCT(X)
  17922.     X=.59019852181507977D-1
  17923.     Y=Y+.14281197333478185D0*FCT(X)
  17924.     RETURN
  17925.     END
  17926. C
  17927. C    ..................................................................
  17928. C
  17929. C       SUBROUTINE DQL32
  17930. C
  17931. C       PURPOSE
  17932. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  17933. C                              FROM 0 TO INFINITY).
  17934. C
  17935. C       USAGE
  17936. C          CALL DQL32 (FCT,Y)
  17937. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  17938. C
  17939. C       DESCRIPTION OF PARAMETERS
  17940. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  17941. C                   SUBPROGRAM USED.
  17942. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  17943. C
  17944. C       REMARKS
  17945. C          NONE
  17946. C
  17947. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  17948. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  17949. C          MUST BE FURNISHED BY THE USER.
  17950. C
  17951. C       METHOD
  17952. C          EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-LAGUERRE
  17953. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  17954. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
  17955. C          FOR REFERENCE, SEE
  17956. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  17957. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  17958. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  17959. C          TR00.1100 (MARCH 1964), PP.24-25.
  17960. C
  17961. C    ..................................................................
  17962. C
  17963.     SUBROUTINE DQL32(FCT,Y)
  17964. C
  17965. C
  17966.     DOUBLE PRECISION X,Y,FCT
  17967. C
  17968.     X=.11175139809793770D3
  17969.     Y=.45105361938989742D-27*FCT(X)
  17970.     X=.9882954286828397D2
  17971.     Y=Y+.13386169421062563D-21*FCT(X)
  17972.     X=.8873534041789240D2
  17973.     Y=Y+.26715112192401370D-17*FCT(X)
  17974.     X=.8018744697791352D2
  17975.     Y=Y+.11922487600982224D-13*FCT(X)
  17976.     X=.7268762809066271D2
  17977.     Y=Y+.19133754944542243D-10*FCT(X)
  17978.     X=.65975377287935053D2
  17979.     Y=Y+.14185605454630369D-7*FCT(X)
  17980.     X=.59892509162134018D2
  17981.     Y=Y+.56612941303973594D-5*FCT(X)
  17982.     X=.54333721333396907D2
  17983.     Y=Y+.13469825866373952D-2*FCT(X)
  17984.     X=.49224394987308639D2
  17985.     Y=Y+.20544296737880454D0*FCT(X)
  17986.     X=.44509207995754938D2
  17987.     Y=Y+.21197922901636186D2*FCT(X)
  17988.     X=.40145719771539442D2
  17989.     Y=Y+.15421338333938234D4*FCT(X)
  17990.     X=.36100494805751974D2
  17991.     Y=Y+.8171823443420719D5*FCT(X)
  17992.     X=.32346629153964737D2
  17993.     Y=Y+.32378016577292665D7*FCT(X)
  17994.     X=.28862101816323475D2
  17995.     Y=Y+.9799379288727094D8*FCT(X)
  17996.     X=.25628636022459248D2
  17997.     Y=Y+.23058994918913361D10*FCT(X)
  17998.     X=.22630889013196774D2
  17999.     Y=Y+.42813829710409289D11*FCT(X)
  18000.     X=.19855860940336055D2
  18001.     Y=Y+.63506022266258067D12*FCT(X)
  18002.     X=.17292454336715315D2
  18003.     Y=Y+.7604567879120781D13*FCT(X)
  18004.     X=.14931139755522557D2
  18005.     Y=Y+.7416404578667552D14*FCT(X)
  18006.     X=.12763697986742725D2
  18007.     Y=Y+.59345416128686329D15*FCT(X)
  18008.     X=.10783018632539972D2
  18009.     Y=Y+.39203419679879472D16*FCT(X)
  18010.     X=.8982940924212596D1
  18011.     Y=Y+.21486491880136419D17*FCT(X)
  18012.     X=.7358126733186241D1
  18013.     Y=Y+.9808033066149551D17*FCT(X)
  18014.     X=.59039585041742439D1
  18015.     Y=Y+.37388162946115248D18*FCT(X)
  18016.     X=.46164567697497674D1
  18017.     Y=Y+.11918214834838557D19*FCT(X)
  18018.     X=.34922132730219945D1
  18019.     Y=Y+.31760912509175070D19*FCT(X)
  18020.     X=.25283367064257949D1
  18021.     Y=Y+.70578623865717442D19*FCT(X)
  18022.     X=.17224087764446454D1
  18023.     Y=Y+.12998378628607176D20*FCT(X)
  18024.     X=.10724487538178176D1
  18025.     Y=Y+.19590333597288104D20*FCT(X)
  18026.     X=.57688462930188643D0
  18027.     Y=Y+.23521322966984801D20*FCT(X)
  18028.     X=.23452610951961854D0
  18029.     Y=Y+.21044310793881323D20*FCT(X)
  18030.     X=.44489365833267018D-1
  18031.     Y=Y+.10921834195238497D20*FCT(X)
  18032.     Y=Y*1.D-20
  18033.     RETURN
  18034.     END
  18035. C
  18036. C    ..................................................................
  18037. C
  18038. C       SUBROUTINE DQL4
  18039. C
  18040. C       PURPOSE
  18041. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  18042. C                              FROM 0 TO INFINITY).
  18043. C
  18044. C       USAGE
  18045. C          CALL DQL4 (FCT,Y)
  18046. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  18047. C
  18048. C       DESCRIPTION OF PARAMETERS
  18049. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  18050. C                   SUBPROGRAM USED.
  18051. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  18052. C
  18053. C       REMARKS
  18054. C          NONE
  18055. C
  18056. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18057. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  18058. C          MUST BE FURNISHED BY THE USER.
  18059. C
  18060. C       METHOD
  18061. C          EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-LAGUERRE
  18062. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  18063. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
  18064. C          FOR REFERENCE, SEE
  18065. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  18066. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  18067. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  18068. C          TR00.1100 (MARCH 1964), PP.24-25.
  18069. C
  18070. C    ..................................................................
  18071. C
  18072.     SUBROUTINE DQL4(FCT,Y)
  18073. C
  18074. C
  18075.     DOUBLE PRECISION X,Y,FCT
  18076. C
  18077.     X=.9395070912301133D1
  18078.     Y=.53929470556132745D-3*FCT(X)
  18079.     X=.45366202969211280D1
  18080.     Y=Y+.38887908515005384D-1*FCT(X)
  18081.     X=.17457611011583466D1
  18082.     Y=Y+.35741869243779969D0*FCT(X)
  18083.     X=.32254768961939231D0
  18084.     Y=Y+.60315410434163360D0*FCT(X)
  18085.     RETURN
  18086.     END
  18087. C
  18088. C    ..................................................................
  18089. C
  18090. C       SUBROUTINE DQL8
  18091. C
  18092. C       PURPOSE
  18093. C          TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
  18094. C                              FROM 0 TO INFINITY).
  18095. C
  18096. C       USAGE
  18097. C          CALL DQL8 (FCT,Y)
  18098. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
  18099. C
  18100. C       DESCRIPTION OF PARAMETERS
  18101. C          FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  18102. C                   SUBPROGRAM USED.
  18103. C          Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
  18104. C
  18105. C       REMARKS
  18106. C          NONE
  18107. C
  18108. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18109. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  18110. C          MUST BE FURNISHED BY THE USER.
  18111. C
  18112. C       METHOD
  18113. C          EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-LAGUERRE
  18114. C          QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
  18115. C          WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
  18116. C          FOR REFERENCE, SEE
  18117. C          SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
  18118. C          CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
  18119. C          GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
  18120. C          TR00.1100 (MARCH 1964), PP.24-25.
  18121. C
  18122. C    ..................................................................
  18123. C
  18124.     SUBROUTINE DQL8(FCT,Y)
  18125. C
  18126. C
  18127.     DOUBLE PRECISION X,Y,FCT
  18128. C
  18129.     X=.22863131736889264D2
  18130.     Y=.10480011748715104D-8*FCT(X)
  18131.     X=.15740678641278005D2
  18132.     Y=Y+.8485746716272532D-6*FCT(X)
  18133.     X=.10758516010180995D2
  18134.     Y=Y+.9076508773358213D-4*FCT(X)
  18135.     X=.70459054023934657D1
  18136.     Y=Y+.27945362352256725D-2*FCT(X)
  18137.     X=.42667001702876588D1
  18138.     Y=Y+.33343492261215652D-1*FCT(X)
  18139.     X=.22510866298661307D1
  18140.     Y=Y+.17579498663717181D0*FCT(X)
  18141.     X=.9037017767993799D0
  18142.     Y=Y+.41878678081434296D0*FCT(X)
  18143.     X=.17027963230510100D0
  18144.     Y=Y+.36918858934163753D0*FCT(X)
  18145.     RETURN
  18146.     END
  18147. C
  18148. C    ..................................................................
  18149. C
  18150. C       SUBROUTINE DQSF
  18151. C
  18152. C       PURPOSE
  18153. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  18154. C          EQUIDISTANT TABLE OF FUNCTION VALUES.
  18155. C
  18156. C       USAGE
  18157. C          CALL DQSF (H,Y,Z,NDIM)
  18158. C
  18159. C       DESCRIPTION OF PARAMETERS
  18160. C          H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
  18161. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  18162. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  18163. C                   VALUES. Z MAY BE IDENTICAL WITH Y.
  18164. C          NDIM   - THE DIMENSION OF VECTORS Y AND Z.
  18165. C
  18166. C       REMARKS
  18167. C          NO ACTION IN CASE NDIM LESS THAN 3.
  18168. C
  18169. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18170. C          NONE
  18171. C
  18172. C       METHOD
  18173. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  18174. C          MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A
  18175. C          COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF
  18176. C          ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3
  18177. C          TRUNCATION ERROR OF Z(2) IS OF ORDER H**4.
  18178. C          FOR REFERENCE, SEE
  18179. C          (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  18180. C              MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76.
  18181. C          (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
  18182. C              PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
  18183. C              PP.214-221.
  18184. C
  18185. C    ..................................................................
  18186. C
  18187.     SUBROUTINE DQSF(H,Y,Z,NDIM)
  18188. C
  18189. C
  18190.     DIMENSION Y(1),Z(1)
  18191.     DOUBLE PRECISION Y,Z,H,HT,SUM1,SUM2,AUX,AUX1,AUX2
  18192. C
  18193.     HT=.33333333333333333D0*H
  18194.     IF(NDIM-5)7,8,1
  18195. C
  18196. C    NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP
  18197. 1    SUM1=Y(2)+Y(2)
  18198.     SUM1=SUM1+SUM1
  18199.     SUM1=HT*(Y(1)+SUM1+Y(3))
  18200.     AUX1=Y(4)+Y(4)
  18201.     AUX1=AUX1+AUX1
  18202.     AUX1=SUM1+HT*(Y(3)+AUX1+Y(5))
  18203.     AUX2=HT*(Y(1)+3.875D0*(Y(2)+Y(5))+2.625D0*(Y(3)+Y(4))+Y(6))
  18204.     SUM2=Y(5)+Y(5)
  18205.     SUM2=SUM2+SUM2
  18206.     SUM2=AUX2-HT*(Y(4)+SUM2+Y(6))
  18207.     Z(1)=0.D0
  18208.     AUX=Y(3)+Y(3)
  18209.     AUX=AUX+AUX
  18210.     Z(2)=SUM2-HT*(Y(2)+AUX+Y(4))
  18211.     Z(3)=SUM1
  18212.     Z(4)=SUM2
  18213.     IF(NDIM-6)5,5,2
  18214. C
  18215. C    INTEGRATION LOOP
  18216. 2    DO 4 I=7,NDIM,2
  18217.     SUM1=AUX1
  18218.     SUM2=AUX2
  18219.     AUX1=Y(I-1)+Y(I-1)
  18220.     AUX1=AUX1+AUX1
  18221.     AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I))
  18222.     Z(I-2)=SUM1
  18223.     IF(I-NDIM)3,6,6
  18224. 3    AUX2=Y(I)+Y(I)
  18225.     AUX2=AUX2+AUX2
  18226.     AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1))
  18227. 4    Z(I-1)=SUM2
  18228. 5    Z(NDIM-1)=AUX1
  18229.     Z(NDIM)=AUX2
  18230.     RETURN
  18231. 6    Z(NDIM-1)=SUM2
  18232.     Z(NDIM)=AUX1
  18233.     RETURN
  18234. C    END OF INTEGRATION LOOP
  18235. C
  18236. 7    IF(NDIM-3)12,11,8
  18237. C
  18238. C    NDIM IS EQUAL TO 4 OR 5
  18239. 8    SUM2=1.125D0*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4))
  18240.     SUM1=Y(2)+Y(2)
  18241.     SUM1=SUM1+SUM1
  18242.     SUM1=HT*(Y(1)+SUM1+Y(3))
  18243.     Z(1)=0.D0
  18244.     AUX1=Y(3)+Y(3)
  18245.     AUX1=AUX1+AUX1
  18246.     Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4))
  18247.     IF(NDIM-5)10,9,9
  18248. 9    AUX1=Y(4)+Y(4)
  18249.     AUX1=AUX1+AUX1
  18250.     Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5))
  18251. 10    Z(3)=SUM1
  18252.     Z(4)=SUM2
  18253.     RETURN
  18254. C
  18255. C    NDIM IS EQUAL TO 3
  18256. 11    SUM1=HT*(1.25D0*Y(1)+Y(2)+Y(2)-.25D0*Y(3))
  18257.     SUM2=Y(2)+Y(2)
  18258.     SUM2=SUM2+SUM2
  18259.     Z(3)=HT*(Y(1)+SUM2+Y(3))
  18260.     Z(1)=0.D0
  18261.     Z(2)=SUM1
  18262. 12    RETURN
  18263.     END
  18264. C
  18265. C    ..................................................................
  18266. C
  18267. C       SUBROUTINE DQTFE
  18268. C
  18269. C       PURPOSE
  18270. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  18271. C          EQUIDISTANT TABLE OF FUNCTION VALUES.
  18272. C
  18273. C       USAGE
  18274. C          CALL DQTFE (H,Y,Z,NDIM)
  18275. C
  18276. C       DESCRIPTION OF PARAMETERS
  18277. C          H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
  18278. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  18279. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  18280. C                   VALUES. Z MAY BE IDENTICAL WITH Y.
  18281. C          NDIM   - THE DIMENSION OF VECTORS Y AND Z.
  18282. C
  18283. C       REMARKS
  18284. C          NO ACTION IN CASE NDIM LESS THAN 1.
  18285. C
  18286. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18287. C          NONE
  18288. C
  18289. C       METHOD
  18290. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  18291. C          MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA).
  18292. C          FOR REFERENCE, SEE
  18293. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  18294. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75.
  18295. C
  18296. C    ..................................................................
  18297. C
  18298.     SUBROUTINE DQTFE(H,Y,Z,NDIM)
  18299. C
  18300. C
  18301.     DIMENSION Y(1),Z(1)
  18302.     DOUBLE PRECISION Y,Z,H,HH,SUM1,SUM2
  18303. C
  18304.     SUM2=0.D0
  18305.     IF(NDIM-1)4,3,1
  18306. 1    HH=.5D0*H
  18307. C
  18308. C    INTEGRATION LOOP
  18309.     DO 2 I=2,NDIM
  18310.     SUM1=SUM2
  18311.     SUM2=SUM2+HH*(Y(I)+Y(I-1))
  18312. 2    Z(I-1)=SUM1
  18313. 3    Z(NDIM)=SUM2
  18314. 4    RETURN
  18315.     END
  18316. C
  18317. C    ..................................................................
  18318. C
  18319. C       SUBROUTINE DQTFG
  18320. C
  18321. C       PURPOSE
  18322. C          TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
  18323. C          GENERAL TABLE OF ARGUMENT AND FUNCTION VALUES.
  18324. C
  18325. C       USAGE
  18326. C          CALL DQTFG (X,Y,Z,NDIM)
  18327. C
  18328. C       DESCRIPTION OF PARAMETERS
  18329. C          X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
  18330. C          Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
  18331. C          Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
  18332. C                   VALUES. Z MAY BE IDENTICAL WITH X OR Y.
  18333. C          NDIM   - THE DIMENSION OF VECTORS X,Y,Z.
  18334. C
  18335. C       REMARKS
  18336. C          NO ACTION IN CASE NDIM LESS THAN 1.
  18337. C
  18338. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18339. C          NONE
  18340. C
  18341. C       METHOD
  18342. C          BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
  18343. C          MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA).
  18344. C          FOR REFERENCE, SEE
  18345. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  18346. C          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75.
  18347. C
  18348. C    ..................................................................
  18349. C
  18350.     SUBROUTINE DQTFG(X,Y,Z,NDIM)
  18351. C
  18352. C
  18353.     DIMENSION X(1),Y(1),Z(1)
  18354.     DOUBLE PRECISION X,Y,Z,SUM1,SUM2
  18355. C
  18356.     SUM2=0.D0
  18357.     IF(NDIM-1)4,3,1
  18358. C
  18359. C    INTEGRATION LOOP
  18360. 1    DO 2 I=2,NDIM
  18361.     SUM1=SUM2
  18362.     SUM2=SUM2+.5D0*(X(I)-X(I-1))*(Y(I)+Y(I-1))
  18363. 2    Z(I-1)=SUM1
  18364. 3    Z(NDIM)=SUM2
  18365. 4    RETURN
  18366.     END
  18367. C
  18368. C    ..................................................................
  18369. C
  18370. C       SUBROUTINE DRHARM
  18371. C
  18372. C       PURPOSE
  18373. C          FINDS THE FOURIER COEFFICIENTS OF ONE DIMENSIONAL DOUBLE
  18374. C          PRECISION REAL DATA
  18375. C
  18376. C       USAGE
  18377. C          CALL DRHARM(A,M,INV,S,IFERR)
  18378. C
  18379. C       DESCRIPTION OF PARAMETERS
  18380. C          A     - A DOUBLE PRECISION VECTOR
  18381. C                  AS INPUT, CONTAINS ONE DIMENSIONAL REAL DATA. A IS
  18382. C                  2*N+4 CORE LOCATIONS, WHERE N = 2**M. 2*N REAL
  18383. C                  NUMBERS ARE PUT INTO THE FIRST 2*N CORE LOCATIONS
  18384. C                  OF A
  18385. C                  AS OUTPUT, A CONTAINS THE FOURIER COEFFICIENTS
  18386. C                  A0/2,B0=0,A1,B1,A2,B2,...,AN/2,BN=0 RESPECTIVELY IN
  18387. C                  THE FIRST 2N+2 CORE LOCATIONS OF A
  18388. C          M     - AN INTEGER WHICH DETERMINES THE SIZE OF THE VECTOR
  18389. C                  A. THE SIZE OF A IS 2*(2**M) + 4
  18390. C          INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION OF
  18391. C                  DIMENSION ONE EIGHTH THE NUMBER OF REAL INPUT, VIZ.,
  18392. C                  (1/8)*2*(2**M)
  18393. C          S     - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES
  18394. C                  WITH DIMENSION THE SAME AS INV
  18395. C          IFERR - A RETURNED VALUE OF 1 MEANS THAT M IS LESS THAN 3 OR
  18396. C                  GREATER THAN 20. OTHERWISE IFERR IS SET = 0
  18397. C
  18398. C       REMARKS
  18399. C          THIS SUBROUTINE GIVES THE FOURIER COEFFICIENTS OF 2*(2**M)
  18400. C          REAL POINTS. SEE SUBROUTINE DHARM FOR THREE DIMENSIONAL,
  18401. C          DOUBLE PRECISION, COMPLEX FOURIER TRANSFORMS.
  18402. C
  18403. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18404. C          DHARM
  18405. C
  18406. C       METHOD
  18407. C          THE FOURIER COEFFICIENTS A0,B0=0,A1,B1,...,AN,BN=0 ARE
  18408. C          OBTAINED FOR INPUT XJ, J=0,1,2,...,2N-1 FOR THE FOLLOWING
  18409. C          EQUATION (PI = 3.14159...)
  18410. C
  18411. C                N-1                                               J
  18412. C    XJ=(1/2)A0+SUM (AK*COS(PI*J*K/N)+BK*SIN(PI*J*K/N))+(1/2)AN(-1)
  18413. C                K=1
  18414. C
  18415. C          SEE REFERENCE UNDER SUBROUTINE DHARM
  18416. C
  18417. C    ..................................................................
  18418. C
  18419.     SUBROUTINE DRHARM(A,M,INV,S,IFERR)
  18420.     DIMENSION A(1),L(3),INV(1),S(1)
  18421.     DOUBLE PRECISION A,SI,AP1IM,FN,CO,CIRE,AP2IM,S,SS,DEL,CIIM,AP1RE,
  18422.      1 CNIRE,SC,SIS,AP2RE,CNIIM
  18423.     IFSET=1
  18424.     L(1)=M
  18425.     L(2)=0
  18426.     L(3)=0
  18427.     NTOT=2**M
  18428.     NTOT2 = 2*NTOT
  18429.     FN = NTOT
  18430.     DO   3 I = 2,NTOT2,2
  18431. 3    A(I) = -A(I)
  18432.     DO   6 I = 1,NTOT2
  18433. 6    A(I) = A(I)/FN
  18434.     CALL DHARM(A,L,INV,S,IFSET,IFERR)
  18435. C
  18436. C    MOVE LAST HALF OF A(J)S DOWN ONE SLOT AND ADD A(N) AT BOTTOM TO
  18437. C    GIVE ARRAY FOR A1PRIME AND A2PRIME CALCULATION
  18438. C
  18439. 21    DO  52 I=1,NTOT,2
  18440.     J0=NTOT2+2-I
  18441.     A(J0)=A(J0-2)
  18442. 52    A(J0+1)=A(J0-1)
  18443.     A(NTOT2+3)=A(1)
  18444.     A(NTOT2+4)=A(2)
  18445. C
  18446. C    CALCULATE A1PRIMES AND STORE IN FIRST N SLOTS
  18447. C    CALCULATE A2PRIMES AND STORE IN SECOND N SLOTS IN REVERSE ORDER
  18448.     K0=NTOT+1
  18449.     DO 104 I=1,K0,2
  18450.     K1=NTOT2-I+4
  18451.     AP1RE=.5*(A(I)+A(K1))
  18452.     AP2RE=-.5*(A(I+1)+A(K1+1))
  18453.     AP1IM=.5*(-A(I+1)+A(K1+1))
  18454.     AP2IM=-.5*(A(I)-A(K1))
  18455.     A(I)=AP1RE
  18456.     A(I+1)=AP1IM
  18457.     A(K1)=AP2RE
  18458. 104    A(K1+1)=AP2IM
  18459.     NTO = NTOT/2
  18460. 110    NT=NTO+1
  18461.     DEL=3.141592653589793/DFLOAT(NTOT)
  18462.     SS=DSIN(DEL)
  18463.     SC=DCOS(DEL)
  18464.     SI=0.0
  18465.     CO=1.0
  18466. C
  18467. C    COMPUTE C(J)S FOR J=0 THRU J=N
  18468. 114    DO 116 I=1,NT
  18469.     K6=NTOT2-2*I+5
  18470.     AP2RE=A(K6)*CO+A(K6+1)*SI
  18471.     AP2IM=-A(K6)*SI+A(K6+1)*CO
  18472.     CIRE=.5*(A(2*I-1)+AP2RE)
  18473.     CIIM=.5*(A(2*I)+AP2IM)
  18474.     CNIRE=.5*(A(2*I-1)-AP2RE)
  18475.     CNIIM=.5*(A(2*I)-AP2IM)
  18476.     A(2*I-1)=CIRE
  18477.     A(2*I)=CIIM
  18478.     A(K6)=CNIRE
  18479.     A(K6+1)=-CNIIM
  18480.     SIS=SI
  18481.     SI=SI*SC+CO*SS
  18482. 116    CO=CO*SC-SIS*SS
  18483. C
  18484. C    SHIFT C(J)S FOR J=N/2+1 TO J=N UP ONE SLOT
  18485.     DO 117 I=1,NTOT,2
  18486.     K8=NTOT+4+I
  18487.     A(K8-2)=A(K8)
  18488. 117    A(K8-1)=A(K8+1)
  18489.     DO 500 I=3,NTOT2,2
  18490.     A(I) = 2. * A(I)
  18491. 500    A(I + 1) = -2. * A(I + 1)
  18492.     RETURN
  18493.     END
  18494. C
  18495. C    ..................................................................
  18496. C
  18497. C       SUBROUTINE DRKGS
  18498. C
  18499. C       PURPOSE
  18500. C          TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL
  18501. C          EQUATIONS WITH GIVEN INITIAL VALUES.
  18502. C
  18503. C       USAGE
  18504. C          CALL DRKGS (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  18505. C          PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
  18506. C
  18507. C       DESCRIPTION OF PARAMETERS
  18508. C          PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
  18509. C                   DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
  18510. C                   SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
  18511. C                   ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
  18512. C                   OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
  18513. C                   SUBROUTINE DRKGS. EXCEPT PRMT(5) THE COMPONENTS
  18514. C                   ARE NOT DESTROYED BY SUBROUTINE DRKGS AND THEY ARE
  18515. C          PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
  18516. C          PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
  18517. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  18518. C                   (INPUT),
  18519. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
  18520. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  18521. C                   IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
  18522. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  18523. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  18524. C                   OUTPUT SUBROUTINE.
  18525. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DRKGS INITIALIZES
  18526. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  18527. C                   SUBROUTINE DRKGS AT ANY OUTPUT POINT, HE HAS TO
  18528. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  18529. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  18530. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  18531. C                   THAN 5. HOWEVER SUBROUTINE DRKGS DOES NOT REQUIRE
  18532. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  18533. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  18534. C                   (CALLING DRKGS) WHICH ARE OBTAINED BY SPECIAL
  18535. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  18536. C          Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
  18537. C                   (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
  18538. C                   DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
  18539. C                   POINTS X.
  18540. C          DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
  18541. C                   (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
  18542. C                   EQUAL TO 1. LATERON DERY IS THE VECTOR OF
  18543. C                   DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
  18544. C                   INTERMEDIATE POINTS X.
  18545. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  18546. C                   EQUATIONS IN THE SYSTEM.
  18547. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  18548. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  18549. C                   GREATER THAN 10, SUBROUTINE DRKGS RETURNS WITH
  18550. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. ERROR
  18551. C                   MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  18552. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  18553. C                   PRMT(1)) RESPECTIVELY.
  18554. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. THIS
  18555. C                   SUBROUTINE COMPUTES THE RIGHT HAND SIDES DERY OF
  18556. C                   THE SYSTEM TO GIVEN VALUES X AND Y. ITS PARAMETER
  18557. C                   LIST MUST BE X,Y,DERY. SUBROUTINE FCT SHOULD
  18558. C                   NOT DESTROY X AND Y.
  18559. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  18560. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  18561. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  18562. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  18563. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  18564. C                   SUBROUTINE DRKGS IS TERMINATED.
  18565. C          AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 8
  18566. C                   ROWS AND NDIM COLUMNS.
  18567. C
  18568. C       REMARKS
  18569. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  18570. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  18571. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  18572. C              IHLF=11),
  18573. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
  18574. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  18575. C          (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  18576. C          (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  18577. C
  18578. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18579. C          THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
  18580. C          OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
  18581. C
  18582. C       METHOD
  18583. C          EVALUATION IS DONE BY MEANS OF FOURTH ORDER RUNGE-KUTTA
  18584. C          FORMULAE IN THE MODIFICATION DUE TO GILL. ACCURACY IS
  18585. C          TESTED COMPARING THE RESULTS OF THE PROCEDURE WITH SINGLE
  18586. C          AND DOUBLE INCREMENT.
  18587. C          SUBROUTINE DRKGS AUTOMATICALLY ADJUSTS THE INCREMENT DURING
  18588. C          THE WHOLE COMPUTATION BY HALVING OR DOUBLING. IF MORE THAN
  18589. C          10 BISECTIONS OF THE INCREMENT ARE NECESSARY TO GET
  18590. C          SATISFACTORY ACCURACY, THE SUBROUTINE RETURNS WITH
  18591. C          ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  18592. C          TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
  18593. C          MUST BE FURNISHED BY THE USER.
  18594. C          FOR REFERENCE, SEE
  18595. C          RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL COMPUTERS,
  18596. C          WILEY, NEW YORK/LONDON, 1960, PP.110-120.
  18597. C
  18598. C    ..................................................................
  18599. C
  18600.     SUBROUTINE DRKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  18601. C
  18602. C
  18603.     DIMENSION Y(1),DERY(1),AUX(8,1),A(4),B(4),C(4),PRMT(1)
  18604.     DOUBLE PRECISION PRMT,Y,DERY,AUX,A,B,C,X,XEND,H,AJ,BJ,CJ,R1,R2,
  18605.      1DELT
  18606.     DO 1 I=1,NDIM
  18607. 1    AUX(8,I)=.066666666666666667D0*DERY(I)
  18608.     X=PRMT(1)
  18609.     XEND=PRMT(2)
  18610.     H=PRMT(3)
  18611.     PRMT(5)=0.D0
  18612.     CALL FCT(X,Y,DERY)
  18613. C
  18614. C    ERROR TEST
  18615.     IF(H*(XEND-X))38,37,2
  18616. C
  18617. C    PREPARATIONS FOR RUNGE-KUTTA METHOD
  18618. 2    A(1)=.5D0
  18619.     A(2)=.29289321881345248D0
  18620.     A(3)=1.7071067811865475D0
  18621.     A(4)=.16666666666666667D0
  18622.     B(1)=2.D0
  18623.     B(2)=1.D0
  18624.     B(3)=1.D0
  18625.     B(4)=2.D0
  18626.     C(1)=.5D0
  18627.     C(2)=.29289321881345248D0
  18628.     C(3)=1.7071067811865475D0
  18629.     C(4)=.5D0
  18630. C
  18631. C    PREPARATIONS OF FIRST RUNGE-KUTTA STEP
  18632.     DO 3 I=1,NDIM
  18633.     AUX(1,I)=Y(I)
  18634.     AUX(2,I)=DERY(I)
  18635.     AUX(3,I)=0.D0
  18636. 3    AUX(6,I)=0.D0
  18637.     IREC=0
  18638.     H=H+H
  18639.     IHLF=-1
  18640.     ISTEP=0
  18641.     IEND=0
  18642. C
  18643. C
  18644. C    START OF A RUNGE-KUTTA STEP
  18645. 4    IF((X+H-XEND)*H)7,6,5
  18646. 5    H=XEND-X
  18647. 6    IEND=1
  18648. C
  18649. C    RECORDING OF INITIAL VALUES OF THIS STEP
  18650. 7    CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT)
  18651.     IF(PRMT(5))40,8,40
  18652. 8    ITEST=0
  18653. 9    ISTEP=ISTEP+1
  18654. C
  18655. C
  18656. C    START OF INNERMOST RUNGE-KUTTA LOOP
  18657.     J=1
  18658. 10    AJ=A(J)
  18659.     BJ=B(J)
  18660.     CJ=C(J)
  18661.     DO 11 I=1,NDIM
  18662.     R1=H*DERY(I)
  18663.     R2=AJ*(R1-BJ*AUX(6,I))
  18664.     Y(I)=Y(I)+R2
  18665.     R2=R2+R2+R2
  18666. 11    AUX(6,I)=AUX(6,I)+R2-CJ*R1
  18667.     IF(J-4)12,15,15
  18668. 12    J=J+1
  18669.     IF(J-3)13,14,13
  18670. 13    X=X+.5D0*H
  18671. 14    CALL FCT(X,Y,DERY)
  18672.     GOTO 10
  18673. C    END OF INNERMOST RUNGE-KUTTA LOOP
  18674. C
  18675. C
  18676. C    TEST OF ACCURACY
  18677. 15    IF(ITEST)16,16,20
  18678. C
  18679. C    IN CASE ITEST=0 THERE IS NO POSSIBILITY FOR TESTING OF ACCURACY
  18680. 16    DO 17 I=1,NDIM
  18681. 17    AUX(4,I)=Y(I)
  18682.     ITEST=1
  18683.     ISTEP=ISTEP+ISTEP-2
  18684. 18    IHLF=IHLF+1
  18685.     X=X-H
  18686.     H=.5D0*H
  18687.     DO 19 I=1,NDIM
  18688.     Y(I)=AUX(1,I)
  18689.     DERY(I)=AUX(2,I)
  18690. 19    AUX(6,I)=AUX(3,I)
  18691.     GOTO 9
  18692. C
  18693. C    IN CASE ITEST=1 TESTING OF ACCURACY IS POSSIBLE
  18694. 20    IMOD=ISTEP/2
  18695.     IF(ISTEP-IMOD-IMOD)21,23,21
  18696. 21    CALL FCT(X,Y,DERY)
  18697.     DO 22 I=1,NDIM
  18698.     AUX(5,I)=Y(I)
  18699. 22    AUX(7,I)=DERY(I)
  18700.     GOTO 9
  18701. C
  18702. C    COMPUTATION OF TEST VALUE DELT
  18703. 23    DELT=0.D0
  18704.     DO 24 I=1,NDIM
  18705. 24    DELT=DELT+AUX(8,I)*DABS(AUX(4,I)-Y(I))
  18706.     IF(DELT-PRMT(4))28,28,25
  18707. C
  18708. C    ERROR IS TOO GREAT
  18709. 25    IF(IHLF-10)26,36,36
  18710. 26    DO 27 I=1,NDIM
  18711. 27    AUX(4,I)=AUX(5,I)
  18712.     ISTEP=ISTEP+ISTEP-4
  18713.     X=X-H
  18714.     IEND=0
  18715.     GOTO 18
  18716. C
  18717. C    RESULT VALUES ARE GOOD
  18718. 28    CALL FCT(X,Y,DERY)
  18719.     DO 29 I=1,NDIM
  18720.     AUX(1,I)=Y(I)
  18721.     AUX(2,I)=DERY(I)
  18722.     AUX(3,I)=AUX(6,I)
  18723.     Y(I)=AUX(5,I)
  18724. 29    DERY(I)=AUX(7,I)
  18725.     CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT)
  18726.     IF(PRMT(5))40,30,40
  18727. 30    DO 31 I=1,NDIM
  18728.     Y(I)=AUX(1,I)
  18729. 31    DERY(I)=AUX(2,I)
  18730.     IREC=IHLF
  18731.     IF(IEND)32,32,39
  18732. C
  18733. C    INCREMENT GETS DOUBLED
  18734. 32    IHLF=IHLF-1
  18735.     ISTEP=ISTEP/2
  18736.     H=H+H
  18737.     IF(IHLF)4,33,33
  18738. 33    IMOD=ISTEP/2
  18739.     IF(ISTEP-IMOD-IMOD)4,34,4
  18740. 34    IF(DELT-.02D0*PRMT(4))35,35,4
  18741. 35    IHLF=IHLF-1
  18742.     ISTEP=ISTEP/2
  18743.     H=H+H
  18744.     GOTO 4
  18745. C
  18746. C
  18747. C    RETURNS TO CALLING PROGRAM
  18748. 36    IHLF=11
  18749.     CALL FCT(X,Y,DERY)
  18750.     GOTO 39
  18751. 37    IHLF=12
  18752.     GOTO 39
  18753. 38    IHLF=13
  18754. 39    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  18755. 40    RETURN
  18756.     END
  18757. C
  18758. C    ..................................................................
  18759. C
  18760. C       SUBROUTINE DRTMI
  18761. C
  18762. C       PURPOSE
  18763. C          TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM FCT(X)=0
  18764. C          BY MEANS OF MUELLER-S ITERATION METHOD.
  18765. C
  18766. C       USAGE
  18767. C          CALL DRTMI (X,F,FCT,XLI,XRI,EPS,IEND,IER)
  18768. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
  18769. C
  18770. C       DESCRIPTION OF PARAMETERS
  18771. C          X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION
  18772. C                   FCT(X)=0.
  18773. C          F      - DOUBLE PRECISION RESULTANT FUNCTION VALUE
  18774. C                   AT ROOT X.
  18775. C          FCT    - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
  18776. C                   SUBPROGRAM USED.
  18777. C          XLI    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  18778. C                   INITIAL LEFT BOUND OF THE ROOT X.
  18779. C          XRI    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  18780. C                   INITIAL RIGHT BOUND OF THE ROOT X.
  18781. C          EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  18782. C                   UPPER BOUND OF THE ERROR OF RESULT X.
  18783. C          IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
  18784. C          IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
  18785. C                    IER=0 - NO ERROR,
  18786. C                    IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS
  18787. C                            FOLLOWED BY IEND SUCCESSIVE STEPS OF
  18788. C                            BISECTION,
  18789. C                    IER=2 - BASIC ASSUMPTION FCT(XLI)*FCT(XRI) LESS
  18790. C                            THAN OR EQUAL TO ZERO IS NOT SATISFIED.
  18791. C
  18792. C       REMARKS
  18793. C          THE PROCEDURE ASSUMES THAT FUNCTION VALUES AT INITIAL
  18794. C          BOUNDS XLI AND XRI HAVE NOT THE SAME SIGN. IF THIS BASIC
  18795. C          ASSUMPTION IS NOT SATISFIED BY INPUT VALUES XLI AND XRI, THE
  18796. C          PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2.
  18797. C
  18798. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18799. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  18800. C          MUST BE FURNISHED BY THE USER.
  18801. C
  18802. C       METHOD
  18803. C          SOLUTION OF EQUATION FCT(X)=0 IS DONE BY MEANS OF MUELLER-S
  18804. C          ITERATION METHOD OF SUCCESSIVE BISECTIONS AND INVERSE
  18805. C          PARABOLIC INTERPOLATION, WHICH STARTS AT THE INITIAL BOUNDS
  18806. C          XLI AND XRI. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
  18807. C          FCT(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
  18808. C          REQUIRES TWO EVALUATIONS OF FCT(X). FOR TEST ON SATISFACTORY
  18809. C          ACCURACY SEE FORMULAE (3,4) OF MATHEMATICAL DESCRIPTION.
  18810. C          FOR REFERENCE, SEE G. K. KRISTIANSEN, ZERO OF ARBITRARY
  18811. C          FUNCTION, BIT, VOL. 3 (1963), PP.205-206.
  18812. C
  18813. C    ..................................................................
  18814. C
  18815.     SUBROUTINE DRTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER)
  18816. C
  18817. C
  18818.     DOUBLE PRECISION X,F,FCT,XLI,XRI,XL,XR,FL,FR,TOL,TOLF,A,DX,XM,FM
  18819. C
  18820. C    PREPARE ITERATION
  18821.     IER=0
  18822.     XL=XLI
  18823.     XR=XRI
  18824.     X=XL
  18825.     TOL=X
  18826.     F=FCT(TOL)
  18827.     IF(F)1,16,1
  18828. 1    FL=F
  18829.     X=XR
  18830.     TOL=X
  18831.     F=FCT(TOL)
  18832.     IF(F)2,16,2
  18833. 2    FR=F
  18834.     IF(DSIGN(1.D0,FL)+DSIGN(1.D0,FR))25,3,25
  18835. C
  18836. C    BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED.
  18837. C    GENERATE TOLERANCE FOR FUNCTION VALUES.
  18838. 3    I=0
  18839.     TOLF=100.*EPS
  18840. C
  18841. C
  18842. C    START ITERATION LOOP
  18843. 4    I=I+1
  18844. C
  18845. C    START BISECTION LOOP
  18846.     DO 13 K=1,IEND
  18847.     X=.5D0*(XL+XR)
  18848.     TOL=X
  18849.     F=FCT(TOL)
  18850.     IF(F)5,16,5
  18851. 5    IF(DSIGN(1.D0,F)+DSIGN(1.D0,FR))7,6,7
  18852. C
  18853. C    INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR
  18854. 6    TOL=XL
  18855.     XL=XR
  18856.     XR=TOL
  18857.     TOL=FL
  18858.     FL=FR
  18859.     FR=TOL
  18860. 7    TOL=F-FL
  18861.     A=F*TOL
  18862.     A=A+A
  18863.     IF(A-FR*(FR-FL))8,9,9
  18864. 8    IF(I-IEND)17,17,9
  18865. 9    XR=X
  18866.     FR=F
  18867. C
  18868. C    TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP
  18869.     TOL=EPS
  18870.     A=DABS(XR)
  18871.     IF(A-1.D0)11,11,10
  18872. 10    TOL=TOL*A
  18873. 11    IF(DABS(XR-XL)-TOL)12,12,13
  18874. 12    IF(DABS(FR-FL)-TOLF)14,14,13
  18875. 13    CONTINUE
  18876. C    END OF BISECTION LOOP
  18877. C
  18878. C    NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND
  18879. C    SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION
  18880. C    VALUES AT RIGHT BOUNDS. ERROR RETURN.
  18881.     IER=1
  18882. 14    IF(DABS(FR)-DABS(FL))16,16,15
  18883. 15    X=XL
  18884.     F=FL
  18885. 16    RETURN
  18886. C
  18887. C    COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION
  18888. 17    A=FR-F
  18889.     DX=(X-XL)*FL*(1.D0+F*(A-TOL)/(A*(FR-FL)))/TOL
  18890.     XM=X
  18891.     FM=F
  18892.     X=XL-DX
  18893.     TOL=X
  18894.     F=FCT(TOL)
  18895.     IF(F)18,16,18
  18896. C
  18897. C    TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP
  18898. 18    TOL=EPS
  18899.     A=DABS(X)
  18900.     IF(A-1.D0)20,20,19
  18901. 19    TOL=TOL*A
  18902. 20    IF(DABS(DX)-TOL)21,21,22
  18903. 21    IF(DABS(F)-TOLF)16,16,22
  18904. C
  18905. C    PREPARATION OF NEXT BISECTION LOOP
  18906. 22    IF(DSIGN(1.D0,F)+DSIGN(1.D0,FL))24,23,24
  18907. 23    XR=X
  18908.     FR=F
  18909.     GO TO 4
  18910. 24    XL=X
  18911.     FL=F
  18912.     XR=XM
  18913.     FR=FM
  18914.     GO TO 4
  18915. C    END OF ITERATION LOOP
  18916. C
  18917. C
  18918. C    ERROR RETURN IN CASE OF WRONG INPUT DATA
  18919. 25    IER=2
  18920.     RETURN
  18921.     END
  18922. C
  18923. C    ..................................................................
  18924. C
  18925. C       SUBROUTINE DRTNI
  18926. C
  18927. C       PURPOSE
  18928. C          TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM F(X)=0
  18929. C          BY MEANS OF NEWTON-S ITERATION METHOD.
  18930. C
  18931. C       USAGE
  18932. C          CALL DRTNI (X,F,DERF,FCT,XST,EPS,IEND,IER)
  18933. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
  18934. C
  18935. C       DESCRIPTION OF PARAMETERS
  18936. C          X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION F(X)=0.
  18937. C          F      - DOUBLE PRECISION RESULTANT FUNCTION VALUE AT
  18938. C                   ROOT X.
  18939. C          DERF   - DOUBLE PRECISION RESULTANT VALUE OF DERIVATIVE
  18940. C                   AT ROOT X.
  18941. C          FCT    - NAME OF THE EXTERNAL SUBROUTINE USED. IT COMPUTES
  18942. C                   TO GIVEN ARGUMENT X FUNCTION VALUE F AND DERIVATIVE
  18943. C                   DERF. ITS PARAMETER LIST MUST BE X,F,DERF, WHERE
  18944. C                   ALL PARAMETERS ARE DOUBLE PRECISION.
  18945. C          XST    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  18946. C                   INITIAL GUESS OF THE ROOT X.
  18947. C          EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  18948. C                   UPPER BOUND OF THE ERROR OF RESULT X.
  18949. C          IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
  18950. C          IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
  18951. C                    IER=0 - NO ERROR,
  18952. C                    IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
  18953. C                    IER=2 - AT ANY ITERATION STEP DERIVATIVE DERF WAS
  18954. C                            EQUAL TO ZERO.
  18955. C
  18956. C       REMARKS
  18957. C          THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
  18958. C          IF AT ANY ITERATION STEP DERIVATIVE OF F(X) IS EQUAL TO 0.
  18959. C          POSSIBLY THE PROCEDURE WOULD BE SUCCESSFUL IF IT IS STARTED
  18960. C          ONCE MORE WITH ANOTHER INITIAL GUESS XST.
  18961. C
  18962. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  18963. C          THE EXTERNAL SUBROUTINE FCT(X,F,DERF) MUST BE FURNISHED
  18964. C          BY THE USER.
  18965. C
  18966. C       METHOD
  18967. C          SOLUTION OF EQUATION F(X)=0 IS DONE BY MEANS OF NEWTON-S
  18968. C          ITERATION METHOD, WHICH STARTS AT THE INITIAL GUESS XST OF
  18969. C          A ROOT X. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
  18970. C          F(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
  18971. C          REQUIRES ONE EVALUATION OF F(X) AND ONE EVALUATION OF THE
  18972. C          DERIVATIVE OF F(X). FOR TEST ON SATISFACTORY ACCURACY SEE
  18973. C          FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
  18974. C          FOR REFERENCE, SEE R. ZURMUEHL, PRAKTISCHE MATHEMATIK FUER
  18975. C          INGENIEURE UND PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/
  18976. C          HEIDELBERG, 1963, PP.12-17.
  18977. C
  18978. C    ..................................................................
  18979. C
  18980.     SUBROUTINE DRTNI(X,F,DERF,FCT,XST,EPS,IEND,IER)
  18981. C
  18982. C
  18983.     DOUBLE PRECISION X,F,DERF,XST,TOL,TOLF,DX,A
  18984. C
  18985. C    PREPARE ITERATION
  18986.     IER=0
  18987.     X=XST
  18988.     TOL=X
  18989.     CALL FCT(TOL,F,DERF)
  18990.     TOLF=100.*EPS
  18991. C
  18992. C
  18993. C    START ITERATION LOOP
  18994.     DO 6 I=1,IEND
  18995.     IF(F)1,7,1
  18996. C
  18997. C    EQUATION IS NOT SATISFIED BY X
  18998. 1    IF(DERF)2,8,2
  18999. C
  19000. C    ITERATION IS POSSIBLE
  19001. 2    DX=F/DERF
  19002.     X=X-DX
  19003.     TOL=X
  19004.     CALL FCT(TOL,F,DERF)
  19005. C
  19006. C    TEST ON SATISFACTORY ACCURACY
  19007.     TOL=EPS
  19008.     A=DABS(X)
  19009.     IF(A-1.D0)4,4,3
  19010. 3    TOL=TOL*A
  19011. 4    IF(DABS(DX)-TOL)5,5,6
  19012. 5    IF(DABS(F)-TOLF)7,7,6
  19013. 6    CONTINUE
  19014. C    END OF ITERATION LOOP
  19015. C
  19016. C
  19017. C    NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
  19018.     IER=1
  19019. 7    RETURN
  19020. C
  19021. C    ERROR RETURN IN CASE OF ZERO DIVISOR
  19022. 8    IER=2
  19023.     RETURN
  19024.     END
  19025. C
  19026. C    ..................................................................
  19027. C
  19028. C       SUBROUTINE DRTWI
  19029. C
  19030. C       PURPOSE
  19031. C          TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM X=FCT(X)
  19032. C          BY MEANS OF WEGSTEIN-S ITERATION METHOD.
  19033. C
  19034. C       USAGE
  19035. C          CALL DRTWI (X,VAL,FCT,XST,EPS,IEND,IER)
  19036. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
  19037. C
  19038. C       DESCRIPTION OF PARAMETERS
  19039. C          X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION
  19040. C                   X=FCT(X).
  19041. C          VAL    - DOUBLE PRECISION RESULTANT VALUE OF X-FCT(X)
  19042. C                   AT ROOT X.
  19043. C          FCT    - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
  19044. C                   SUBPROGRAM USED.
  19045. C          XST    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  19046. C                   INITIAL GUESS OF THE ROOT X.
  19047. C          EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
  19048. C                   UPPER BOUND OF THE ERROR OF RESULT X.
  19049. C          IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
  19050. C          IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
  19051. C                    IER=0 - NO ERROR,
  19052. C                    IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
  19053. C                    IER=2 - AT ANY ITERATION STEP THE DENOMINATOR OF
  19054. C                            ITERATION FORMULA WAS EQUAL TO ZERO.
  19055. C
  19056. C       REMARKS
  19057. C          THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
  19058. C          IF AT ANY ITERATION STEP THE DENOMINATOR OF ITERATION
  19059. C          FORMULA WAS EQUAL TO ZERO. THAT MEANS THAT THERE IS AT
  19060. C          LEAST ONE POINT IN THE RANGE IN WHICH ITERATION MOVES WITH
  19061. C          DERIVATIVE OF FCT(X) EQUAL TO 1.
  19062. C
  19063. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  19064. C          THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
  19065. C          MUST BE FURNISHED BY THE USER.
  19066. C
  19067. C       METHOD
  19068. C          SOLUTION OF EQUATION X=FCT(X) IS DONE BY MEANS OF
  19069. C          WEGSTEIN-S ITERATION METHOD, WHICH STARTS AT THE INITIAL
  19070. C          GUESS XST OF A ROOT X. ONE ITERATION STEP REQUIRES ONE
  19071. C          EVALUATION OF FCT(X). FOR TEST ON SATISFACTORY ACCURACY SEE
  19072. C          FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
  19073. C          FOR REFERENCE, SEE
  19074. C          (1) G. N. LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
  19075. C              ILIFFE, LONDON, 1960, PP.134-138,
  19076. C          (2) J. WEGSTEIN, ALGORITHM 2, CACM, VOL.3, ISS.2 (1960),
  19077. C              PP.74,
  19078. C          (3) H.C. THACHER, ALGORITHM 15, CACM, VOL.3, ISS.8 (1960),
  19079. C              PP.475,
  19080. C          (4) J.G. HERRIOT, ALGORITHM 26, CACM, VOL.3, ISS.11 (1960),
  19081. C              PP.603.
  19082. C
  19083. C    ..................................................................
  19084. C
  19085.     SUBROUTINE DRTWI(X,VAL,FCT,XST,EPS,IEND,IER)
  19086. C
  19087. C
  19088.     DOUBLE PRECISION X,VAL,FCT,XST,A,B,D,TOL
  19089. C
  19090. C    PREPARE ITERATION
  19091.     IER=0
  19092.     TOL=XST
  19093.     X=FCT(TOL)
  19094.     A=X-XST
  19095.     B=-A
  19096.     TOL=X
  19097.     VAL=X-FCT(TOL)
  19098. C
  19099. C
  19100. C    START ITERATION LOOP
  19101.     DO 6 I=1,IEND
  19102.     IF(VAL)1,7,1
  19103. C
  19104. C    EQUATION IS NOT SATISFIED BY X
  19105. 1    B=B/VAL-1.D0
  19106.     IF(B)2,8,2
  19107. C
  19108. C    ITERATION IS POSSIBLE
  19109. 2    A=A/B
  19110.     X=X+A
  19111.     B=VAL
  19112.     TOL=X
  19113.     VAL=X-FCT(TOL)
  19114. C
  19115. C    TEST ON SATISFACTORY ACCURACY
  19116.     TOL=EPS
  19117.     D=DABS(X)
  19118.     IF(D-1.D0)4,4,3
  19119. 3    TOL=TOL*D
  19120. 4    IF(DABS(A)-TOL)5,5,6
  19121. 5    IF(DABS(VAL)-1.D1*TOL)7,7,6
  19122. 6    CONTINUE
  19123. C    END OF ITERATION LOOP
  19124. C
  19125. C
  19126. C    NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
  19127.     IER=1
  19128. 7    RETURN
  19129. C
  19130. C    ERROR RETURN IN CASE OF ZERO DIVISOR
  19131. 8    IER=2
  19132.     RETURN
  19133.     END
  19134. C
  19135. C    ..................................................................
  19136. C
  19137. C       SUBROUTINE DSE13
  19138. C
  19139. C       PURPOSE
  19140. C          TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
  19141. C          VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
  19142. C          EQUIDISTANTLY SPACED ARGUMENT VALUES.
  19143. C
  19144. C       USAGE
  19145. C          CALL DSE13(Y,Z,NDIM,IER)
  19146. C
  19147. C       DESCRIPTION OF PARAMETERS
  19148. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  19149. C                   (DIMENSION NDIM)
  19150. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
  19151. C                   FUNCTION VALUES (DIMENSION NDIM)
  19152. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  19153. C          IER   -  RESULTING ERROR PARAMETER
  19154. C                   IER = -1  - NDIM IS LESS THAN 3
  19155. C                   IER =  0  - NO ERROR
  19156. C
  19157. C       REMARKS
  19158. C          (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
  19159. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y
  19160. C                IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  19161. C
  19162. C       SUBROUTINES AND SUBPROGRAMS REQUIRED
  19163. C          NONE
  19164. C
  19165. C       METHOD
  19166. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  19167. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED
  19168. C          VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST-
  19169. C          SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE
  19170. C          POINTS (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
  19171. C          INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  19172. C          TORONTO/LONDON, 1956, PP. 295-302.)
  19173. C
  19174. C    ..................................................................
  19175. C
  19176.     SUBROUTINE DSE13(Y,Z,NDIM,IER)
  19177. C
  19178.     DIMENSION Y(1),Z(1)
  19179.     DOUBLE PRECISION Y,Z,A,B,C
  19180. C
  19181. C       TEST OF DIMENSION
  19182.     IF(NDIM-3)3,1,1
  19183. C
  19184. C       PREPARE LOOP
  19185. 1    B=.16666666666666667D0*(5.D0*Y(1)+Y(2)+Y(2)-Y(3))
  19186.       C=.16666666666666667*(5.D0*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2))
  19187. C
  19188. C       START LOOP
  19189.     DO 2 I=3,NDIM
  19190.     A=B
  19191.     B=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I))
  19192. 2    Z(I-2)=A
  19193. C       END OF LOOP
  19194. C
  19195. C       UPDATE LAST TWO COMPONENTS
  19196.     Z(NDIM-1)=B
  19197.     Z(NDIM)=C
  19198.     IER=0
  19199.     RETURN
  19200. C
  19201. C       ERROR EXIT IN CASE NDIM IS LESS THAN 3
  19202. 3    IER=-1
  19203.     RETURN
  19204.     END
  19205. C
  19206. C    ..................................................................
  19207. C
  19208. C       SUBROUTINE DSE15
  19209. C
  19210. C       PURPOSE
  19211. C          TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
  19212. C          VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
  19213. C          EQUIDISTANTLY SPACED ARGUMENT VALUES.
  19214. C
  19215. C       USAGE
  19216. C          CALL DSE15(Y,Z,NDIM,IER)
  19217. C
  19218. C       DESCRIPTION OF PARAMETERS
  19219. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  19220. C                   (DIMENSION NDIM)
  19221. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
  19222. C                   FUNCTION VALUES (DIMENSION NDIM)
  19223. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  19224. C          IER   -  RESULTING ERROR PARAMETER
  19225. C                   IER = -1  - NDIM IS LESS THAN 5
  19226. C                   IER =  0  - NO ERROR
  19227. C
  19228. C       REMARKS
  19229. C          (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
  19230. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
  19231. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  19232. C
  19233. C       SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
  19234. C          NONE
  19235. C
  19236. C       METHOD
  19237. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  19238. C          EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
  19239. C          SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
  19240. C          LEAST-SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 5
  19241. C          SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
  19242. C          HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
  19243. C          MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
  19244. C
  19245. C    ..................................................................
  19246. C
  19247.     SUBROUTINE DSE15(Y,Z,NDIM,IER)
  19248. C
  19249. C
  19250.     DIMENSION Y(1),Z(1)
  19251.     DOUBLE PRECISION Y,Z,A,B,C
  19252. C
  19253. C       TEST OF DIMENSION
  19254.     IF(NDIM-5)3,1,1
  19255. C
  19256. C       PREPARE LOOP
  19257. 1    A=Y(1)+Y(1)
  19258.     C=Y(2)+Y(2)
  19259.     B=.2D0*(A+Y(1)+C+Y(3)-Y(5))
  19260.     C=.1D0*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4))
  19261. C
  19262. C       START LOOP
  19263.     DO 2 I=5,NDIM
  19264.     A=B
  19265.     B=C
  19266.     C=.2D0*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I))
  19267. 2    Z(I-4)=A
  19268. C       END OF LOOP
  19269. C
  19270. C       UPDATE LAST FOUR COMPONENTS
  19271.     A=Y(NDIM)+Y(NDIM)
  19272.     A=.1D0*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2)
  19273.      1      +Y(NDIM-3))
  19274.     Z(NDIM-3)=B
  19275.     Z(NDIM-2)=C
  19276.     Z(NDIM-1)=A
  19277.     Z(NDIM)=A+A-C
  19278.     IER=0
  19279.     RETURN
  19280. C
  19281. C       ERROR EXIT IN CASE NDIM IS LESS THAN 5
  19282. 3    IER=-1
  19283.     RETURN
  19284.     END
  19285. C
  19286. C    ..................................................................
  19287. C
  19288. C       SUBROUTINE DSE35
  19289. C
  19290. C       PURPOSE
  19291. C          TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
  19292. C          VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
  19293. C          EQUIDISTANTLY SPACED ARGUMENT VALUES.
  19294. C
  19295. C       USAGE
  19296. C          CALL DSE35(Y,Z,NDIM,IER)
  19297. C
  19298. C       DESCRIPTION OF PARAMETERS
  19299. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  19300. C                   (DIMENSION NDIM)
  19301. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
  19302. C                   FUNCTION VALUES (DIMENSION NDIM)
  19303. C          NDIM  -  DIMENSION OF VECTORS Y AND Z
  19304. C          IER   -  RESULTING ERROR PARAMETER
  19305. C                   IER = -1  - NDIM IS LESS THAN 5
  19306. C                   IER =  0  - NO ERROR
  19307. C
  19308. C       REMARKS
  19309. C          (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
  19310. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
  19311. C                DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  19312. C
  19313. C       SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
  19314. C          NONE
  19315. C
  19316. C       METHOD
  19317. C          IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
  19318. C          EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
  19319. C          SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
  19320. C          LEAST-SQUARES POLYNOMIAL OF DEGREE 3 RELEVANT TO THE 5
  19321. C          SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
  19322. C          HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
  19323. C          MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
  19324. C
  19325. C    ..................................................................
  19326. C
  19327.     SUBROUTINE DSE35(Y,Z,NDIM,IER)
  19328. C
  19329. C
  19330.     DIMENSION Y(1),Z(1)
  19331.     DOUBLE PRECISION Y,Z,A,B,C,D
  19332. C
  19333. C       TEST OF DIMENSION
  19334.     IF(NDIM-5)4,1,1
  19335. C
  19336. C       PREPARE LOOP
  19337. 1    B=Y(1)
  19338.     C=Y(2)
  19339. C
  19340. C       START LOOP
  19341.     DO 3 I=5,NDIM
  19342.     A=B
  19343.     B=C
  19344.     C=Y(I-2)
  19345. C
  19346. C       GENERATE FOURTH CENTRAL DIFFERENCE
  19347.     D=C-B-Y(I-1)
  19348.     D=D+D+C
  19349.     D=D+D+A+Y(I)
  19350. C
  19351. C       CHECK FIRST TWO COMPONENTS
  19352.     IF(I-5)2,2,3
  19353. 2    Z(1)=A-.014285714285714286D0*D
  19354.     Z(2)=B+.057142857142857143D0*D
  19355. 3    Z(I-2)=C-.08571428571428571D0*D
  19356. C       END OF LOOP
  19357. C
  19358. C       UPDATE LAST TWO COMPONENTS
  19359.     Z(NDIM-1)=Y(NDIM-1)+.057142857142857143D0*D
  19360.     Z(NDIM)=Y(NDIM)-.014285714285714286D0*D
  19361.     IER=0
  19362.     RETURN
  19363. C
  19364. C       ERROR EXIT IN CASE NDIM IS LESS THAN 5
  19365. 4    IER=-1
  19366.     RETURN
  19367.     END
  19368. C
  19369. C    ..................................................................
  19370. C
  19371. C       SUBROUTINE DSG13
  19372. C
  19373. C       PURPOSE
  19374. C          TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN
  19375. C          VECTORS OF ARGUMENT VALUES AND CORRESPONDING FUNCTION
  19376. C          VALUES.
  19377. C
  19378. C       USAGE
  19379. C          CALL DSG13(X,Y,Z,NDIM,IER)
  19380. C
  19381. C       DESCRIPTION OF PARAMETERS
  19382. C          X     -  GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES
  19383. C                   (DIMENSION NDIM)
  19384. C          Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
  19385. C                   CORRESPONDING TO X (DIMENSION NDIM)
  19386. C          Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
  19387. C                   FUNCTION VALUES (DIMENSION NDIM)
  19388. C          NDIM  -  DIMENSION OF VECTORS X,Y,AND Z
  19389. C          IER   -  RESULTING ERROR PARAMETER
  19390. C                   IER = -1  - NDIM IS LESS THAN 3
  19391. C                   IER =  0  - NO ERROR
  19392. C
  19393. C       REMARKS
  19394. C          (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
  19395. C          (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
  19396. C                X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
  19397. C
  19398. C       SUBROUTINES AND SUBPROGRAMS REQUIRED
  19399. C          NONE
  19400. C
  19401. C       METHOD
  19402. C          EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED
  19403. C          VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST-
  19404. C          SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE
  19405. C          POINTS (X(I+K),Y(I+K)) K = -1,0,1.(SEE HILDEBRAND, F.B.,
  19406. C          INTRODUCTION  TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
  19407. C          TORONTO/LONDON, 1956, PP.258-311.)
  19408. C
  19409. C    ..................................................................
  19410. C
  19411.     SUBROUTINE DSG13(X,Y,Z,NDIM,IER)
  19412. C
  19413. C
  19414.     DIMENSION X(1),Y(1),Z(1)
  19415.     DOUBLE PRECISION X,Y,Z,XM,YM,T1,T2,T3,H
  19416. C
  19417. C       TEST OF DIMENSION
  19418.     IF(NDIM-3)7,1,1
  19419. C
  19420. C       START LOOP
  19421. 1    DO 6 I=3,NDIM
  19422.     XM=.33333333333333333D0*(X(I-2)+X(I-1)+X(I))
  19423.     YM=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I))
  19424.     T1=X(I-2)-XM
  19425.     T2=X(I-1)-XM
  19426.     T3=X(I)-XM
  19427.     XM=T1*T1+T2*T2+T3*T3
  19428.     IF(XM)3,3,2
  19429. 2    XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM
  19430. C
  19431. C       CHECK FIRST POINT
  19432. 3    IF(I-3)4,4,5
  19433. 4    H=XM*T1+YM
  19434. 5    Z(I-2)=H
  19435. 6    H=XM*T2+YM
  19436. C       END OF LOOP
  19437. C
  19438. C       UPDATE LAST TWO COMPONENTS
  19439.     Z(NDIM-1)=H
  19440.     Z(NDIM)=XM*T3+YM
  19441.     IER=0
  19442.     RETURN
  19443. C
  19444. C       ERROR EXIT IN CASE NDIM IS LESS THAN 3
  19445. 7    IER=-1
  19446.     RETURN
  19447.     END
  19448. C
  19449. C    ..................................................................
  19450. C
  19451. C       SUBROUTINE DSINV
  19452. C
  19453. C       PURPOSE
  19454. C          INVERT A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX
  19455. C
  19456. C       USAGE
  19457. C          CALL DSINV(A,N,EPS,IER)
  19458. C
  19459. C       DESCRIPTION OF PARAMETERS
  19460. C          A      - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN
  19461. C                   SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT
  19462. C                   MATRIX.
  19463. C                   ON RETURN A CONTAINS THE RESULTANT UPPER
  19464. C                   TRIANGULAR MATRIX IN DOUBLE PRECISION.
  19465. C          N      - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX.
  19466. C          EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED
  19467. C                   AS RELATIVE TOLERANCE FOR TEST ON LOSS OF
  19468. C                   SIGNIFICANCE.
  19469. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  19470. C                   IER=0  - NO ERROR
  19471. C                   IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
  19472. C                            TER N OR BECAUSE SOME RADICAND IS NON-
  19473. C                            POSITIVE (MATRIX A IS NOT POSITIVE
  19474. C                            DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI-
  19475. C                            FICANCE)
  19476. C                   IER=K  - WARNING WHICH INDICATES LOSS OF SIGNIFI-
  19477. C                            CANCE. THE RADICAND FORMED AT FACTORIZA-
  19478. C                            TION STEP K+1 WAS STILL POSITIVE BUT NO
  19479. C                            LONGER GREATER THAN ABS(EPS*A(K+1,K+1)).
  19480. C
  19481. C       REMARKS
  19482. C          THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE
  19483. C          STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS.
  19484. C          IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU-
  19485. C          LAR MATRIX IS STORED COLUMNWISE TOO.
  19486. C          THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL
  19487. C          CALCULATED RADICANDS ARE POSITIVE.
  19488. C
  19489. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  19490. C          DMFSD
  19491. C
  19492. C       METHOD
  19493. C          SOLUTION IS DONE USING FACTORIZATION BY SUBROUTINE DMFSD.
  19494. C
  19495. C    ..................................................................
  19496. C
  19497.     SUBROUTINE DSINV(A,N,EPS,IER)
  19498. C
  19499. C
  19500.     DIMENSION A(1)
  19501.     DOUBLE PRECISION A,DIN,WORK
  19502. C
  19503. C       FACTORIZE GIVEN MATRIX BY MEANS OF SUBROUTINE DMFSD
  19504. C       A = TRANSPOSE(T) * T
  19505.     CALL DMFSD(A,N,EPS,IER)
  19506.     IF(IER) 9,1,1
  19507. C
  19508. C       INVERT UPPER TRIANGULAR MATRIX T
  19509. C       PREPARE INVERSION-LOOP
  19510. 1    IPIV=N*(N+1)/2
  19511.     IND=IPIV
  19512. C
  19513. C       INITIALIZE INVERSION-LOOP
  19514.     DO 6 I=1,N
  19515.     DIN=1.D0/A(IPIV)
  19516.     A(IPIV)=DIN
  19517.     MIN=N
  19518.     KEND=I-1
  19519.     LANF=N-KEND
  19520.     IF(KEND) 5,5,2
  19521. 2    J=IND
  19522. C
  19523. C       INITIALIZE ROW-LOOP
  19524.     DO 4 K=1,KEND
  19525.     WORK=0.D0
  19526.     MIN=MIN-1
  19527.     LHOR=IPIV
  19528.     LVER=J
  19529. C
  19530. C       START INNER LOOP
  19531.     DO 3 L=LANF,MIN
  19532.     LVER=LVER+1
  19533.     LHOR=LHOR+L
  19534. 3    WORK=WORK+A(LVER)*A(LHOR)
  19535. C       END OF INNER LOOP
  19536. C
  19537.     A(J)=-WORK*DIN
  19538. 4    J=J-MIN
  19539. C       END OF ROW-LOOP
  19540. C
  19541. 5    IPIV=IPIV-MIN
  19542. 6    IND=IND-1
  19543. C       END OF INVERSION-LOOP
  19544. C
  19545. C       CALCULATE INVERSE(A) BY MEANS OF INVERSE(T)
  19546. C       INVERSE(A) = INVERSE(T) * TRANSPOSE(INVERSE(T))
  19547. C       INITIALIZE MULTIPLICATION-LOOP
  19548.     DO 8 I=1,N
  19549.     IPIV=IPIV+I
  19550.     J=IPIV
  19551. C
  19552. C       INITIALIZE ROW-LOOP
  19553.     DO 8 K=I,N
  19554.     WORK=0.D0
  19555.     LHOR=J
  19556. C
  19557. C       START INNER LOOP
  19558.     DO 7 L=K,N
  19559.     LVER=LHOR+K-I
  19560.     WORK=WORK+A(LHOR)*A(LVER)
  19561. 7    LHOR=LHOR+L
  19562. C       END OF INNER LOOP
  19563. C
  19564.     A(J)=WORK
  19565. 8    J=J+K
  19566. C       END OF ROW- AND MULTIPLICATION-LOOP
  19567. C
  19568. 9    RETURN
  19569.     END
  19570. C
  19571. C    ..................................................................
  19572. C
  19573. C       SUBROUTINE DTCNP
  19574. C
  19575. C       PURPOSE
  19576. C          A SERIES EXPANSION IN CHEBYSHEV POLYNOMIALS WITH INDEPENDENT
  19577. C          VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
  19578. C          VARIABLE Z, WHERE X=A*Z+B.
  19579. C
  19580. C       USAGE
  19581. C          CALL DTCNP(A,B,POL,N,C,WORK)
  19582. C
  19583. C       DESCRIPTION OF PARAMETERS
  19584. C          A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
  19585. C                  DOUBLE PRECISION VARIABLE
  19586. C          B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
  19587. C                  DOUBLE PRECISION VARIABLE
  19588. C          POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
  19589. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  19590. C                  DOUBLE PRECISION VECTOR
  19591. C          N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
  19592. C          C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
  19593. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  19594. C                  POL AND C MAY BE IDENTICALLY LOCATED
  19595. C                  DOUBLE PRECISION VECTOR
  19596. C          WORK  - WORKING STORAGE OF DIMENSION 2*N
  19597. C                  DOUBLE PRECISION ARRAY
  19598. C
  19599. C       REMARKS
  19600. C          COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
  19601. C          WITH COEFFICIENT VECTOR POL.
  19602. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1.
  19603. C          THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
  19604. C          THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
  19605. C          ZL=-(1+B)/A AND ZR=(1-B)/A.
  19606. C          FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
  19607. C
  19608. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  19609. C          NONE
  19610. C
  19611. C       METHOD
  19612. C          THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
  19613. C          FOR CHEBYSHEV POLYNOMIALS T(N,X)
  19614. C          T(N+1,X)=2*X*T(N,X)-T(N-1,X),
  19615. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  19616. C          THE SECOND IS THE ARGUMENT.
  19617. C          STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
  19618. C          THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
  19619. C          X = A*Z+B TOGETHER WITH
  19620. C          SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
  19621. C          =SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
  19622. C
  19623. C    ..................................................................
  19624. C
  19625.     SUBROUTINE DTCNP(A,B,POL,N,C,WORK)
  19626. C
  19627.     DIMENSION POL(1),C(1),WORK(1)
  19628.     DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0
  19629. C
  19630. C       TEST OF DIMENSION
  19631.     IF(N-1)2,1,3
  19632. C
  19633. C       DIMENSION LESS THAN 2
  19634. 1    POL(1)=C(1)
  19635. 2    RETURN
  19636. C
  19637. 3    POL(1)=C(1)+C(2)*B
  19638.     POL(2)=C(2)*A
  19639.     IF(N-2)2,2,4
  19640. C
  19641. C       INITIALIZATION
  19642. 4    WORK(1)=1.D0
  19643.     WORK(2)=B
  19644.     WORK(3)=0.D0
  19645.     WORK(4)=A
  19646.     XD=A+A
  19647.     X0=B+B
  19648. C
  19649. C       CALCULATE COEFFICIENT VECTOR OF NEXT CHEBYSHEV POLYNOMIAL
  19650. C       AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
  19651.     DO 6 J=3,N
  19652.     P=0.D0
  19653. C
  19654.     DO 5 K=2,J
  19655.     H=P-WORK(2*K-3)+X0*WORK(2*K-2)
  19656.     P=WORK(2*K-2)
  19657.     WORK(2*K-2)=H
  19658.     WORK(2*K-3)=P
  19659.     POL(K-1)=POL(K-1)+H*C(J)
  19660. 5    P=XD*P
  19661.     WORK(2*J-1)=0.D0
  19662.     WORK(2*J)=P
  19663. 6    POL(J)=C(J)*P
  19664.     RETURN
  19665.     END
  19666. C
  19667. C    ..................................................................
  19668. C
  19669. C       SUBROUTINE DTCSP
  19670. C
  19671. C       PURPOSE
  19672. C          A SERIES EXPANSION IN SHIFTED CHEBYSHEV POLYNOMIALS WITH
  19673. C          INDEPENDENT VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH
  19674. C          INDEPENDENT VARIABLE Z, WHERE X=A*Z+B.
  19675. C
  19676. C       USAGE
  19677. C          CALL DTCSP(A,B,POL,N,C,WORK)
  19678. C
  19679. C       DESCRIPTION OF PARAMETERS
  19680. C          A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
  19681. C                  DOUBLE PRECISION VARIABLE
  19682. C          B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
  19683. C                  DOUBLE PRECISION VARIABLE
  19684. C          POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
  19685. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  19686. C                  DOUBLE PRECISION VECTOR
  19687. C          N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
  19688. C          C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
  19689. C                  POL AND C MAY BE IDENTICALLY LOCATED
  19690. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  19691. C                  DOUBLE PRECISION VECTOR
  19692. C          WORK  - WORKING STORAGE OF DIMENSION 2*N
  19693. C                  DOUBLE PRECISION ARRAY
  19694. C
  19695. C       REMARKS
  19696. C          COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
  19697. C          WITH COEFFICIENT VECTOR POL.
  19698. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1.
  19699. C          THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
  19700. C          THE RANGE (0,1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
  19701. C          ZL=-B/A AND ZR=(1-B)/A.
  19702. C          FOR GIVEN ZL, ZR WE HAVE A=1/(ZR-ZL) AND B=-ZL/(ZR-ZL).
  19703. C
  19704. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  19705. C          NONE
  19706. C
  19707. C       METHOD
  19708. C          THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION FOR
  19709. C          SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
  19710. C          TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
  19711. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  19712. C          THE SECOND IS THE ARGUMENT.
  19713. C          STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
  19714. C          THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
  19715. C          X=A*Z+B TOGETHER WITH
  19716. C          SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
  19717. C          =SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
  19718. C
  19719. C    ..................................................................
  19720. C
  19721.     SUBROUTINE DTCSP(A,B,POL,N,C,WORK)
  19722. C
  19723.     DIMENSION POL(1),C(1),WORK(1)
  19724.     DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0
  19725. C
  19726. C       TEST OF DIMENSION
  19727.     IF(N-1)2,1,3
  19728. C
  19729. C       DIMENSION LESS THAN 2
  19730. 1    POL(1)=C(1)
  19731. 2    RETURN
  19732. C
  19733. 3    XD=A+A
  19734.     X0=B+B-1.D0
  19735.     POL(1)=C(1)+C(2)*X0
  19736.     POL(2)=C(2)*XD
  19737.     IF(N-2)2,2,4
  19738. C
  19739. C       INITIALIZATION
  19740. 4    WORK(1)=1.D0
  19741.     WORK(2)=X0
  19742.     WORK(3)=0.D0
  19743.     WORK(4)=XD
  19744.     XD=XD+XD
  19745.     X0=X0+X0
  19746. C
  19747. C       CALCULATE COEFFICIENT VECTOR OF NEXT SHIFTED CHEBYSHEV
  19748. C       POLYNOMIAL AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
  19749.     DO 6 J=3,N
  19750.     P=0.D0
  19751. C
  19752.     DO 5 K=2,J
  19753.     H=P-WORK(2*K-3)+X0*WORK(2*K-2)
  19754.     P=WORK(2*K-2)
  19755.     WORK(2*K-2)=H
  19756.     WORK(2*K-3)=P
  19757.     POL(K-1)=POL(K-1)+H*C(J)
  19758. 5    P=XD*P
  19759.     WORK(2*J-1)=0.D0
  19760.     WORK(2*J)=P
  19761. 6    POL(J)=C(J)*P
  19762.     RETURN
  19763.     END
  19764. C
  19765. C    ..................................................................
  19766. C
  19767. C       SUBROUTINE DTEAS
  19768. C
  19769. C       PURPOSE
  19770. C          CALCULATE THE LIMIT OF A GIVEN SEQUENCE BY MEANS OF THE
  19771. C          EPSILON-ALGORITHM.
  19772. C
  19773. C       USAGE
  19774. C          CALL DTEAS(X,N,FIN,EPS,IER)
  19775. C
  19776. C       DESCRIPTION OF PARAMETERS
  19777. C          X      - DOUBLE PRECISION VECTOR WHOSE COMPONENTS ARE TERMS
  19778. C                   OF THE GIVEN SEQUENCE. ON RETURN THE COMPONENTS OF
  19779. C                   VECTOR X ARE DESTROYED.
  19780. C          N      - DIMENSION OF INPUT VECTOR X.
  19781. C          FIN    - RESULTANT SCALAR IN DOUBLE PRECISION CONTAINING ON
  19782. C                   RETURN THE LIMIT OF THE GIVEN SEQUENCE.
  19783. C          EPS    - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE
  19784. C                   UPPER BOUND OF THE RELATIVE (ABSOLUTE) ERROR IF THE
  19785. C                   COMPONENTS OF X ARE ABSOLUTELY GREATER (LESS) THAN
  19786. C                   ONE.
  19787. C                   CALCULATION IS TERMINATED AS SOON AS THREE TIMES IN
  19788. C                   SUCCESSION THE RELATIVE (ABSOLUTE) DIFFERENCE
  19789. C                   BETWEEN NEIGHBOURING TERMS IS NOT GREATER THAN EPS.
  19790. C          IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
  19791. C                   FORM
  19792. C                    IER=0  - NO ERROR
  19793. C                    IER=1  - REQUIRED ACCURACY NOT REACHED WITH
  19794. C                             MAXIMAL NUMBER OF ITERATIONS
  19795. C                    IER=-1 - INTEGER N IS LESS THAN TEN.
  19796. C
  19797. C       REMARKS
  19798. C          NO ACTION BESIDES ERROR MESSAGE IN CASE N LESS THAN TEN.
  19799. C          THE CHARACTER OF THE GIVEN INFINITE SEQUENCE MUST BE
  19800. C          RECOGNIZABLE BY THOSE N COMPONENTS OF THE INPUT VECTOR X.
  19801. C
  19802. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  19803. C          NONE
  19804. C
  19805. C       METHOD
  19806. C          THE CONVERGENCE OF THE GIVEN SEQUENCE IS ACCELERATED BY
  19807. C          MEANS OF THE E(2)-TRANSFORMATION, USED IN AN ITERATIVE WAY.
  19808. C          FOR REFERENCE, SEE
  19809. C          ALGORITHM 215,SHANKS, CACM 1963, NO. 11, PP. 662. AND
  19810. C          P. WYNN, SINGULAR RULES FOR CERTAIN NON-LINEAR ALGORITHMS
  19811. C          BIT VOL. 3, 1963, PP. 175-195.
  19812. C
  19813. C    ..................................................................
  19814. C
  19815.     SUBROUTINE DTEAS(X,N,FIN,EPS,IER)
  19816. C
  19817.     DIMENSION X(1)
  19818.     DOUBLE PRECISION X,FIN,W1,W2,W3,W4,W5,W6,W7,T
  19819. C
  19820. C       TEST ON WRONG INPUT PARAMETER N
  19821. C
  19822.     NEW=N
  19823.     IF(NEW-10)1,2,2
  19824. 1    IER=-1
  19825.     RETURN
  19826. C
  19827. C       CALCULATE INITIAL VALUES FOR THE EPSILON ARRAY
  19828. C
  19829. 2    ISW1=0
  19830.     ISW2=0
  19831.     W1=1.D38
  19832.     W7=X(4)-X(3)
  19833.     IF(W7)3,4,3
  19834. 3    W1=1.D0/W7
  19835. C
  19836. 4    W5=1.D38
  19837.     W7=X(2)-X(1)
  19838.     IF(W7)5,6,5
  19839. 5    W5=1.D0/W7
  19840. C
  19841. 6    W4=X(3)-X(2)
  19842.     IF(W4)9,7,9
  19843. 7    W4=1.D38
  19844.     T=X(2)
  19845.     W2=X(3)
  19846. 8    W3=1.D38
  19847.     GO TO 17
  19848. C
  19849. 9    W4=1.D0/W4
  19850. C
  19851.     T=1.D38
  19852.     W7=W4-W5
  19853.     IF(W7)10,11,10
  19854. 10    T=X(2)+1.D0/W7
  19855. C
  19856. 11    W2=W1-W4
  19857.     IF(W2)15,12,15
  19858. 12    W2=1.D38
  19859.     IF(T-1.D38)13,14,14
  19860. 13    ISW2=1
  19861. 14    W3=W4
  19862.     GO TO 17
  19863. C
  19864. 15    W2=X(3)+1.D0/W2
  19865.     W7=W2-T
  19866.     IF(W7)16,8,16
  19867. 16    W3=W4+1.D0/W7
  19868. C
  19869. 17    ISW1=ISW2
  19870.     ISW2=0
  19871.     IMIN=4
  19872. C
  19873. C       CALCULATE DIAGONALS OF THE EPSILON ARRAY IN A DO-LOOP
  19874. C
  19875.     DO 40 I=5,NEW
  19876.     IAUS=I-IMIN
  19877.     W4=1.D38
  19878.     W5=X(I-1)
  19879.     W7=X(I)-X(I-1)
  19880.     IF(W7)18,24,18
  19881. 18    W4=1.D0/W7
  19882. C
  19883.     IF(W1-1.D38)19,25,25
  19884. 19    W6=W4-W1
  19885. C
  19886. C       TEST FOR NECESSITY OF A SINGULAR RULE
  19887. C
  19888.     IF(DABS(W6)-DABS(W4)*1.D-12)20,20,22
  19889. 20    ISW2=1
  19890.     IF(W6)22,21,22
  19891. 21    W5=1.D38
  19892.     W6=W1
  19893.     IF(W2-1.D38)28,26,26
  19894. 22    W5=X(I-1)+1.D0/W6
  19895. C
  19896. C       FIRST TEST FOR LOSS OF SIGNIFICANCE
  19897. C
  19898.     IF(DABS(W5)-DABS(X(I-1))*1.D-10)23,24,24
  19899. 23    IF(W5)36,24,36
  19900. C
  19901. 24    W7=W5-W2
  19902.     IF(W7)27,25,27
  19903. 25    W6=1.D38
  19904. 26    ISW2=0
  19905.     X(IAUS)=W2
  19906.     GO TO 37
  19907. 27    W6=W1+1.D0/W7
  19908. 28    IF(ISW1-1)33,29,29
  19909. C
  19910. C       CALCULATE X(IAUS) WITH HELP OF SINGULAR RULE
  19911. C
  19912. 29    IF(W2-1.D38)30,32,32
  19913. 30    W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2)
  19914.     IF(1.D0+W7)31,38,31
  19915. 31    X(IAUS)=W7*W2/(1.D0+W7)
  19916.     GO TO 39
  19917. C
  19918. 32    X(IAUS)=W5+T-X(I-2)
  19919.     GO TO 39
  19920. C
  19921. 33    W7=W6-W3
  19922.     IF(W7)34,38,34
  19923. 34    X(IAUS)=W2+1.D0/W7
  19924. C
  19925. C       SECOND TEST FOR LOSS OF SIGNIFICANCE
  19926. C
  19927.     IF(DABS(X(IAUS))-DABS(W2)*1.D-10)35,37,37
  19928. 35    IF(X(IAUS))36,37,36
  19929. C
  19930. 36    NEW=IAUS-1
  19931.     ISW2=0
  19932.     GO TO 41
  19933. C
  19934. 37    IF(W2-1.D38)39,38,38
  19935. 38    X(IAUS)=1.D38
  19936.     IMIN=I
  19937. C
  19938. 39    W1=W4
  19939.     T=W2
  19940.     W2=W5
  19941.     W3=W6
  19942.     ISW1=ISW2
  19943. 40    ISW2=0
  19944. C
  19945.     NEW=NEW-IMIN
  19946. C
  19947. C       TEST FOR ACCURACY
  19948. C
  19949. 41    IEND=NEW-1
  19950.     DO 47 I=1,IEND
  19951.     HE1=DABS(X(I)-X(I+1))
  19952.     HE2=DABS(X(I+1))
  19953.     IF(HE1-EPS)44,44,42
  19954. 42    IF(HE2-1.)46,46,43
  19955. 43    IF(HE1-EPS*HE2)44,44,46
  19956. 44    ISW2=ISW2+1
  19957.     IF(3-ISW2)45,45,47
  19958. 45    FIN=X(I)
  19959.     IER=0
  19960.     RETURN
  19961. C
  19962. 46    ISW2=0
  19963. 47    CONTINUE
  19964. C
  19965.     IF(NEW-6)48,2,2
  19966. 48    FIN=X(NEW)
  19967.     IER=1
  19968.     RETURN
  19969.     END
  19970. C
  19971. C    ..................................................................
  19972. C
  19973. C       SUBROUTINE DTEUL
  19974. C
  19975. C       PURPOSE
  19976. C          COMPUTE THE SUM OF FCT(K) FOR K FROM ONE UP TO INFINITY.
  19977. C
  19978. C       USAGE
  19979. C          CALL DTEUL(FCT,SUM,MAX,EPS,IER)
  19980. C          PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
  19981. C
  19982. C       DESCRIPTION OF PARAMETERS
  19983. C          FCT    - NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
  19984. C                   SUBPROGRAM USED. IT COMPUTES THE K-TH TERM OF THE
  19985. C                   SERIES TO ANY GIVEN INDEX K.
  19986. C          SUM    - RESULTANT VALUE IN DOUBLE PRECISION CONTAINING ON
  19987. C                   RETURN THE SUM OF THE GIVEN SERIES.
  19988. C          MAX    - INPUT VALUE, WHICH SPECIFIES THE MAXIMAL NUMBER
  19989. C                   OF TERMS OF THE SERIES THAT ARE RESPECTED.
  19990. C          EPS    - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE
  19991. C                   UPPER BOUND OF THE RELATIVE ERROR.
  19992. C                   SUMMATION IS STOPPED AS SOON AS FIVE TIMES IN
  19993. C                   SUCCESSION THE ABSOLUTE VALUE OF THE TERMS OF THE
  19994. C                   TRANSFORMED SERIES ARE FOUND TO BE LESS THAN
  19995. C                   EPS*(ABSOLUTE VALUE OF CURRENT SUM).
  19996. C          IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
  19997. C                   FORM
  19998. C                    IER=0  - NO ERROR
  19999. C                    IER=1  - REQUIRED ACCURACY NOT REACHED WITH
  20000. C                             MAXIMAL NUMBER OF TERMS
  20001. C                    IER=-1 - THE INTEGER MAX IS LESS THAN ONE.
  20002. C
  20003. C       REMARKS
  20004. C          NO ACTION BESIDES ERROR MESSAGE IN CASE MAX LESS THAN ONE.
  20005. C
  20006. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20007. C          THE EXTERNAL FUNCTION SUBPROGRAM FCT(K) MUST BE FURNISHED
  20008. C          BY THE USER.
  20009. C
  20010. C       METHOD
  20011. C          EVALUATION IS DONE BY MEANS OF A SUITABLY REFINED EULER
  20012. C          TRANSFORMATION. FOR REFERENCE, SEE
  20013. C          F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
  20014. C          MCGRAW/HILL, NEW YORK/TORONTO/LONDON, 1956, PP.155-160, AND
  20015. C          P. NAUR, REPORT ON THE ALGORITHMIC LANGUAGE ALGOL 60,
  20016. C          CACM, VOL.3, ISS.5 (1960), PP.311.
  20017. C
  20018. C    ..................................................................
  20019. C
  20020.     SUBROUTINE DTEUL (FCT,SUM,MAX,EPS,IER)
  20021. C
  20022.     DIMENSION Y(15)
  20023.     DOUBLE PRECISION FCT,SUM,Y,AMN,AMP
  20024. C
  20025. C       TEST ON WRONG INPUT PARAMETER MAX
  20026. C
  20027.     IF(MAX)1,1,2
  20028. 1    IER=-1
  20029.     GOTO 12
  20030. C
  20031. C       INITIALIZE EULER TRANSFORMATION
  20032. C
  20033. 2    IER=1
  20034.     I=1
  20035.     M=1
  20036.     N=1
  20037.     Y(1)=FCT(N)
  20038.     SUM=Y(1)*.5D0
  20039. C
  20040. C       START EULER-LOOP
  20041. C
  20042. 3    J=0
  20043. 4    I=I+1
  20044.     IF(I-MAX)5,5,12
  20045. 5    N=I
  20046.     AMN=FCT(N)
  20047.     DO 6 K=1,M
  20048.     AMP=(AMN+Y(K))*.5D0
  20049.     Y(K)=AMN
  20050. 6    AMN=AMP
  20051. C
  20052. C       CHECK EULER TRANSFORMATION
  20053. C
  20054.     IF(DABS(AMN)-DABS(Y(M)))7,9,9
  20055. 7    IF(M-15)8,9,9
  20056. 8    M=M+1
  20057.     Y(M)=AMN
  20058.     AMN=.5D0*AMN
  20059. C
  20060. C       UPDATE SUM
  20061. C
  20062. 9    SUM=SUM+AMN
  20063.     IF(ABS(SNGL(AMN))-EPS*ABS(SNGL(SUM)))10,10,3
  20064. C
  20065. C       TEST END OF PROCEDURE
  20066. C
  20067. 10    J=J+1
  20068.     IF(J-5)4,11,11
  20069. 11    IER=0
  20070. 12    RETURN
  20071.     END
  20072. C
  20073. C    ..................................................................
  20074. C
  20075. C       SUBROUTINE DTHEP
  20076. C
  20077. C       PURPOSE
  20078. C          A SERIES EXPANSION IN HERMITE POLYNOMIALS WITH INDEPENDENT
  20079. C          VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
  20080. C          VARIABLE Z, WHERE X=A*Z+B
  20081. C
  20082. C       USAGE
  20083. C          CALL DTHEP(A,B,POL,N,C,WORK)
  20084. C
  20085. C       DESCRIPTION OF PARAMETERS
  20086. C          A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
  20087. C                  DOUBLE PRECISION VARIABLE
  20088. C          B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
  20089. C                  DOUBLE PRECISION VARIABLE
  20090. C          POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
  20091. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20092. C                  DOUBLE PRECISION VECTOR
  20093. C          N     - DIMENSION OF COEFFICIENT VECTOR POL AND C
  20094. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  20095. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20096. C                  POL AND C MAY BE IDENTICALLY LOCATED
  20097. C                  DOUBLE PRECISION VECTOR
  20098. C          WORK  - WORKING STORAGE OF DIMENSION 2*N
  20099. C                  DOUBLE PRECISION ARRAY
  20100. C
  20101. C       REMARKS
  20102. C          COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
  20103. C          WITH COEFFICIENT VECTOR POL.
  20104. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1.
  20105. C          THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
  20106. C          THE RANGE (-C,C) IN X TO THE RANGE (ZL,ZR) IN Z WHERE
  20107. C          ZL=-(C+B)/A AND ZR=(C-B)/A.
  20108. C          FOR GIVEN ZL, ZR AND C WE HAVE A=2C/(ZR-ZL) AND
  20109. C          B=-C(ZR+ZL)/(ZR-ZL)
  20110. C
  20111. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20112. C          NONE
  20113. C
  20114. C       METHOD
  20115. C          THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
  20116. C          FOR HERMITE POLYNOMIALS H(N,X)
  20117. C          H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)),
  20118. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX
  20119. C          THE SECOND IS THE ARGUMENT.
  20120. C          STARTING VALUES ARE H(0,X)=1,H(1,X)=2*X.
  20121. C          THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
  20122. C          X=A*Z+B TOGETHER WITH
  20123. C          SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
  20124. C          =SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
  20125. C
  20126. C    ..................................................................
  20127. C
  20128.     SUBROUTINE DTHEP(A,B,POL,N,C,WORK)
  20129. C
  20130.     DIMENSION POL(1),C(1),WORK(1)
  20131.     DOUBLE PRECISION A,B,POL,C,WORK,H,P,FI,XD,X0
  20132. C
  20133. C       TEST OF DIMENSION
  20134.     IF(N-1)2,1,3
  20135. C
  20136. C       DIMENSION LESS THAN 2
  20137. 1    POL(1)=C(1)
  20138. 2    RETURN
  20139. C
  20140. 3    XD=A+A
  20141.     X0=B+B
  20142.     POL(1)=C(1)+C(2)*X0
  20143.     POL(2)=C(2)*XD
  20144.     IF(N-2)2,2,4
  20145. C
  20146. C       INITIALIZATION
  20147. 4    WORK(1)=1.D0
  20148.     WORK(2)=X0
  20149.     WORK(3)=0.D0
  20150.     WORK(4)=XD
  20151.     FI=2.D0
  20152. C
  20153. C       CALCULATE COEFFICIENT VECTOR OF NEXT HERMITE POLYNOMIAL
  20154. C       AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
  20155.     DO 6 J=3,N
  20156.     P=0.D0
  20157. C
  20158.     DO 5 K=2,J
  20159.     H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3)
  20160.     P=WORK(2*K-2)
  20161.     WORK(2*K-2)=H
  20162.     WORK(2*K-3)=P
  20163. 5    POL(K-1)=POL(K-1)+H*C(J)
  20164.     WORK(2*J-1)=0.D0
  20165.     WORK(2*J)=P*XD
  20166.     FI=FI+2.D0
  20167. 6    POL(J)=C(J)*WORK(2*J)
  20168.     RETURN
  20169.     END
  20170. C
  20171. C    ..................................................................
  20172. C
  20173. C       SUBROUTINE DTLAP
  20174. C
  20175. C       PURPOSE
  20176. C          A SERIES EXPANSION IN LAGUERRE POLYNOMIALS WITH INDEPENDENT
  20177. C          VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
  20178. C          VARIABLE Z, WHERE X=A*Z+B
  20179. C
  20180. C       USAGE
  20181. C          CALL DTLAP(A,B,POL,N,C,WORK)
  20182. C
  20183. C       DESCRIPTION OF PARAMETERS
  20184. C          A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
  20185. C                  DOUBLE PRECISION VARIABLE
  20186. C          B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
  20187. C                  DOUBLE PRECISION VARIABLE
  20188. C          POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
  20189. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20190. C                  DOUBLE PRECISION VECTOR
  20191. C          N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
  20192. C          C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
  20193. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20194. C                  POL AND C MAY BE IDENTICALLY LOCATED
  20195. C                  DOUBLE PRECISION VECTOR
  20196. C          WORK  - WORKING STORAGE OF DIMENSION 2*N
  20197. C                  DOUBLE PRECISION ARRAY
  20198. C
  20199. C       REMARKS
  20200. C          COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
  20201. C          WITH COEFFICIENT VECTOR POL.
  20202. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1.
  20203. C          THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
  20204. C          THE RANGE (0,C) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
  20205. C          ZL=-B/A AND ZR=(C-B)/A.
  20206. C          FOR GIVEN ZL, ZR AND C WE HAVE A=C/(ZR-ZL) AND
  20207. C          B=-C*ZL/(ZR-ZL)
  20208. C
  20209. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20210. C          NONE
  20211. C
  20212. C       METHOD
  20213. C          THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
  20214. C          FOR LAGUERRE POLYNOMIALS L(N,X)
  20215. C          L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
  20216. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  20217. C          THE SECOND IS THE ARGUMENT.
  20218. C          STARTING VALUES ARE L(0,X)=1, L(1,X)=1-X.
  20219. C          THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
  20220. C          X=A*Z+B TOGETHER WITH
  20221. C          SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
  20222. C          =SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
  20223. C
  20224. C    ..................................................................
  20225. C
  20226.     SUBROUTINE DTLAP(A,B,POL,N,C,WORK)
  20227. C
  20228.     DIMENSION POL(1),C(1),WORK(1)
  20229.     DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,Q2,FI
  20230. C
  20231. C       TEST OF DIMENSION
  20232.     IF(N-1)2,1,3
  20233. C
  20234. C       DIMENSION LESS THAN 2
  20235. 1    POL(1)=C(1)
  20236. 2    RETURN
  20237. C
  20238. 3    POL(1)=C(1)+C(2)-B*C(2)
  20239.     POL(2)=-C(2)*A
  20240.     IF(N-2)2,2,4
  20241. C
  20242. C       INITIALIZATION
  20243. 4    WORK(1)=1.D0
  20244.     WORK(2)=1.D0-B
  20245.     WORK(3)=0.D0
  20246.     WORK(4)=-A
  20247.     FI=1.D0
  20248. C
  20249. C       CALCULATE COEFFICIENT VECTOR OF NEXT LAGUERRE POLYNOMIAL
  20250. C       AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
  20251.     DO 6 J=3,N
  20252.     FI=FI+1.D0
  20253.     Q=1.D0/FI
  20254.     Q1=Q-1.D0
  20255.     Q2=1.D0-Q1-B*Q
  20256.     Q=Q*A
  20257.     P=0.D0
  20258. C
  20259.     DO 5 K=2,J
  20260.     H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1
  20261.     P=WORK(2*K-2)
  20262.     WORK(2*K-2)=H
  20263.     WORK(2*K-3)=P
  20264. 5    POL(K-1)=POL(K-1)+H*C(J)
  20265.     WORK(2*J-1)=0.D0
  20266.     WORK(2*J)=-Q*P
  20267. 6    POL(J)=C(J)*WORK(2*J)
  20268.     RETURN
  20269.     END
  20270. C
  20271. C    ..................................................................
  20272. C
  20273. C       SUBROUTINE DTLEP
  20274. C
  20275. C       PURPOSE
  20276. C          A SERIES EXPANSION IN LEGENDRE POLYNOMIALS WITH INDEPENDENT
  20277. C          VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
  20278. C          VARIABLE Z, WHERE X=A*Z+B
  20279. C
  20280. C       USAGE
  20281. C          CALL DTLEP(A,B,POL,N,C,WORK)
  20282. C
  20283. C       DESCRIPTION OF PARAMETERS
  20284. C          A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
  20285. C                  DOUBLE PRECISION VARIABLE
  20286. C          B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
  20287. C                  DOUBLE PRECISION VARIABLE
  20288. C          POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
  20289. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20290. C                  DOUBLE PRECISION VECTOR
  20291. C          N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
  20292. C          C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
  20293. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  20294. C                  POL AND C MAY BE IDENTICALLY LOCATED
  20295. C                  DOUBLE PRECISION VECTOR
  20296. C          WORK  - WORKING STORAGE OF DIMENSION 2*N
  20297. C                  DOUBLE PRECISION ARRAY
  20298. C
  20299. C       REMARKS
  20300. C          COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
  20301. C          WITH COEFFICIENT VECTOR POL.
  20302. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1.
  20303. C          THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
  20304. C          THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
  20305. C          ZL=-(1+B)/A AND ZR=(1-B)/A.
  20306. C          FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
  20307. C
  20308. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20309. C          NONE
  20310. C
  20311. C       METHOD
  20312. C          THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
  20313. C          FOR LEGENDRE POLYNOMIALS P(N,X)
  20314. C          P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
  20315. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  20316. C          THE SECOND IS THE ARGUMENT.
  20317. C          STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
  20318. C          THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
  20319. C          X=A*Z+B TOGETHER WITH
  20320. C          SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
  20321. C          =SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
  20322. C
  20323. C    ..................................................................
  20324. C
  20325.     SUBROUTINE DTLEP(A,B,POL,N,C,WORK)
  20326. C
  20327.     DIMENSION POL(1),C(1),WORK(1)
  20328.     DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,FI
  20329. C
  20330. C       TEST OF DIMENSION
  20331.     IF(N-1)2,1,3
  20332. C
  20333. C       DIMENSION LESS THAN 2
  20334. 1    POL(1)=C(1)
  20335. 2    RETURN
  20336. C
  20337. 3    POL(1)=C(1)+B*C(2)
  20338.     POL(2)=A*C(2)
  20339.     IF(N-2)2,2,4
  20340. C
  20341. C       INITIALIZATION
  20342. 4    WORK(1)=1.D0
  20343.     WORK(2)=B
  20344.     WORK(3)=0.D0
  20345.     WORK(4)=A
  20346.     FI=1.D0
  20347. C
  20348. C       CALCULATE COEFFICIENT VECTOR OF NEXT LEGENDRE POLYNOMIAL
  20349. C       AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
  20350.     DO 6 J=3,N
  20351.     FI=FI+1.D0
  20352.     Q=1.D0/FI-1.D0
  20353.     Q1=1.D0-Q
  20354.     P=0.D0
  20355. C
  20356.     DO 5 K=2,J
  20357.     H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3)
  20358.     P=WORK(2*K-2)
  20359.     WORK(2*K-2)=H
  20360.     WORK(2*K-3)=P
  20361. 5    POL(K-1)=POL(K-1)+H*C(J)
  20362.     WORK(2*J-1)=0.D0
  20363.     WORK(2*J)=A*P*Q1
  20364. 6    POL(J)=C(J)*WORK(2*J)
  20365.     RETURN
  20366.     END
  20367. C
  20368. C    ..................................................................
  20369. C
  20370. C       SUBROUTINE EIGEN
  20371. C
  20372. C       PURPOSE
  20373. C          COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
  20374. C          MATRIX
  20375. C
  20376. C       USAGE
  20377. C          CALL EIGEN(A,R,N,MV)
  20378. C
  20379. C       DESCRIPTION OF PARAMETERS
  20380. C          A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION.
  20381. C              RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF
  20382. C              MATRIX A IN DESCENDING ORDER.
  20383. C          R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE,
  20384. C              IN SAME SEQUENCE AS EIGENVALUES)
  20385. C          N - ORDER OF MATRICES A AND R
  20386. C          MV- INPUT CODE
  20387. C                  0   COMPUTE EIGENVALUES AND EIGENVECTORS
  20388. C                  1   COMPUTE EIGENVALUES ONLY (R NEED NOT BE
  20389. C                      DIMENSIONED BUT MUST STILL APPEAR IN CALLING
  20390. C                      SEQUENCE)
  20391. C
  20392. C       REMARKS
  20393. C          ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1)
  20394. C          MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R
  20395. C
  20396. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20397. C          NONE
  20398. C
  20399. C       METHOD
  20400. C          DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED
  20401. C          BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN 'MATHEMATICAL
  20402. C          METHODS FOR DIGITAL COMPUTERS', EDITED BY A. RALSTON AND
  20403. C          H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7
  20404. C
  20405. C    ..................................................................
  20406. C
  20407.     SUBROUTINE EIGEN(A,R,N,MV)
  20408.     DIMENSION A(1),R(1)
  20409. C
  20410. C       ...............................................................
  20411. C
  20412. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  20413. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  20414. C       STATEMENT WHICH FOLLOWS.
  20415. C
  20416. C    DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX,
  20417. C    1                 COSX2,SINCS,RANGE
  20418. C
  20419. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  20420. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  20421. C       ROUTINE.
  20422. C
  20423. C       THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
  20424. C       CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
  20425. C       40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT.  ABS IN STATEMENT
  20426. C       62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD
  20427. C       BE CHANGED TO 1.0D-12.
  20428. C
  20429. C       ...............................................................
  20430. C
  20431. C       GENERATE IDENTITY MATRIX
  20432. C
  20433. 5    RANGE=1.0E-6
  20434.     IF(MV-1) 10,25,10
  20435. 10    IQ=-N
  20436.     DO 20 J=1,N
  20437.     IQ=IQ+N
  20438.     DO 20 I=1,N
  20439.     IJ=IQ+I
  20440.     R(IJ)=0.0
  20441.     IF(I-J) 20,15,20
  20442. 15    R(IJ)=1.0
  20443. 20    CONTINUE
  20444. C
  20445. C       COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX)
  20446. C
  20447. 25    ANORM=0.0
  20448.     DO 35 I=1,N
  20449.     DO 35 J=I,N
  20450.     IF(I-J) 30,35,30
  20451. 30    IA=I+(J*J-J)/2
  20452.     ANORM=ANORM+A(IA)*A(IA)
  20453. 35    CONTINUE
  20454.     IF(ANORM) 165,165,40
  20455. 40    ANORM=1.414*SQRT(ANORM)
  20456.     ANRMX=ANORM*RANGE/FLOAT(N)
  20457. C
  20458. C       INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR
  20459. C
  20460.     IND=0
  20461.     THR=ANORM
  20462. 45    THR=THR/FLOAT(N)
  20463. 50    L=1
  20464. 55    M=L+1
  20465. C
  20466. C       COMPUTE SIN AND COS
  20467. C
  20468. 60    MQ=(M*M-M)/2
  20469.     LQ=(L*L-L)/2
  20470.     LM=L+MQ
  20471. 62    IF( ABS(A(LM))-THR) 130,65,65
  20472. 65    IND=1
  20473.     LL=L+LQ
  20474.     MM=M+MQ
  20475.     X=0.5*(A(LL)-A(MM))
  20476. 68    Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X)
  20477.     IF(X) 70,75,75
  20478. 70    Y=-Y
  20479. 75    SINX=Y/ SQRT(2.0*(1.0+( SQRT(1.0-Y*Y))))
  20480.     SINX2=SINX*SINX
  20481. 78    COSX= SQRT(1.0-SINX2)
  20482.     COSX2=COSX*COSX
  20483.     SINCS =SINX*COSX
  20484. C
  20485. C       ROTATE L AND M COLUMNS
  20486. C
  20487.     ILQ=N*(L-1)
  20488.     IMQ=N*(M-1)
  20489.     DO 125 I=1,N
  20490.     IQ=(I*I-I)/2
  20491.     IF(I-L) 80,115,80
  20492. 80    IF(I-M) 85,115,90
  20493. 85    IM=I+MQ
  20494.     GO TO 95
  20495. 90    IM=M+IQ
  20496. 95    IF(I-L) 100,105,105
  20497. 100    IL=I+LQ
  20498.     GO TO 110
  20499. 105    IL=L+IQ
  20500. 110    X=A(IL)*COSX-A(IM)*SINX
  20501.     A(IM)=A(IL)*SINX+A(IM)*COSX
  20502.     A(IL)=X
  20503. 115    IF(MV-1) 120,125,120
  20504. 120    ILR=ILQ+I
  20505.     IMR=IMQ+I
  20506.     X=R(ILR)*COSX-R(IMR)*SINX
  20507.     R(IMR)=R(ILR)*SINX+R(IMR)*COSX
  20508.     R(ILR)=X
  20509. 125    CONTINUE
  20510.     X=2.0*A(LM)*SINCS
  20511.     Y=A(LL)*COSX2+A(MM)*SINX2-X
  20512.     X=A(LL)*SINX2+A(MM)*COSX2+X
  20513.     A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2)
  20514.     A(LL)=Y
  20515.     A(MM)=X
  20516. C
  20517. C       TESTS FOR COMPLETION
  20518. C
  20519. C       TEST FOR M = LAST COLUMN
  20520. C
  20521. 130    IF(M-N) 135,140,135
  20522. 135    M=M+1
  20523.     GO TO 60
  20524. C
  20525. C       TEST FOR L = SECOND FROM LAST COLUMN
  20526. C
  20527. 140    IF(L-(N-1)) 145,150,145
  20528. 145    L=L+1
  20529.     GO TO 55
  20530. 150    IF(IND-1) 160,155,160
  20531. 155    IND=0
  20532.     GO TO 50
  20533. C
  20534. C       COMPARE THRESHOLD WITH FINAL NORM
  20535. C
  20536. 160    IF(THR-ANRMX) 165,165,45
  20537. C
  20538. C       SORT EIGENVALUES AND EIGENVECTORS
  20539. C
  20540. 165    IQ=-N
  20541.     DO 185 I=1,N
  20542.     IQ=IQ+N
  20543.     LL=I+(I*I-I)/2
  20544.     JQ=N*(I-2)
  20545.     DO 185 J=I,N
  20546.     JQ=JQ+N
  20547.     MM=J+(J*J-J)/2
  20548.     IF(A(LL)-A(MM)) 170,185,185
  20549. 170    X=A(LL)
  20550.     A(LL)=A(MM)
  20551.     A(MM)=X
  20552.     IF(MV-1) 175,185,175
  20553. 175    DO 180 K=1,N
  20554.     ILR=IQ+K
  20555.     IMR=JQ+K
  20556.     X=R(ILR)
  20557.     R(ILR)=R(IMR)
  20558. 180    R(IMR)=X
  20559. 185    CONTINUE
  20560.     RETURN
  20561.     END
  20562. C
  20563. C    ..................................................................
  20564. C
  20565. C       SUBROUTINE ELI1
  20566. C
  20567. C       PURPOSE
  20568. C          COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND
  20569. C
  20570. C       USAGE
  20571. C          CALL ELI1(RES,X,CK)
  20572. C
  20573. C       DESCRIPTION OF PARAMETERS
  20574. C          RES   - RESULT VALUE
  20575. C          X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
  20576. C                  INTEGRAL OF FIRST KIND)
  20577. C          CK    - COMPLEMENTARY MODULUS
  20578. C
  20579. C       REMARKS
  20580. C          MODULUS K = SQRT(1.-CK*CK).
  20581. C
  20582. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20583. C          NONE
  20584. C
  20585. C       METHOD
  20586. C          DEFINITION
  20587. C          RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
  20588. C          OVER T FROM 0 TO X).
  20589. C          EQUIVALENT ARE THE DEFINITIONS
  20590. C          RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED
  20591. C          OVER T FROM 0 TO ATAN(X)),
  20592. C          RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER
  20593. C          T FROM 0 TO ATAN(X)).
  20594. C          EVALUATION
  20595. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  20596. C          REFERENCE
  20597. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  20598. C                 ELLIPTIC FUNCTIONS.
  20599. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  20600. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  20601. C
  20602. C    ..................................................................
  20603. C
  20604.     SUBROUTINE ELI1(RES,X,CK)
  20605. C
  20606.     IF(X)2,1,2
  20607. 1    RES=0.
  20608.     RETURN
  20609. 2    IF(CK)4,3,4
  20610. 3    RES=ALOG(ABS(X)+SQRT(1.+X*X))
  20611.     GOTO 13
  20612. 4    ANGLE=ABS(1./X)
  20613.     GEO=ABS(CK)
  20614.     ARI=1.
  20615.     PIM=0.
  20616. 5    SQGEO=ARI*GEO
  20617.     AARI=ARI
  20618.     ARI=GEO+ARI
  20619.     ANGLE=-SQGEO/ANGLE+ANGLE
  20620.     SQGEO=SQRT(SQGEO)
  20621.     IF(ANGLE)7,6,7
  20622. C    REPLACE 0 BY SMALL VALUE
  20623. 6    ANGLE=SQGEO*1.E-8
  20624. 7    TEST=AARI*1.E-4
  20625.     IF(ABS(AARI-GEO)-TEST)10,10,8
  20626. 8    GEO=SQGEO+SQGEO
  20627.     PIM=PIM+PIM
  20628.     IF(ANGLE)9,5,5
  20629. 9    PIM=PIM+3.1415927
  20630.     GOTO 5
  20631. 10    IF(ANGLE)11,12,12
  20632. 11    PIM=PIM+3.1415927
  20633. 12    RES=(ATAN(ARI/ANGLE)+PIM)/ARI
  20634. 13    IF(X)14,15,15
  20635. 14    RES=-RES
  20636. 15    RETURN
  20637.     END
  20638. C
  20639. C    ..................................................................
  20640. C
  20641. C       SUBROUTINE ELI2
  20642. C
  20643. C       PURPOSE
  20644. C          COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND
  20645. C
  20646. C       USAGE
  20647. C          CALL ELI2(R,X,CK,A,B)
  20648. C
  20649. C       DESCRIPTION OF PARAMETERS
  20650. C          R     - RESULT VALUE
  20651. C          X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
  20652. C                  INTEGRAL OF SECOND KIND)
  20653. C          CK    - COMPLEMENTARY MODULUS
  20654. C          A     - CONSTANT TERM IN NUMERATOR
  20655. C          B     - QUADRATIC TERM IN NUMERATOR
  20656. C
  20657. C       REMARKS
  20658. C          MODULUS K = SQRT(1.-CK*CK).
  20659. C          SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF
  20660. C          SECOND KIND ARE
  20661. C          F(ATAN(X),K) OBTAINED WITH A=1., B=1.
  20662. C          E(ATAN(X),K) OBTAINED WITH A=1., B=CK*CK.
  20663. C          B(ATAN(X),K) OBTAINED WITH A=1., B=0.
  20664. C          D(ATAN(X),K) OBTAINED WITH A=0., B=1.
  20665. C
  20666. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20667. C          NONE
  20668. C
  20669. C       METHOD
  20670. C          DEFINITION
  20671. C          R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)),
  20672. C                 SUMMED OVER T FROM 0 TO X).
  20673. C          EQUIVALENT IS THE DEFINITION
  20674. C          R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2),
  20675. C                 SUMMED OVER T FROM 0 TO ATAN(X)).
  20676. C          EVALUATION
  20677. C          LANDENS TRANSFORMATION IS USED FOR CALCULATION.
  20678. C          REFERENCE
  20679. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  20680. C                 ELLIPTIC FUNCTIONS
  20681. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  20682. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  20683. C
  20684. C    ..................................................................
  20685. C
  20686.     SUBROUTINE ELI2(R,X,CK,A,B)
  20687. C       TEST ARGUMENT
  20688.     IF(X)2,1,2
  20689. 1    R=0.
  20690.     RETURN
  20691. C       TEST MODULUS
  20692. 2    C=0.
  20693.     D=0.5
  20694.     IF(CK)7,3,7
  20695. 3    R=SQRT(1.+X*X)
  20696.     R=(A-B)*ABS(X)/R+B*ALOG(ABS(X)+R)
  20697. C       TEST SIGN OF ARGUMENT
  20698. 4    R=R+C*(A-B)
  20699.     IF(X)5,6,6
  20700. 5    R=-R
  20701. 6    RETURN
  20702. C       INITIALIZATION
  20703. 7    AN=(B+A)*0.5
  20704.     AA=A
  20705.     R=B
  20706.     ANG=ABS(1./X)
  20707.     PIM=0.
  20708.     ISI=0
  20709.     ARI=1.
  20710.     GEO=ABS(CK)
  20711. C       LANDEN TRANSFORMATION
  20712. 8    R=AA*GEO+R
  20713.     SGEO=ARI*GEO
  20714.     AA=AN
  20715.     AARI=ARI
  20716. C       ARITHMETIC MEAN
  20717.     ARI=GEO+ARI
  20718. C       SUM OF SINE VALUES
  20719.     AN=(R/ARI+AA)*0.5
  20720.     AANG=ABS(ANG)
  20721.     ANG=-SGEO/ANG+ANG
  20722.     PIMA=PIM
  20723.     IF(ANG)10,9,11
  20724. 9    ANG=-1.E-8*AANG
  20725. 10    PIM=PIM+3.1415927
  20726.     ISI=ISI+1
  20727. 11    AANG=ARI*ARI+ANG*ANG
  20728.     P=D/SQRT(AANG)
  20729.     IF(ISI-4)13,12,12
  20730. 12    ISI=ISI-4
  20731. 13    IF(ISI-2)15,14,14
  20732. 14    P=-P
  20733. 15    C=C+P
  20734.     D=D*(AARI-GEO)*0.5/ARI
  20735.     IF(ABS(AARI-GEO)-1.E-4*AARI)17,17,16
  20736. 16    SGEO=SQRT(SGEO)
  20737. C       GEOMETRIC MEAN
  20738.     GEO=SGEO+SGEO
  20739.     PIM=PIM+PIMA
  20740.     ISI=ISI+ISI
  20741.     GOTO 8
  20742. C       ACCURACY WAS SUFFICIENT
  20743. 17    R=(ATAN(ARI/ANG)+PIM)*AN/ARI
  20744.     C=C+D*ANG/AANG
  20745.     GOTO 4
  20746.     END
  20747. C
  20748. C    ..................................................................
  20749. C
  20750. C       SUBROUTINE EXPI
  20751. C
  20752. C       PURPOSE
  20753. C          COMPUTES THE EXPONENTIAL INTEGRAL -EI(-X)
  20754. C
  20755. C       USAGE
  20756. C          CALL EXPI(X,RES)
  20757. C
  20758. C       DESCRIPTION OF PARAMETERS
  20759. C          X     - ARGUMENT OF EXPONENTIAL INTEGRAL
  20760. C          RES   - RESULT VALUE
  20761. C          AUX   - RESULTANT AUXILIARY VALUE
  20762. C
  20763. C       REMARKS
  20764. C          X GT 170 (X LT -174) MAY CAUSE UNDERFLOW (OVERFLOW)
  20765. C          WITH THE EXPONENTIAL FUNCTION
  20766. C          FOR X = 0 THE RESULT VALUE IS SET TO -1.7E38                        0
  20767. C
  20768. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20769. C          NONE
  20770. C
  20771. C       METHOD
  20772. C          DEFINITION
  20773. C          RES=INTEGRAL(EXP(-T)/T, SUMMED OVER T FROM X TO INFINITY).
  20774. C          EVALUATION
  20775. C          THREE DIFFERENT RATIONAL APPROXIMATIONS ARE USED IN THE
  20776. C          RANGES 1 LE X, X LE -9 AND -9 LT X LE -3 RESPECTIVELY,
  20777. C          A POLYNOMIAL APPROXIMATION IS USED IN -3 LT X LT 1.
  20778. C
  20779. C    ..................................................................
  20780. C
  20781.     SUBROUTINE EXPI(X,RES,AUX)
  20782.     IF(X-1.)2,1,1
  20783. 1    Y=1./X
  20784.     AUX=1.-Y*(((Y+3.377358E0)*Y+2.052156E0)*Y+2.709479E-1)/((((Y*
  20785.      11.072553E0+5.716943E0)*Y+6.945239E0)*Y+2.593888E0)*Y+2.709496E-1)
  20786.     RES=AUX*Y*EXP(-X)
  20787.     RETURN
  20788. 2    IF(X+3.)6,6,3
  20789. 3    AUX=(((((((7.122452E-7*X-1.766345E-6)*X+2.928433E-5)*X-2.335379E-4
  20790.      1)*X+1.664156E-3)*X-1.041576E-2)*X+5.555682E-2)*X-2.500001E-1)*X
  20791.      2+9.999999E-1
  20792.     RES=-1.7E38                                                               0
  20793.     IF(X)4,5,4
  20794. 4    RES=X*AUX-ALOG(ABS(X))-5.772157E-1
  20795. 5    RETURN
  20796. 6    IF(X+9.)8,8,7
  20797. 7    AUX=1.-((((5.176245E-2*X+3.061037E0)*X+3.243665E1)*X+2.244234E2)*X
  20798.      1+2.486697E2)/((((X+3.995161E0)*X+3.893944E1)*X+2.263818E1)*X
  20799.      2+1.807837E2)
  20800.     GOTO 9
  20801. 8    Y=9./X
  20802.     AUX=1.-Y*(((Y+7.659824E-1)*Y-7.271015E-1)*Y-1.080693E0)/((((Y
  20803.      1*2.518750E0+1.122927E1)*Y+5.921405E0)*Y-8.666702E0)*Y-9.724216E0)
  20804. 9    RES=AUX*EXP(-X)/X
  20805.     RETURN
  20806.     END
  20807. C
  20808. C    ..................................................................
  20809. C
  20810. C       SAMPLE MAIN PROGRAM FOR TRIPLE EXPONENTIAL SMOOTHING - EXPON
  20811. C
  20812. C       PURPOSE
  20813. C          (1) READ THE PROBLEM PARAMETER CARD AND A TIME SERIES,
  20814. C          (2) CALL THE SUBROUTINE EXSMO TO SMOOTH THE TIME SERIES,
  20815. C          AND (3) PRINT THE RESULT.
  20816. C
  20817. C       REMARKS
  20818. C          A SMOOTHING CONSTANT SPECIFIED IN THE PROBLEM PARAMETER
  20819. C          CARD MUST BE GREATER THAN ZERO BUT LESS THAN ONE IN ORDER
  20820. C          TO OBTAIN REASONABLE RESULTS.
  20821. C
  20822. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20823. C          EXSMO
  20824. C
  20825. C       METHOD
  20826. C          REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION
  20827. C          OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963,
  20828. C          PP. 140 TO 144.
  20829. C
  20830. C    ..................................................................
  20831. cC
  20832. cC    THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
  20833. cC    NUMBER OF DATA POINTS IN A GIVEN TIME SERIES..
  20834. cC
  20835. cc       DIMENSION X(1000),S(1000)
  20836. cC
  20837. cC    ..................................................................
  20838. cC
  20839. c1    FORMAT(A4,A2,I4,F5.0,3F10.0)
  20840. c2    FORMAT(12F6.0)
  20841. c3    FORMAT(34H1TRIPLE EXPONENTIAL SMOOTHING.....,A4,A2//22H NUMBER OF 
  20842. c     1DATA POINTS,I6/19H SMOOTHING CONSTANT,F9.3/)
  20843. c4    FORMAT(13H0COEFFICIENTS,9X,1HA,14X,1HB,14X,1HC)
  20844. c5    FORMAT(9H0ORIGINAL,F19.5,2F15.5)
  20845. c6    FORMAT(8H0UPDATED,F20.5,2F15.5/)
  20846. c7    FORMAT(1H0,27X,13HSMOOTHED DATA/7X,10HINPUT DATA,12X,10H(FORECAST)
  20847. c     1)
  20848. c8    FORMAT(F17.5,8X,F15.5)
  20849. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  20850. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  20851. cC
  20852. cC    ..................................................................
  20853. cC
  20854. cC    READ PROBLEM PARAMETER CARD
  20855. cC
  20856. c    LOGICAL EOF
  20857. c    CALL CHKEOF (EOF)
  20858. c100    READ (5,1) PR,PR1,NX,AL,A,B,C
  20859. c    IF (EOF) GOTO 999
  20860. cC       PR......PROBLEM NUMBER (MAY BE ALPHAMERIC)
  20861. cC       PR1.....PROBLEM NUMBER (CONTINUED)
  20862. cC       NX......NUMBER OF DATA POINTS IN TIME SERIES
  20863. cC       AL......SMOOTHING CONSTANT
  20864. cC       A,B,C...COEFFICIENTS OF THE PREDICTION EQUATION
  20865. cC
  20866. c    WRITE (6,3) PR,PR1,NX,AL
  20867. cC
  20868. cC    PRINT ORIGINAL COEFFICIENTS
  20869. cC
  20870. c    WRITE (6,4)
  20871. c    WRITE (6,5) A,B,C
  20872. cC
  20873. cC    READ TIME SERIES DATA
  20874. cC
  20875. c    READ (5,2) (X(I),I=1,NX)
  20876. cC
  20877. c    CALL EXSMO (X,NX,AL,A,B,C,S)
  20878. cC
  20879. cC    PRINT UPDATED COEFFICIENTS
  20880. cC
  20881. c    WRITE (6,6) A,B,C
  20882. cC
  20883. cC    PRINT INPUT AND SMOOTHED DATA
  20884. cC
  20885. c    WRITE (6,7)
  20886. c    DO 200 I=1,NX
  20887. c200    WRITE (6,8) X(I),S(I)
  20888. c    GO TO 100
  20889. c999    STOP
  20890. c    END
  20891. cC
  20892. C    ..................................................................
  20893. C
  20894. C       SUBROUTINE EXSMO
  20895. C
  20896. C       PURPOSE
  20897. C          TO FIND THE TRIPLE EXPONENTIAL SMOOTHED SERIES S OF THE
  20898. C          GIVEN SERIES X.
  20899. C
  20900. C       USAGE
  20901. C          CALL EXSMO (X,NX,AL,A,B,C,S)
  20902. C
  20903. C       DESCRIPTION OF PARAMETERS
  20904. C          X     - INPUT VECTOR OF LENGTH NX CONTAINING TIME SERIES
  20905. C                  DATA WHICH IS TO BE EXPONENTIALLY SMOOTHED.
  20906. C          NX    - THE NUMBER OF ELEMENTS IN X.
  20907. C          AL    - SMOOTHING CONSTANT, ALPHA.  AL MUST BE GREATER THAN
  20908. C                  ZERO AND LESS THAN ONE.
  20909. C          A,B,C - COEFFICIENTS OF THE PREDICTION EQUATION WHERE S IS
  20910. C                  PREDICTED T PERIODS HENCE BY
  20911. C                                A + B*T + C*T*T/2.
  20912. C                  AS INPUT-- IF A=B=C=0, PROGRAM WILL PROVIDE INITIAL
  20913. C                  VALUES.  IF AT LEAST ONE OF A,B,C IS NOT ZERO,
  20914. C                  PROGRAM WILL TAKE GIVEN VALUES AS INITIAL VALUES.
  20915. C                  AS OUTPUT-- A,B,C CONTAIN LATEST, UPDATED COEFFI-
  20916. C                  CIENTS OF PREDICTION.
  20917. C          S     - OUTPUT VECTOR OF LENGTH NX CONTAINING TRIPLE
  20918. C                  EXPONENTIALLY SMOOTHED TIME SERIES.
  20919. C
  20920. C       REMARKS
  20921. C          NONE
  20922. C
  20923. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20924. C          NONE
  20925. C
  20926. C       METHOD
  20927. C          REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION
  20928. C          OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963,
  20929. C          PP. 140 TO 144.
  20930. C
  20931. C    ..................................................................
  20932. C
  20933.     SUBROUTINE EXSMO (X,NX,AL,A,B,C,S)
  20934.     DIMENSION X(1),S(1)
  20935. C
  20936. C    IF A=B=C=0.0, GENERATE INITIAL VALUES OF A, B, AND C
  20937. C
  20938.     IF(A) 140, 110, 140
  20939. 110    IF(B) 140, 120, 140
  20940. 120    IF(C) 140, 130, 140
  20941. 130    C=X(1)-2.0*X(2)+X(3)
  20942.     B=X(2)-X(1)-1.5*C
  20943.     A=X(1)-B-0.5*C
  20944. C
  20945. 140    BE=1.0-AL
  20946.     BECUB=BE*BE*BE
  20947.     ALCUB=AL*AL*AL
  20948. C
  20949. C    DO THE FOLLOWING FOR I=1 TO NX
  20950. C
  20951.     DO 150 I=1,NX
  20952. C
  20953. C       FIND S(I) FOR ONE PERIOD AHEAD
  20954. C
  20955.     S(I)=A+B+0.5*C
  20956. C
  20957. C       UPDATE COEFFICIENTS A, B, AND C
  20958. C
  20959.     DIF=S(I)-X(I)
  20960.     A=X(I)+BECUB*DIF
  20961.     B=B+C-1.5*AL*AL*(2.0-AL)*DIF
  20962. 150    C=C-ALCUB*DIF
  20963.     RETURN
  20964.     END
  20965. C
  20966. C    .................................................................
  20967. C
  20968. C       SAMPLE MAIN PROGRAM FOR FACTOR ANALYSIS - FACTO
  20969. C
  20970. C       PURPOSE
  20971. C          (1) READ THE PROBLEM PARAMETER CARD, (2) CALL FIVE SUBROU-
  20972. C          TINES TO PERFORM A PRINCIPAL COMPONENT SOLUTION AND THE
  20973. C          VARIMAX ROTATION OF A FACTOR MATRIX, AND (3) PRINT THE
  20974. C          RESULTS.
  20975. C
  20976. C       REMARKS
  20977. C          NONE
  20978. C
  20979. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  20980. C          CORRE  (WHICH, IN TURN, CALLS THE SUBROUTINE NAMED DATA.)
  20981. C          EIGEN
  20982. C          TRACE
  20983. C          LOAD
  20984. C          VARMX
  20985. C
  20986. C       METHOD
  20987. C          REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
  20988. C          DIXON, UCLA, 1964.
  20989. C
  20990. C    ..................................................................
  20991. C
  20992. C    THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
  20993. C    NUMBER OF VARIABLES, M..
  20994. cC
  20995. c       DIMENSION B(35),D(35),S(35),T(35),XBAR(35)
  20996. cC
  20997. cC    THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
  20998. cC    PRODUCT OF M*M..
  20999. cC
  21000. c       DIMENSION V(1225)
  21001. cC
  21002. cC    THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
  21003. cC    (M+1)*M/2..
  21004. cC
  21005. c       DIMENSION R(630)
  21006. cC
  21007. cC    THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 51..
  21008. cC
  21009. c       DIMENSION TV(51)
  21010. cC
  21011. cC    ..................................................................
  21012. cC
  21013. cC       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  21014. cC       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  21015. cC       STATEMENT WHICH FOLLOWS.
  21016. cC
  21017. cC    DOUBLE PRECISION XBAR,S,V,R,D,B,T,TV
  21018. cC
  21019. cC       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  21020. cC       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  21021. cC       ROUTINE.
  21022. cC
  21023. cC       ...............................................................
  21024. cC
  21025. c1    FORMAT(21H1FACTOR ANALYSIS.....A4,A2//3X,12HNO. OF CASES,4X,I6/3X,
  21026. c     116HNO. OF VARIABLES,I6/)
  21027. c2    FORMAT(6H0MEANS/(8F15.5))
  21028. c3    FORMAT(20H0STANDARD DEVIATIONS/(8F15.5))
  21029. c4    FORMAT(25H0CORRELATION COEFFICIENTS)
  21030. c5    FORMAT(4H0ROWI3/(10F12.5))
  21031. c6    FORMAT(1H0/12H EIGENVALUES/(10F12.5))
  21032. c7    FORMAT(37H0CUMULATIVE PERCENTAGE OF EIGENVALUES/(10F12.5))
  21033. c8    FORMAT(1H0/13H EIGENVECTORS)
  21034. c9    FORMAT(7H0VECTORI3/(10F12.5))
  21035. c10    FORMAT(1H0/16H FACTOR MATRIX (,I3,9H FACTORS))
  21036. c11    FORMAT(9H0VARIABLEI3/(10F12.5))
  21037. c12    FORMAT(1H0/10H ITERATION,7X,9HVARIANCES/8H   CYCLE)
  21038. c13    FORMAT(I6,F20.6)
  21039. c14    FORMAT(1H0/24H ROTATED FACTOR MATRIX (I3,9H FACTORS))
  21040. c15    FORMAT(9H0VARIABLEI3/(10F12.5))
  21041. c16    FORMAT(1H0/23H CHECK ON COMMUNALITIES//9H VARIABLE,7X,8HORIGINAL,
  21042. c     112X,5HFINAL,10X,10HDIFFERENCE)
  21043. c17    FORMAT(I6,3F18.5)
  21044. c18    FORMAT(A4,A2,I5,I2,F6.0)
  21045. c19    FORMAT(5H0ONLY,I2,30H FACTOR RETAINED.  NO ROTATION)
  21046. cC    DOUBLE PRECISION TMPFIL,FILE
  21047. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  21048. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  21049. cC    FILE = TMPFIL('SSP')
  21050. cC    OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
  21051. cC    1    DISPOSE='DELETE')
  21052. cC
  21053. cC    ..................................................................
  21054. cC
  21055. cC    READ PROBLEM PARAMETER CARD
  21056. cC
  21057. c    LOGICAL EOF
  21058. c    CALL CHKEOF (EOF)
  21059. c100    READ (5,18) PR,PR1,N,M,CON
  21060. c    IF (EOF) GOTO 999
  21061. cC       PR.........PROBLEM NUMBER (MAY BE ALPHAMERIC)
  21062. cC       PR1........PROBLEM NUMBER (CONTINUED)
  21063. cC       N..........NUMBER OF CASES
  21064. cC       M..........NUMBER OF VARIABLES
  21065. cC       CON........CONSTANT USED TO DECIDE HOW MANY EIGENVALUES
  21066. cC                    TO RETAIN
  21067. cC
  21068. c    WRITE (6,1) PR,PR1,N,M
  21069. cC
  21070. c    IO=0
  21071. c    X=0.0
  21072. cC
  21073. c    CALL CORRE (N,M,IO,X,XBAR,S,V,R,D,B,T)
  21074. cC
  21075. cC    PRINT MEANS
  21076. cC
  21077. c    WRITE (6,2) (XBAR(J),J=1,M)
  21078. cC
  21079. cC    PRINT STANDARD DEVIATIONS
  21080. cC
  21081. c    WRITE (6,3) (S(J),J=1,M)
  21082. cC
  21083. cC    PRINT CORRELATION COEFFICIENTS
  21084. cC
  21085. c    WRITE (6,4)
  21086. c    DO 120 I=1,M
  21087. c    DO 110 J=1,M
  21088. c    IF(I-J) 102, 104, 104
  21089. c102    L=I+(J*J-J)/2
  21090. c    GO TO 110
  21091. c104    L=J+(I*I-I)/2
  21092. c110    D(J)=R(L)
  21093. c120    WRITE (6,5) I,(D(J),J=1,M)
  21094. cC
  21095. c    MV=0
  21096. c    CALL EIGEN (R,V,M,MV)
  21097. cC
  21098. c    CALL TRACE (M,R,CON,K,D)
  21099. cC
  21100. cC    PRINT EIGENVALUES
  21101. cC
  21102. c    DO 130 I=1,K
  21103. c    L=I+(I*I-I)/2
  21104. c130    S(I)=R(L)
  21105. c    WRITE (6,6) (S(J),J=1,K)
  21106. cC
  21107. cC    PRINT CUMULATIVE PERCENTAGE OF EIGENVALUES
  21108. cC
  21109. c    WRITE (6,7) (D(J),J=1,K)
  21110. cC
  21111. cC    PRINT EIGENVECTORS
  21112. cC
  21113. c    WRITE (6,8)
  21114. c    L=0
  21115. c    DO 150 J=1,K
  21116. c    DO 140 I=1,M
  21117. c    L=L+1
  21118. c140    D(I)=V(L)
  21119. c150    WRITE (6,9) J,(D(I),I=1,M)
  21120. cC
  21121. c    CALL LOAD (M,K,R,V)
  21122. cC
  21123. cC    PRINT FACTOR MATRIX
  21124. cC
  21125. c    WRITE (6,10) K
  21126. c    DO 180 I=1,M
  21127. c    DO 170 J=1,K
  21128. c    L=M*(J-1)+I
  21129. c170    D(J)=V(L)
  21130. c180    WRITE (6,11) I,(D(J),J=1,K)
  21131. cC
  21132. c    IF(K-1) 185, 185, 188
  21133. c185    WRITE (6,19) K
  21134. c    GO TO 100
  21135. cC
  21136. c188    CALL VARMX (M,K,V,NC,TV,B,T,D,IER)
  21137. c    IF (IER .EQ. 1) WRITE (6,998)
  21138. c998    FORMAT(/' **** WARNING ****'/
  21139. c     1    ' CONVERGENCE NOT REACHED AFTER 50 ITERATIONS'/)
  21140. cC
  21141. cC    PRINT VARIANCES
  21142. cC
  21143. c    NV=NC+1
  21144. c    WRITE (6,12)
  21145. c    DO 190 I=1,NV
  21146. c    NC=I-1
  21147. c190    WRITE (6,13) NC,TV(I)
  21148. cC
  21149. cC    PRINT ROTATED FACTOR MATRIX
  21150. cC
  21151. c    WRITE (6,14) K
  21152. c    DO 220 I=1,M
  21153. c    DO 210 J=1,K
  21154. c    L=M*(J-1)+I
  21155. c210    S(J)=V(L)
  21156. c220    WRITE (6,15) I,(S(J),J=1,K)
  21157. cC
  21158. cC    PRINT COMMUNALITIES
  21159. cC
  21160. c    WRITE (6,16)
  21161. c    DO 230 I=1,M
  21162. c230    WRITE (6,17) I,B(I),T(I),D(I)
  21163. c    GO TO 100
  21164. c999    STOP
  21165. c    END
  21166. C
  21167. C    ..................................................................
  21168. C
  21169. C       SUBROUTINE FACTR
  21170. C
  21171. C       PURPOSE
  21172. C          FACTORIZATION OF THE MATRIX A INTO A PRODUCT OF A LOWER
  21173. C          TRIANGULAR MATRIX L AND AN UPPER TRIANGULAR MATRIX U.  L HAS
  21174. C          UNIT DIAGONAL WHICH IS NOT STORED.
  21175. C
  21176. C       USAGE
  21177. C          CALL FACTR(A,PER,N,IA,IER)
  21178. C
  21179. C       DESCRIPTION OF PARAMETERS
  21180. C          A      MATRIX A
  21181. C          PER    ONE DIMENSIONAL ARRAY WHERE PERMUTATIONS OF ROWS OF
  21182. C                 THE MATRIX ARE STORED
  21183. C                 DIMENSION OF PER MUST BE GREATER THAN OR EQUAL TO N
  21184. C          N      ORDER OF THE MATRIX A
  21185. C          IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A
  21186. C                 IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE
  21187. C                 SUBSCRIPTED DATA STORAGE MODE.  IA=N WHEN THE MATRIX
  21188. C                 IS IN SSP VECTOR STORAGE MODE.
  21189. C          IER    ERROR INDICATOR WHICH IS ZERO IF THERE IS NO ERROR,
  21190. C                 AND IS THREE IF THE PROCEDURE FAILS.
  21191. C
  21192. C       REMARKS
  21193. C          THE ORIGINAL MATRIX, A,IS REPLACED BY THE TRIANGULAR FACTORS
  21194. C
  21195. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  21196. C          NONE
  21197. C
  21198. C       METHOD
  21199. C          SUCCESSIVE COMPUTATION OF THE COLUMNS OF L AND THE
  21200. C          CORRESPONDING ROWS OF U.
  21201. C
  21202. C       REFERENCES
  21203. C          J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
  21204. C          CLARENDON PRESS, OXFORD, 1965. H. J. BOWDLER, R. S. MARTIN,
  21205. C          G. PETERS, AND J. H. WILKINSON - 'SOLUTION OF REAL AND
  21206. C          COMPLEX SYSTEMS OF LINEAR EQUATIONS', NUMERISCHE MATHEMATIK,
  21207. C          VOL. 8, NO. 3, 1966, P. 217-234.
  21208. C
  21209. C    ..................................................................
  21210. C
  21211.     SUBROUTINE FACTR(A,PER,N,IA,IER)
  21212.     DIMENSION A(1),PER(1)
  21213.     DOUBLE PRECISION DP
  21214. C
  21215. C       COMPUTATION OF WEIGHTS FOR EQUILIBRATION
  21216. C
  21217.     DO 20 I=1,N
  21218.     X=0.
  21219.     IJ=I
  21220.     DO 10 J=1,N
  21221.     IF (ABS(A(IJ))-X)10,10,5
  21222. 5    X=ABS(A(IJ))
  21223. 10    IJ=IJ+IA
  21224.     IF (X) 110,110,20
  21225. 20    PER(I)=1./X
  21226.     I0=0
  21227.     DO 100 I=1,N
  21228.     IM1=I-1
  21229.     IP1=I+1
  21230.     IPIVOT=I
  21231.     X=0.
  21232. C
  21233. C       COMPUTATION OF THE ITH COLUMN OF L
  21234. C
  21235.     DO 50 K=I,N
  21236.     KI=I0+K
  21237.     DP=A(KI)
  21238.     IF (I-1) 110,40,25
  21239. 25    KJ=K
  21240.     DO 30 J=1,IM1
  21241.     IJ=I0+J
  21242.     DP=DP-1.D0*A(KJ)*A(IJ)
  21243. 30    KJ=KJ+IA
  21244.     A(KI)=DP
  21245. C
  21246. C       SEARCH FOR EQUILIBRATED PIVOT
  21247. C
  21248. 40    IF (X-DABS(DP)*PER(K))45,50,50
  21249. 45    IPIVOT=K
  21250.     X=DABS(DP)*PER(K)
  21251. 50    CONTINUE
  21252.     IF (X)110,110,55
  21253. C
  21254. C       PERMUTATION OF ROWS IF REQUIRED
  21255. C
  21256. 55    IF (IPIVOT-I) 110,70,57
  21257. 57    KI=IPIVOT
  21258.     IJ=I
  21259.     DO 60 J=1,N
  21260.     X=A(IJ)
  21261.     A(IJ)=A(KI)
  21262.     A(KI)=X
  21263.     KI=KI+IA
  21264. 60    IJ=IJ+IA
  21265.     PER(IPIVOT)=PER(I)
  21266. 70    PER(I)=IPIVOT
  21267.     IF (I-N) 72,100,100
  21268. 72    IJ=I0+I
  21269.     X=A(IJ)
  21270. C
  21271. C       COMPUTATION OF THE ITH ROW OF U
  21272. C
  21273.     K0=I0+IA
  21274.     DO 90 K=IP1,N
  21275.     KI=I0+K
  21276.     A(KI)=A(KI)/X
  21277.     IF (I-1)110,90,75
  21278. 75    IJ=I
  21279.     KI=K0+I
  21280.     DP=A(KI)
  21281.     DO 80 J=1,IM1
  21282.     KJ=K0+J
  21283.     DP=DP-1.D0*A(IJ)*A(KJ)
  21284. 80    IJ=IJ+IA
  21285.     A(KI)=DP
  21286. 90    K0=K0+IA
  21287. 100    I0=I0+IA
  21288.     IER=0
  21289.     RETURN
  21290. 110    IER=3
  21291.     RETURN
  21292.     END
  21293. C    FUNCTION FCDF
  21294. C    GIVES PROBABILITIES FOR OBSERVED STATISTICS
  21295. C
  21296. C    T P=P^2
  21297. C    N = DF
  21298. C    M = INFINITY
  21299. C
  21300. C    Z P=P^2
  21301. C    N = INFINITY
  21302. CF    M = 1
  21303. C
  21304. C    CHI2 P=P/M
  21305. C    N =  INFINITY
  21306. C    M = DF
  21307. C
  21308. C    F P=P
  21309. C    M = DF1
  21310. C    N = DF2
  21311.     FUNCTION FCDF(FR,M,N)
  21312. C    FROM DECUSSCOPE
  21313. C    13:2 PAGE 7
  21314. C MODIFIED 10/8/84 LP ADDED DOUBLE
  21315.     IMPLICIT DOUBLE PRECISION (A-J,P-Z)
  21316.     REAL FR
  21317.     KONSTANT PI=3.1415926535
  21318.     FCDF=0
  21319.     CON=1
  21320.     FM=M
  21321.     FN=N
  21322.     IF((M-M/2*2).EQ.0)GOTO 80
  21323.     IF((N-N/2*2).EQ.0)GOTO 60
  21324.     IF(N.NE.1)GOTO 5
  21325.     THETA=ATAN(SQRT(FN/(FM*FR)))
  21326.     J=M/2
  21327.     GOTO 7
  21328. 5    THETA=ATAN(SQRT(FM*FR/FN))
  21329.     J=N/2
  21330. 7    SINE=SIN(THETA)
  21331.     SINSQ=SINE*SINE
  21332.     COSQ=1.0-SINSQ
  21333.     COSN=SQRT(COSQ)
  21334.     IF((M.EQ.1).AND.(N.EQ.1))GOTO 50
  21335.     DO 10 I=1,J
  21336.     FCDF=FCDF+CON
  21337.     TWI=2*I
  21338. 10    CON=CON*TWI*COSQ/(TWI+1.0)
  21339. 50    FCDF=1.0-2.0*(FCDF*SINE*COSN+THETA)/PI
  21340.     IF (N.EQ.1)RETURN
  21341.     FCDF=1.0-FCDF
  21342.     IF(M.EQ.1)RETURN
  21343.     FCTR=CON
  21344.     CON=1.0
  21345.     PEP=0.0
  21346.     FNM1=N-1
  21347.     J=M/2
  21348.     DO 20 I=1,J
  21349.     PEP=PEP+CON
  21350.     TWI=2*I
  21351. 20    CON=CON*(FNM1+TWI)*SINSQ/(TWI+1.0)
  21352.     FCDF=FCDF-2.*FN*FCTR*SINE*COSN*PEP/PI
  21353.     RETURN
  21354. 60    X=FN/(FN+FM*FR)
  21355.     J=N/2
  21356.     FMS2=M-2
  21357.     GOTO 85
  21358. 80    X=FM*FR/(FN+FM*FR)
  21359.     J=M/2
  21360.     FMS2=N-2
  21361. 85    OWX=1.0-X
  21362.     DO 90 I=1,J
  21363.     FCDF=FCDF+CON
  21364.     TWI=2*I
  21365.     CON=CON*(FMS2+TWI)*X/TWI
  21366.     IF(CON.LT.1E-6)GOTO 91
  21367. 90    CONTINUE
  21368. 91    IF((M-M/2*2).NE.0)GOTO 100
  21369.     FCDF=1.0-OWX**(FN/2.0)*FCDF
  21370.     RETURN
  21371. 100    FCDF=OWX**(FM/2.0)*FCDF
  21372.     RETURN
  21373.     END
  21374. C
  21375. C    ..................................................................
  21376. C
  21377. C       SUBROUTINE FMCG
  21378. C
  21379. C       PURPOSE
  21380. C          TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
  21381. C          BY THE METHOD OF CONJUGATE GRADIENTS
  21382. C
  21383. C       USAGE
  21384. C          CALL FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  21385. C
  21386. C       DESCRIPTION OF PARAMETERS
  21387. C          FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
  21388. C                   BE MINIMIZED. IT MUST BE OF THE FORM
  21389. C                   SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
  21390. C                   AND MUST SERVE THE FOLLOWING PURPOSE
  21391. C                   FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
  21392. C                   FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
  21393. C                   AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
  21394. C          N      - NUMBER OF VARIABLES
  21395. C          X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
  21396. C                   ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
  21397. C                   X HOLDS THE ARGUMENT CORRESPONDING TO THE
  21398. C                   COMPUTED MINIMUM FUNCTION VALUE
  21399. C          F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
  21400. C                   VALUE ON RETURN, I.E. F=F(X).
  21401. C          G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
  21402. C                   VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
  21403. C                   I.E. G=G(X).
  21404. C          EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
  21405. C          EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
  21406. C                   A REASONABLE CHOICE IS 10**(-6), I.E.
  21407. C                   SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
  21408. C                   NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
  21409. C                   REPRESENTATION.
  21410. C          LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
  21411. C          IER    - ERROR PARAMETER
  21412. C                   IER = 0 MEANS CONVERGENCE WAS OBTAINED
  21413. C                   IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
  21414. C                   IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
  21415. C                   IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
  21416. C                   IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
  21417. C          H      - WORKING STORAGE OF DIMENSION 2*N.
  21418. C
  21419. C       REMARKS
  21420. C           I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
  21421. C              MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
  21422. C          II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
  21423. C              DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
  21424. C              A TOLERABLE RANGE OF ARGUMENT.
  21425. C              IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
  21426. C              INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
  21427. C              RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
  21428. C              MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
  21429. C              TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
  21430. C              IS FOUND WHERE THE FUNCTION INCREASES.
  21431. C
  21432. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  21433. C          FUNCT
  21434. C
  21435. C       METHOD
  21436. C          THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
  21437. C          R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY
  21438. C          CONJUGATE GRADIENTS,
  21439. C          COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154.
  21440. C
  21441. C    ..................................................................
  21442. C
  21443.     SUBROUTINE FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  21444. C
  21445. C       DIMENSIONED DUMMY VARIABLES
  21446.     DIMENSION X(1),G(1),H(1)
  21447. C
  21448. C
  21449. C       COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
  21450.     CALL FUNCT(N,X,F,G)
  21451. C
  21452. C       RESET ITERATION COUNTER
  21453.     KOUNT=0
  21454.     IER=0
  21455.     N1=N+1
  21456. C
  21457. C       START ITERATION CYCLE FOR EVERY N+1 ITERATIONS
  21458. 1    DO 43 II=1,N1
  21459. C
  21460. C       STEP ITERATION COUNTER AND SAVE FUNCTION VALUE
  21461.     KOUNT=KOUNT+1
  21462.     OLDF=F
  21463. C
  21464. C       COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO
  21465.     GNRM=0.
  21466.     DO 2 J=1,N
  21467. 2    GNRM=GNRM+G(J)*G(J)
  21468.     IF(GNRM)46,46,3
  21469. C
  21470. C       EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL
  21471. C       BE IN DIRECTION OF STEEPEST DESCENT
  21472. 3    IF(II-1)4,4,6
  21473. 4    DO 5 J=1,N
  21474. 5    H(J)=-G(J)
  21475.     GO TO 8
  21476. C
  21477. C       FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING
  21478. C       TO THE CONJUGATE GRADIENT METHOD
  21479. 6    AMBDA=GNRM/OLDG
  21480.     DO 7 J=1,N
  21481. 7    H(J)=AMBDA*H(J)-G(J)
  21482. C
  21483. C       COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL
  21484. C       DERIVATIVE
  21485. 8    DY=0.
  21486.     HNRM=0.
  21487.     DO 9 J=1,N
  21488.     K=J+N
  21489. C
  21490. C       SAVE ARGUMENT VECTOR
  21491.     H(K)=X(J)
  21492.     HNRM=HNRM+ABS(H(J))
  21493. 9    DY=DY+H(J)*G(J)
  21494. C
  21495. C       CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND
  21496. C       SKIP LINEAR SEARCH ROUTINE IF NOT
  21497.     IF(DY)10,42,42
  21498. C
  21499. C       COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE
  21500. 10    SNRM=1./HNRM
  21501. C
  21502. C       SEARCH MINIMUM ALONG DIRECTION H
  21503. C
  21504. C       SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
  21505.     FY=F
  21506.     ALFA=2.*(EST-F)/DY
  21507.     AMBDA=SNRM
  21508. C
  21509. C       USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
  21510. C       SNRM. OTHERWISE TAKE SNRM AS STEPSIZE.
  21511.     IF(ALFA)13,13,11
  21512. 11    IF(ALFA-AMBDA)12,13,13
  21513. 12    AMBDA=ALFA
  21514. 13    ALFA=0.
  21515. C
  21516. C       SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
  21517. 14    FX=FY
  21518.     DX=DY
  21519. C
  21520. C       STEP ARGUMENT ALONG H
  21521.     DO 15 I=1,N
  21522. 15    X(I)=X(I)+AMBDA*H(I)
  21523. C
  21524. C       COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
  21525.     CALL FUNCT(N,X,F,G)
  21526.     FY=F
  21527. C
  21528. C       COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
  21529. C       SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
  21530.     DY=0.
  21531.     DO 16 I=1,N
  21532. 16    DY=DY+G(I)*H(I)
  21533.     IF(DY)17,38,20
  21534. C
  21535. C       TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
  21536. C       A MINIMUM HAS BEEN PASSED
  21537. 17    IF(FY-FX)18,20,20
  21538. C
  21539. C       REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
  21540. 18    AMBDA=AMBDA+ALFA
  21541.     ALFA=AMBDA
  21542. C
  21543. C       TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
  21544.     IF(HNRM*AMBDA-1.E10)14,14,19
  21545. C
  21546. C       LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
  21547. 19    IER=2
  21548. C
  21549. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  21550.     F=OLDF
  21551.     DO 100 J=1,N
  21552.     G(J)=H(J)
  21553.     K=N+J
  21554. 100    X(J)=H(K)
  21555.     RETURN
  21556. C       END OF SEARCH LOOP
  21557. C
  21558. C       INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
  21559. C       ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
  21560. C       POLYNOMIAL IS MINIMIZED
  21561. C
  21562. 20    T=0.
  21563. 21    IF(AMBDA)22,38,22
  21564. 22    Z=3.*(FX-FY)/AMBDA+DX+DY
  21565.     ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY))
  21566.     DALFA=Z/ALFA
  21567.     DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
  21568.     IF(DALFA)23,27,27
  21569. C
  21570. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  21571. 23    DO 24 J=1,N
  21572.     K=N+J
  21573. 24    X(J)=H(K)
  21574.     CALL FUNCT(N,X,F,G)
  21575. C
  21576. C       TEST FOR REPEATED FAILURE OF ITERATION
  21577. 25    IF(IER)47,26,47
  21578. 26    IER=-1
  21579.     GOTO 1
  21580. 27    W=ALFA*SQRT(DALFA)
  21581.     ALFA=DY-DX+W+W
  21582.     IF(ALFA)270,271,270
  21583. 270    ALFA=(DY-Z+W)/ALFA
  21584.     GO TO 272
  21585. 271    ALFA=(Z+DY-W)/(Z+DX+Z+DY)
  21586. 272    ALFA=ALFA*AMBDA
  21587.     DO 28 I=1,N
  21588. 28    X(I)=X(I)+(T-ALFA)*H(I)
  21589. C
  21590. C       TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
  21591. C       THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
  21592. C       THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
  21593. C       THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
  21594. C       VALUE OF THE FUNCTION AND ITS GRADIENT AT X
  21595. C
  21596.     CALL FUNCT(N,X,F,G)
  21597.     IF(F-FX)29,29,30
  21598. 29    IF(F-FY)38,38,30
  21599. C
  21600. C       COMPUTE DIRECTIONAL DERIVATIVE
  21601. 30    DALFA=0.
  21602.     DO 31 I=1,N
  21603. 31    DALFA=DALFA+G(I)*H(I)
  21604.     IF(DALFA)32,35,35
  21605. 32    IF(F-FX)34,33,35
  21606. 33    IF(DX-DALFA)34,38,34
  21607. 34    FX=F
  21608.     DX=DALFA
  21609.     T=ALFA
  21610.     AMBDA=ALFA
  21611.     GO TO 21
  21612. 35    IF(FY-F)37,36,37
  21613. 36    IF(DY-DALFA)37,38,37
  21614. 37    FY=F
  21615.     DY=DALFA
  21616.     AMBDA=AMBDA-ALFA
  21617.     GO TO 20
  21618. C
  21619. C       TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
  21620. C       OTHERWISE SAVE GRADIENT NORM
  21621. 38    IF(OLDF-F+EPS)19,25,39
  21622. 39    OLDG=GNRM
  21623. C
  21624. C       COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR
  21625.     T=0.
  21626.     DO 40 J=1,N
  21627.     K=J+N
  21628.     H(K)=X(J)-H(K)
  21629. 40    T=T+ABS(H(K))
  21630. C
  21631. C       TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS
  21632. C       HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS
  21633.     IF(KOUNT-N1)42,41,41
  21634. 41    IF(T-EPS)45,45,42
  21635. C
  21636. C       TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
  21637. 42    IF(KOUNT-LIMIT)43,44,44
  21638. 43    IER=0
  21639. C       END OF ITERATION CYCLE
  21640. C
  21641. C       START NEXT ITERATION CYCLE
  21642.     GO TO 1
  21643. C
  21644. C       NO CONVERGENCE AFTER  LIMIT  ITERATIONS
  21645. 44    IER=1
  21646.     IF(GNRM-EPS)46,46,47
  21647. C
  21648. C       TEST FOR SUFFICIENTLY SMALL GRADIENT
  21649. 45    IF(GNRM-EPS)46,46,25
  21650. 46    IER=0
  21651. 47    RETURN
  21652.     END
  21653. C
  21654. C    ..................................................................
  21655. C
  21656. C       SUBROUTINE FMFP
  21657. C
  21658. C       PURPOSE
  21659. C          TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
  21660. C          BY THE METHOD OF FLETCHER AND POWELL
  21661. C
  21662. C       USAGE
  21663. C          CALL FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  21664. C
  21665. C       DESCRIPTION OF PARAMETERS
  21666. C          FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
  21667. C                   BE MINIMIZED. IT MUST BE OF THE FORM
  21668. C                   SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
  21669. C                   AND MUST SERVE THE FOLLOWING PURPOSE
  21670. C                   FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
  21671. C                   FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
  21672. C                   AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
  21673. C          N      - NUMBER OF VARIABLES
  21674. C          X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
  21675. C                   ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
  21676. C                   X HOLDS THE ARGUMENT CORRESPONDING TO THE
  21677. C                   COMPUTED MINIMUM FUNCTION VALUE
  21678. C          F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
  21679. C                   VALUE ON RETURN, I.E. F=F(X).
  21680. C          G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
  21681. C                   VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
  21682. C                   I.E. G=G(X).
  21683. C          EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
  21684. C          EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
  21685. C                   A REASONABLE CHOICE IS 10**(-6), I.E.
  21686. C                   SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
  21687. C                   NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
  21688. C                   REPRESENTATION.
  21689. C          LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
  21690. C          IER    - ERROR PARAMETER
  21691. C                   IER = 0 MEANS CONVERGENCE WAS OBTAINED
  21692. C                   IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
  21693. C                   IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
  21694. C                   IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
  21695. C                   IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
  21696. C          H      - WORKING STORAGE OF DIMENSION N*(N+7)/2.
  21697. C
  21698. C       REMARKS
  21699. C           I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
  21700. C              MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
  21701. C          II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
  21702. C              DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
  21703. C              A TOLERABLE RANGE OF ARGUMENT.
  21704. C              IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
  21705. C              INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
  21706. C              RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
  21707. C              MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
  21708. C              TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
  21709. C              IS FOUND WHERE THE FUNCTION INCREASES.
  21710. C
  21711. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  21712. C          FUNCT
  21713. C
  21714. C       METHOD
  21715. C          THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
  21716. C          R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR
  21717. C          MINIMIZATION,
  21718. C          COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168.
  21719. C
  21720. C    ..................................................................
  21721. C
  21722.     SUBROUTINE FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
  21723. C
  21724. C       DIMENSIONED DUMMY VARIABLES
  21725.     DIMENSION H(1),X(1),G(1)
  21726. C
  21727. C       COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
  21728.     CALL FUNCT(N,X,F,G)
  21729. C
  21730. C       RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX
  21731.     IER=0
  21732.     KOUNT=0
  21733.     N2=N+N
  21734.     N3=N2+N
  21735.     N31=N3+1
  21736. 1    K=N31
  21737.     DO 4 J=1,N
  21738.     H(K)=1.
  21739.     NJ=N-J
  21740.     IF(NJ)5,5,2
  21741. 2    DO 3 L=1,NJ
  21742.     KL=K+L
  21743. 3    H(KL)=0.
  21744. 4    K=KL+1
  21745. C
  21746. C       START ITERATION LOOP
  21747. 5    KOUNT=KOUNT +1
  21748. C
  21749. C       SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR
  21750.     OLDF=F
  21751.     DO 9 J=1,N
  21752.     K=N+J
  21753.     H(K)=G(J)
  21754.     K=K+N
  21755.     H(K)=X(J)
  21756. C
  21757. C       DETERMINE DIRECTION VECTOR H
  21758.     K=J+N3
  21759.     T=0.
  21760.     DO 8 L=1,N
  21761.     T=T-G(L)*H(K)
  21762.     IF(L-J)6,7,7
  21763. 6    K=K+N-L
  21764.     GO TO 8
  21765. 7    K=K+1
  21766. 8    CONTINUE
  21767. 9    H(J)=T
  21768. C
  21769. C       CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H.
  21770.     DY=0.
  21771.     HNRM=0.
  21772.     GNRM=0.
  21773. C
  21774. C       CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION
  21775. C       VECTOR H AND GRADIENT VECTOR G.
  21776.     DO 10 J=1,N
  21777.     HNRM=HNRM+ABS(H(J))
  21778.     GNRM=GNRM+ABS(G(J))
  21779. 10    DY=DY+H(J)*G(J)
  21780. C
  21781. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL
  21782. C       DERIVATIVE APPEARS TO BE POSITIVE OR ZERO.
  21783.     IF(DY)11,51,51
  21784. C
  21785. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION
  21786. C       VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G.
  21787. 11    IF(HNRM/GNRM-EPS)51,51,12
  21788. C
  21789. C       SEARCH MINIMUM ALONG DIRECTION H
  21790. C
  21791. C       SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
  21792. 12    FY=F
  21793.     ALFA=2.*(EST-F)/DY
  21794.     AMBDA=1.
  21795. C
  21796. C       USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
  21797. C       1. OTHERWISE TAKE 1. AS STEPSIZE
  21798.     IF(ALFA)15,15,13
  21799. 13    IF(ALFA-AMBDA)14,15,15
  21800. 14    AMBDA=ALFA
  21801. 15    ALFA=0.
  21802. C
  21803. C       SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
  21804. 16    FX=FY
  21805.     DX=DY
  21806. C
  21807. C       STEP ARGUMENT ALONG H
  21808.     DO 17 I=1,N
  21809. 17    X(I)=X(I)+AMBDA*H(I)
  21810. C
  21811. C       COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
  21812.     CALL FUNCT(N,X,F,G)
  21813.     FY=F
  21814. C
  21815. C       COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
  21816. C       SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
  21817.     DY=0.
  21818.     DO 18 I=1,N
  21819. 18    DY=DY+G(I)*H(I)
  21820.     IF(DY)19,36,22
  21821. C
  21822. C       TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
  21823. C       A MINIMUM HAS BEEN PASSED
  21824. 19    IF(FY-FX)20,22,22
  21825. C
  21826. C       REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
  21827. 20    AMBDA=AMBDA+ALFA
  21828.     ALFA=AMBDA
  21829. C       END OF SEARCH LOOP
  21830. C
  21831. C       TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
  21832.     IF(HNRM*AMBDA-1.E10)16,16,21
  21833. C
  21834. C       LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
  21835. 21    IER=2
  21836.     RETURN
  21837. C
  21838. C       INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
  21839. C       ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
  21840. C       POLYNOMIAL IS MINIMIZED
  21841. 22    T=0.
  21842. 23    IF(AMBDA)24,36,24
  21843. 24    Z=3.*(FX-FY)/AMBDA+DX+DY
  21844.     ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY))
  21845.     DALFA=Z/ALFA
  21846.     DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
  21847.     IF(DALFA)51,25,25
  21848. 25    W=ALFA*SQRT(DALFA)
  21849.     ALFA=DY-DX+W+W
  21850.     IF(ALFA) 250,251,250
  21851. 250    ALFA=(DY-Z+W)/ALFA
  21852.     GO TO 252
  21853. 251    ALFA=(Z+DY-W)/(Z+DX+Z+DY)
  21854. 252    ALFA=ALFA*AMBDA
  21855.     DO 26 I=1,N
  21856. 26    X(I)=X(I)+(T-ALFA)*H(I)
  21857. C
  21858. C       TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
  21859. C       THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
  21860. C       THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
  21861. C       THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
  21862. C       VALUE OF THE FUNCTION AND ITS GRADIENT AT X
  21863. C
  21864.     CALL FUNCT(N,X,F,G)
  21865.     IF(F-FX)27,27,28
  21866. 27    IF(F-FY)36,36,28
  21867. 28    DALFA=0.
  21868.     DO 29 I=1,N
  21869. 29    DALFA=DALFA+G(I)*H(I)
  21870.     IF(DALFA)30,33,33
  21871. 30    IF(F-FX)32,31,33
  21872. 31    IF(DX-DALFA)32,36,32
  21873. 32    FX=F
  21874.     DX=DALFA
  21875.     T=ALFA
  21876.     AMBDA=ALFA
  21877.     GO TO 23
  21878. 33    IF(FY-F)35,34,35
  21879. 34    IF(DY-DALFA)35,36,35
  21880. 35    FY=F
  21881.     DY=DALFA
  21882.     AMBDA=AMBDA-ALFA
  21883.     GO TO 22
  21884. C
  21885. C       TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
  21886. 36    IF(OLDF-F+EPS)51,38,38
  21887. C
  21888. C       COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM
  21889. C       TWO CONSECUTIVE ITERATIONS
  21890. 38    DO 37 J=1,N
  21891.     K=N+J
  21892.     H(K)=G(J)-H(K)
  21893.     K=N+K
  21894. 37    H(K)=X(J)-H(K)
  21895. C
  21896. C       TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR
  21897. C       IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF
  21898. C       BOTH ARE LESS THAN  EPS
  21899.     IER=0
  21900.     IF(KOUNT-N)42,39,39
  21901. 39    T=0.
  21902.     Z=0.
  21903.     DO 40 J=1,N
  21904.     K=N+J
  21905.     W=H(K)
  21906.     K=K+N
  21907.     T=T+ABS(H(K))
  21908. 40    Z=Z+W*H(K)
  21909.     IF(HNRM-EPS)41,41,42
  21910. 41    IF(T-EPS)56,56,42
  21911. C
  21912. C       TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
  21913. 42    IF(KOUNT-LIMIT)43,50,50
  21914. C
  21915. C       PREPARE UPDATING OF MATRIX H
  21916. 43    ALFA=0.
  21917.     DO 47 J=1,N
  21918.     K=J+N3
  21919.     W=0.
  21920.     DO 46 L=1,N
  21921.     KL=N+L
  21922.     W=W+H(KL)*H(K)
  21923.     IF(L-J)44,45,45
  21924. 44    K=K+N-L
  21925.     GO TO 46
  21926. 45    K=K+1
  21927. 46    CONTINUE
  21928.     K=N+J
  21929.     ALFA=ALFA+W*H(K)
  21930. 47    H(J)=W
  21931. C
  21932. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS
  21933. C       ARE NOT SATISFACTORY
  21934.     IF(Z*ALFA)48,1,48
  21935. C
  21936. C       UPDATE MATRIX H
  21937. 48    K=N31
  21938.     DO 49 L=1,N
  21939.     KL=N2+L
  21940.     DO 49 J=L,N
  21941.     NJ=N2+J
  21942.     H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA
  21943. 49    K=K+1
  21944.     GO TO 5
  21945. C       END OF ITERATION LOOP
  21946. C
  21947. C       NO CONVERGENCE AFTER  LIMIT  ITERATIONS
  21948. 50    IER=1
  21949.     RETURN
  21950. C
  21951. C       RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
  21952. 51    DO 52 J=1,N
  21953.     K=N2+J
  21954. 52    X(J)=H(K)
  21955.     CALL FUNCT(N,X,F,G)
  21956. C
  21957. C       REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE
  21958. C       FAILS TO BE SUFFICIENTLY SMALL
  21959.     IF(GNRM-EPS)55,55,53
  21960. C
  21961. C       TEST FOR REPEATED FAILURE OF ITERATION
  21962. 53    IF(IER)56,54,54
  21963. 54    IER=-1
  21964.     GOTO 1
  21965. 55    IER=0
  21966. 56    RETURN
  21967.     END
  21968. C
  21969. C    ..................................................................
  21970. C
  21971. C       SUBROUTINE FORIF
  21972. C
  21973. C       PURPOSE
  21974. C          FOURIER ANALYSIS OF A GIVEN PERIODIC FUNCTION IN THE
  21975. C          RANGE 0-2PI
  21976. C          COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS
  21977. C          IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX)
  21978. C          WHERE K=1,2,...,M TO APPROXIMATE THE COMPUTED VALUES OF A
  21979. C          GIVEN FUNCTION SUBPROGRAM
  21980. C
  21981. C       USAGE
  21982. C          CALL FORIF(FUN,N,M,A,B,IER)
  21983. C
  21984. C       DESCRIPTION OF PARAMETERS
  21985. C          FUN-NAME OF FUNCTION SUBPROGRAM TO BE USED FOR COMPUTING
  21986. C              DATA POINTS
  21987. C          N  -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN
  21988. C              OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1
  21989. C          M  -THE MAXIMUM ORDER OF THE HARMONICS TO BE FITTED
  21990. C          A  -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF
  21991. C              LENGTH M+1
  21992. C              A SUB 0, A SUB 1,..., A SUB M
  21993. C          B  -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF
  21994. C              LENGTH M+1
  21995. C              B SUB 0, B SUB 1,..., B SUB M
  21996. C          IER-RESULTANT ERROR CODE WHERE
  21997. C              IER=0  NO ERROR
  21998. C              IER=1  N NOT GREATER OR EQUAL TO M
  21999. C              IER=2  M LESS THAN 0
  22000. C
  22001. C       REMARKS
  22002. C          M MUST BE GREATER THAN OR EQUAL TO ZERO
  22003. C          N MUST BE GREATER THAN OR EQUAL TO M
  22004. C          THE FIRST ELEMENT IN VECTOR B IS ZERO IN ALL CASES
  22005. C
  22006. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22007. C          FUN-NAME OF USER FUNCTION SUBPROGRAM USED FOR COMPUTING
  22008. C              DATA POINTS
  22009. C          CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT
  22010. C          CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO
  22011. C          FORIF
  22012. C
  22013. C       METHOD
  22014. C          USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF,
  22015. C          'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY
  22016. C          AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF
  22017. C          INDEXING THROUGH THE PROCEDURE HAS BEEN MODIFIED TO
  22018. C          SIMPLIFY THE COMPUTATION.
  22019. C
  22020. C    ..................................................................
  22021. C
  22022.     SUBROUTINE FORIF(FUN,N,M,A,B,IER)
  22023.     DIMENSION A(1),B(1)
  22024. C
  22025. C       CHECK FOR PARAMETER ERRORS
  22026. C
  22027.     IER=0
  22028. 20    IF(M) 30,40,40
  22029. 30    IER=2
  22030.     RETURN
  22031. 40    IF(M-N) 60,60,50
  22032. 50    IER=1
  22033.     RETURN
  22034. C
  22035. C       COMPUTE AND PRESET CONSTANTS
  22036. C
  22037. 60    AN=N
  22038.     COEF=2.0/(2.0*AN+1.0)
  22039.     CONST=3.141593*COEF
  22040.     S1=SIN(CONST)
  22041.     C1=COS(CONST)
  22042.     C=1.0
  22043.     S=0.0
  22044.     J=1
  22045.     FUNZ=FUN(0.0)
  22046. 70    U2=0.0
  22047.     U1=0.0
  22048.     AI=2*N
  22049. C
  22050. C       FORM FOURIER COEFFICIENTS RECURSIVELY
  22051. C
  22052. 75    X=AI*CONST
  22053.     U0=FUN(X)+2.0*C*U1-U2
  22054.     U2=U1
  22055.     U1=U0
  22056.     AI=AI-1.0
  22057.     IF(AI) 80,80,75
  22058. 80    A(J)=COEF*(FUNZ+C*U1-U2)
  22059.     B(J)=COEF*S*U1
  22060.     IF(J-(M+1)) 90,100,100
  22061. 90    Q=C1*C-S1*S
  22062.     S=C1*S+S1*C
  22063.     C=Q
  22064.     J=J+1
  22065.     GO TO 70
  22066. 100    A(1)=A(1)*0.5
  22067.     RETURN
  22068.     END
  22069. C
  22070. C    ..................................................................
  22071. C
  22072. C       SUBROUTINE FORIT
  22073. C
  22074. C       PURPOSE
  22075. C          FOURIER ANALYSIS OF A PERIODICALLY TABULATED FUNCTION.
  22076. C          COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS
  22077. C          IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX)
  22078. C          WHERE K=1,2,...,M TO APPROXIMATE A GIVEN SET OF
  22079. C          PERIODICALLY TABULATED VALUES OF A FUNCTION.
  22080. C
  22081. C       USAGE
  22082. C          CALL FORIT(FNT,N,M,A,B,IER)
  22083. C
  22084. C       DESCRIPTION OF PARAMETERS
  22085. C          FNT-VECTOR OF TABULATED FUNCTION VALUES OF LENGTH 2N+1
  22086. C          N  -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN
  22087. C              OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1
  22088. C          M  -MAXIMUM ORDER OF HARMONICS TO BE FITTED
  22089. C          A  -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF
  22090. C              LENGTH M+1
  22091. C              A SUB 0, A SUB 1,..., A SUB M
  22092. C          B  -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF
  22093. C              LENGTH M+1
  22094. C              B SUB 0, B SUB 1,..., B SUB M
  22095. C          IER-RESULTANT ERROR CODE WHERE
  22096. C              IER=0  NO ERROR
  22097. C              IER=1  N NOT GREATER OR EQUAL TO M
  22098. C              IER=2  M LESS THAN 0
  22099. C
  22100. C       REMARKS
  22101. C          M MUST BE GREATER THAN OR EQUAL TO ZERO
  22102. C          N MUST BE GREATER THAN OR EQUAL TO M
  22103. C          THE FIRST ELEMENT OF VECTOR B IS ZERO IN ALL CASES
  22104. C
  22105. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22106. C          NONE
  22107. C
  22108. C       METHOD
  22109. C          USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF,
  22110. C          'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY
  22111. C          AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF INDEXING
  22112. C          THROUGH THE PROCEDURE HAS BEEN MODIFIED TO SIMPLIFY THE
  22113. C          COMPUTATION.
  22114. C
  22115. C    ..................................................................
  22116. C
  22117.     SUBROUTINE FORIT(FNT,N,M,A,B,IER)
  22118.     DIMENSION A(1),B(1),FNT(1)
  22119. C
  22120. C       CHECK FOR PARAMETER ERRORS
  22121. C
  22122.     IER=0
  22123. 20    IF(M) 30,40,40
  22124. 30    IER=2
  22125.     RETURN
  22126. 40    IF(M-N) 60,60,50
  22127. 50    IER=1
  22128.     RETURN
  22129. C
  22130. C       COMPUTE AND PRESET CONSTANTS
  22131. C
  22132. 60    AN=N
  22133.     COEF=2.0/(2.0*AN+1.0)
  22134.     CONST=3.141593*COEF
  22135.     S1=SIN(CONST)
  22136.     C1=COS(CONST)
  22137.     C=1.0
  22138.     S=0.0
  22139.     J=1
  22140.     FNTZ=FNT(1)
  22141. 70    U2=0.0
  22142.     U1=0.0
  22143.     I=2*N+1
  22144. C
  22145. C       FORM FOURIER COEFFICIENTS RECURSIVELY
  22146. C
  22147. 75    U0=FNT(I)+2.0*C*U1-U2
  22148.     U2=U1
  22149.     U1=U0
  22150.     I=I-1
  22151.     IF(I-1) 80,80,75
  22152. 80    A(J)=COEF*(FNTZ+C*U1-U2)
  22153.     B(J)=COEF*S*U1
  22154.     IF(J-(M+1)) 90,100,100
  22155. 90    Q=C1*C-S1*S
  22156.     S=C1*S+S1*C
  22157.     C=Q
  22158.     J=J+1
  22159.     GO TO 70
  22160. 100    A(1)=A(1)*0.5
  22161.     RETURN
  22162.     END
  22163. C
  22164. C    ..................................................................
  22165. C
  22166. C       SUBROUTINE FRAT
  22167. C
  22168. C       PURPOSE
  22169. C          FRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS
  22170. C          WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF
  22171. C          RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY
  22172. C
  22173. C       USAGE
  22174. C          CALL FRAT(I,N,M,P,DATI,WGT,IER)
  22175. C
  22176. C       DESCRIPTION OF PARAMETERS
  22177. C          I     - SUBSCRIPT OF CURRENT DATA POINT
  22178. C          N     - NUMBER OF ALL DATA POINTS
  22179. C          M     - NUMBER OF FUNDAMENTAL FUNCTIONS USED
  22180. C          P     - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS
  22181. C                  ON RETURN THE VALUES OF THE M FUNDAMENTAL
  22182. C                  FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE
  22183. C          DATI  - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED
  22184. C                  BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY
  22185. C                  N WEIGHT VALUES
  22186. C          WGT   - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM
  22187. C          IER   - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT
  22188. C                  VALUES FOR CONTROL
  22189. C                  IER(2) MEANS DIMENSION OF NUMERATOR
  22190. C                  IER(3) MEANS DIMENSION OF DENOMINATOR
  22191. C                  IER(1) IS USED AS RESULTANT ERROR PARAMETER,
  22192. C                  IER(1) = 0 IN CASE OF NO ERRORS
  22193. C                  IER(1) = 1 OTHERWISE (ZERO DENOMINATOR)
  22194. C
  22195. C       REMARKS
  22196. C          VECTOR IER IS USED FOR COMMUNICATION BETWEEN ARAT AND FRAT
  22197. C
  22198. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22199. C          CNP
  22200. C
  22201. C       METHOD
  22202. C          CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT
  22203. C
  22204. C    ..................................................................
  22205. C
  22206.     SUBROUTINE FRAT(I,N,M,P,DATI,WGT,IER)
  22207. C
  22208. C
  22209. C       DIMENSIONED DUMMY VARIABLES
  22210.     DIMENSION P(1),DATI(1),IER(1)
  22211. C
  22212. C       INITIALIZATION
  22213.     IP=IER(2)
  22214.     IQ=IER(3)
  22215.     IQM1=IQ-1
  22216.     IPQ=IP+IQ
  22217. C
  22218. C       LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT
  22219. C       LOOK UP NUMERATOR AND DENOMINATOR
  22220.     T=DATI(I)
  22221.     J=I+N
  22222.     F=DATI(J)
  22223.     FNUM=P(J)
  22224.     J=J+N
  22225.     WGT=1.
  22226.     IF(DATI(2*N+1))2,2,1
  22227. 1    WGT=DATI(J)
  22228. 2    FDEN=P(J)
  22229. C
  22230. C       CALCULATE FUNCTION VALUE USED
  22231.     F=F*FDEN-FNUM
  22232. C
  22233. C       CHECK FOR ZERO DENOMINATOR
  22234.     IF(FDEN)4,3,4
  22235. C
  22236. C       ERROR RETURN IN CASE OF ZERO DENOMINATOR
  22237. 3    IER(1)=1
  22238.     RETURN
  22239. C
  22240. C       CALCULATE WEIGHT FACTORS USED
  22241. 4    WGT=WGT/(FDEN*FDEN)
  22242.     FNUM=-FNUM/FDEN
  22243. C
  22244. C       CALCULATE FUNDAMENTAL FUNCTIONS
  22245.     J=IQM1
  22246.     IF(IP-IQ)6,6,5
  22247. 5    J=IP-1
  22248. 6    CALL CNP(P(IQ),T,J)
  22249. C
  22250. C       STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS
  22251. 7    IF(IQM1)10,10,8
  22252. 8    DO 9 II=1,IQM1
  22253.     J=II+IQ
  22254. 9    P(II)=P(J)*FNUM
  22255. C
  22256. C       STORE FUNCTION VALUE
  22257. 10    P(IPQ)=F
  22258. C
  22259. C       NORMAL RETURN
  22260.     IER(1)=0
  22261.     RETURN
  22262.     END
  22263.     FUNCTION FUN(X,Y)
  22264. C
  22265.     FUN=1./X
  22266.     RETURN
  22267.     END
  22268. C
  22269. C    ..................................................................
  22270. C
  22271. C       SUBROUTINE GAUSS
  22272. C
  22273. C       PURPOSE
  22274. C          COMPUTES A NORMALLY DISTRIBUTED RANDOM NUMBER WITH A GIVEN
  22275. C          MEAN AND STANDARD DEVIATION
  22276. C
  22277. C       USAGE
  22278. C          CALL GAUSS(IX,S,AM,V)
  22279. C
  22280. C       DESCRIPTION OF PARAMETERS
  22281. C          IX -IX MUST CONTAIN AN ODD INTEGER NUMBER WITH NINE OR
  22282. C              LESS DIGITS ON THE FIRST ENTRY TO GAUSS. THEREAFTER
  22283. C              IT WILL CONTAIN A UNIFORMLY DISTRIBUTED INTEGER RANDOM
  22284. C              NUMBER GENERATED BY THE SUBROUTINE FOR USE ON THE NEXT
  22285. C              ENTRY TO THE SUBROUTINE.
  22286. C          S  -THE DESIRED STANDARD DEVIATION OF THE NORMAL
  22287. C              DISTRIBUTION.
  22288. C          AM -THE DESIRED MEAN OF THE NORMAL DISTRIBUTION
  22289. C          V  -THE VALUE OF THE COMPUTED NORMAL RANDOM VARIABLE
  22290. C
  22291. C       REMARKS
  22292. C          THIS SUBROUTINE USES RANDU WHICH IS MACHINE SPECIFIC
  22293. C
  22294. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22295. C          RANDU
  22296. C
  22297. C       METHOD
  22298. C          USES 12 UNIFORM RANDOM NUMBERS TO COMPUTE NORMAL RANDOM
  22299. C          NUMBERS BY CENTRAL LIMIT THEOREM. THE RESULT IS THEN
  22300. C          ADJUSTED TO MATCH THE GIVEN MEAN AND STANDARD DEVIATION.
  22301. C          THE UNIFORM RANDOM NUMBERS COMPUTED WITHIN THE SUBROUTINE
  22302. C          ARE FOUND BY THE POWER RESIDUE METHOD.
  22303. C
  22304. C    ..................................................................
  22305. C
  22306.     SUBROUTINE GAUSS(IX,S,AM,V)
  22307.     A=0.0
  22308.     DO 50 I=1,12
  22309.     CALL RANDU(IX,IY,Y)
  22310.     IX=IY
  22311. 50    A=A+Y
  22312.     V=(A-6.0)*S+AM
  22313.     RETURN
  22314.     END
  22315. C
  22316. C    ..................................................................
  22317. C
  22318. C       SUBROUTINE GDATA
  22319. C
  22320. C       PURPOSE
  22321. C          GENERATE INDEPENDENT VARIABLES UP TO THE M-TH POWER (THE
  22322. C          HIGHEST DEGREE POLYNOMIAL SPECIFIED) AND COMPUTE MEANS,
  22323. C          STANDARD DEVIATIONS, AND CORRELATION COEFFICIENTS.  THIS
  22324. C          SUBROUTINE IS NORMALLY CALLED BEFORE SUBROUTINES ORDER,
  22325. C          MINV AND MULTR IN THE PERFORMANCE OF A POLYNOMIAL
  22326. C          REGRESSION.
  22327. C
  22328. C       USAGE
  22329. C          CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ)
  22330. C
  22331. C       DESCRIPTION OF PARAMETERS
  22332. C          N     - NUMBER OF OBSERVATIONS.
  22333. C          M     - THE HIGHEST DEGREE POLYNOMIAL TO BE FITTED.
  22334. C          X     - INPUT MATRIX (N BY M+1) .  WHEN THE SUBROUTINE IS
  22335. C                  CALLED, DATA FOR THE INDEPENDENT VARIABLE ARE
  22336. C                  STORED IN THE FIRST COLUMN OF MATRIX X, AND DATA FOR
  22337. C                  THE DEPENDENT VARIABLE ARE STORED IN THE LAST
  22338. C                  COLUMN OF THE MATRIX.  UPON RETURNING TO THE
  22339. C                  CALLING ROUTINE, GENERATED POWERS OF THE INDEPENDENT
  22340. C                  VARIABLE ARE STORED IN COLUMNS 2 THROUGH M.
  22341. C          XBAR  - OUTPUT VECTOR OF LENGTH M+1 CONTAINING MEANS OF
  22342. C                  INDEPENDENT AND DEPENDENT VARIABLES.
  22343. C          STD   - OUTPUT VECTOR OF LENGTH M+1 CONTAINING STANDARD
  22344. C                  DEVIATIONS OF INDEPENDENT AND DEPENDENT VARIABLES.
  22345. C          D     - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
  22346. C                  SYMMETRIC MATRIX OF M+1 BY M+1) CONTAINING CORRELA-
  22347. C                  TION COEFFICIENTS.  (STORAGE MODE OF 1)
  22348. C          SUMSQ - OUTPUT VECTOR OF LENGTH M+1 CONTAINING SUMS OF
  22349. C                  PRODUCTS OF DEVIATIONS FROM MEANS  OF INDEPENDENT
  22350. C                  AND DEPENDENT VARIABLES.
  22351. C
  22352. C       REMARKS
  22353. C          N MUST BE GREATER THAN M+1.
  22354. C          IF M IS EQUAL TO 5 OR GREATER, SINGLE PRECISION MAY NOT BE
  22355. C          SUFFICIENT TO GIVE SATISFACTORY COMPUTATIONAL RESULTS.
  22356. C
  22357. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22358. C          NONE
  22359. C
  22360. C       METHOD
  22361. C          REFER TO B. OSTLE, 'STATISTICS IN RESEARCH', THE IOWA STATE
  22362. C          COLLEGE PRESS, 1954, CHAPTER 6.
  22363. C
  22364. C    ..................................................................
  22365. C
  22366.     SUBROUTINE GDATA (N,M,X,XBAR,STD,D,SUMSQ)
  22367.     DIMENSION X(1),XBAR(1),STD(1),D(1),SUMSQ(1)
  22368. C
  22369. C       ...............................................................
  22370. C
  22371. C       IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
  22372. C       C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
  22373. C       STATEMENT WHICH FOLLOWS.
  22374. C
  22375. C    DOUBLE PRECISION X,XBAR,STD,D,SUMSQ,T1,T2
  22376. C
  22377. C       THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
  22378. C       APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
  22379. C       ROUTINE.
  22380. C
  22381. C       THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
  22382. C       CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
  22383. C       STATEMENT 180 MUST BE CHANGED TO DSQRT AND DABS.
  22384. C
  22385. C       ...............................................................
  22386. C
  22387. C    GENERATE INDEPENDENT VARIABLES
  22388. C
  22389.     IF(M-1) 105, 105, 90
  22390. 90    L1=0
  22391.     DO 100 I=2,M
  22392.     L1=L1+N
  22393.     DO 100 J=1,N
  22394.     L=L1+J
  22395.     K=L-N
  22396. 100    X(L)=X(K)*X(J)
  22397. C
  22398. C    CALCULATE MEANS
  22399. C
  22400. 105    MM=M+1
  22401.     DF=N
  22402.     L=0
  22403.     DO 115 I=1,MM
  22404.     XBAR(I)=0.0
  22405.     DO 110 J=1,N
  22406.     L=L+1
  22407. 110    XBAR(I)=XBAR(I)+X(L)
  22408. 115    XBAR(I)=XBAR(I)/DF
  22409. C
  22410.     DO 130 I=1,MM
  22411. 130    STD(I)=0.0
  22412. C
  22413. C    CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
  22414. C
  22415.     L=((MM+1)*MM)/2
  22416.     DO 150 I=1,L
  22417. 150    D(I)=0.0
  22418.     DO 170 K=1,N
  22419.     L=0
  22420.     DO 170 J=1,MM
  22421.     L2=N*(J-1)+K
  22422.     T2=X(L2)-XBAR(J)
  22423.     STD(J)=STD(J)+T2
  22424.     DO 170 I=1,J
  22425.     L1=N*(I-1)+K
  22426.     T1=X(L1)-XBAR(I)
  22427.     L=L+1
  22428. 170    D(L)=D(L)+T1*T2
  22429.     L=0
  22430.     DO 175 J=1,MM
  22431.     DO 175 I=1,J
  22432.     L=L+1
  22433. 175    D(L)=D(L)-STD(I)*STD(J)/DF
  22434.     L=0
  22435.     DO 180 I=1,MM
  22436.     L=L+I
  22437.     SUMSQ(I)=D(L)
  22438. 180    STD(I)= SQRT( ABS(D(L)))
  22439. C
  22440. C    CALCULATE CORRELATION COEFFICIENTS
  22441. C
  22442.     L=0
  22443.     DO 190 J=1,MM
  22444.     DO 190 I=1,J
  22445.     L=L+1
  22446. 190    D(L)=D(L)/(STD(I)*STD(J))
  22447. C
  22448. C    CALCULATE STANDARD DEVIATIONS
  22449. C
  22450.     DF=SQRT(DF-1.0)
  22451.     DO 200 I=1,MM
  22452. 200    STD(I)=STD(I)/DF
  22453.     RETURN
  22454.     END
  22455. C
  22456. C    ..................................................................
  22457. C
  22458. C       SUBROUTINE GELB
  22459. C
  22460. C       PURPOSE
  22461. C          TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A
  22462. C          COEFFICIENT MATRIX OF BAND STRUCTURE.
  22463. C
  22464. C       USAGE
  22465. C          CALL GELB(R,A,M,N,MUD,MLD,EPS,IER)
  22466. C
  22467. C       DESCRIPTION OF PARAMETERS
  22468. C          R      - M BY N RIGHT HAND SIDE MATRIX (DESTROYED).
  22469. C                   ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
  22470. C          A      - M BY M COEFFICIENT MATRIX WITH BAND STRUCTURE
  22471. C                   (DESTROYED).
  22472. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  22473. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  22474. C          MUD    - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS
  22475. C                   CODIAGONALS ABOVE MAIN DIAGONAL).
  22476. C          MLD    - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS
  22477. C                   CODIAGONALS BELOW MAIN DIAGONAL).
  22478. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
  22479. C                   TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
  22480. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  22481. C                   IER=0  - NO ERROR,
  22482. C                   IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
  22483. C                            TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT
  22484. C                            AT ANY ELIMINATION STEP EQUAL TO 0,
  22485. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  22486. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  22487. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  22488. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  22489. C                            ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
  22490. C
  22491. C       REMARKS
  22492. C          BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST
  22493. C          ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA
  22494. C          STORAGE LOCATIONS, WHERE
  22495. C            MA=M*MC-ML*(ML+1)/2    AND    ME=MA-MU*(MU+1)/2    WITH
  22496. C            MC=MIN(M,1+MUD+MLD),  ML=MC-1-MLD,  MU=MC-1-MUD.
  22497. C          RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
  22498. C          IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION
  22499. C          MATRIX R IS STORED COLUMNWISE TOO.
  22500. C          INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING
  22501. C          RESTRICTIONS     MUD NOT LESS THAN ZERO
  22502. C                           MLD NOT LESS THAN ZERO
  22503. C                           MUD+MLD NOT GREATER THAN 2*M-2.
  22504. C          NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
  22505. C          RESTRICTIONS ARE NOT SATISFIED.
  22506. C          THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
  22507. C          PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL
  22508. C          ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING
  22509. C          IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE.
  22510. C          IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE
  22511. C          EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K.
  22512. C          NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL.
  22513. C
  22514. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22515. C          NONE
  22516. C
  22517. C       METHOD
  22518. C          SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH
  22519. C          COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE
  22520. C          IN REMAINING COEFFICIENT MATRICES.
  22521. C
  22522. C    ..................................................................
  22523. C
  22524.     SUBROUTINE GELB(R,A,M,N,MUD,MLD,EPS,IER)
  22525. C
  22526. C
  22527.     DIMENSION R(1),A(1)
  22528. C
  22529. C    TEST ON WRONG INPUT PARAMETERS
  22530.     IF(MLD)47,1,1
  22531. 1    IF(MUD)47,2,2
  22532. 2    MC=1+MLD+MUD
  22533.     IF(MC+1-M-M)3,3,47
  22534. C
  22535. C    PREPARE INTEGER PARAMETERS
  22536. C       MC=NUMBER OF COLUMNS IN MATRIX A
  22537. C       MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A
  22538. C       ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A
  22539. C       MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS
  22540. C       MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A
  22541. C       MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A
  22542. C       NM=NUMBER OF ELEMENTS IN MATRIX R
  22543. 3    IF(MC-M)5,5,4
  22544. 4    MC=M
  22545. 5    MU=MC-MUD-1
  22546.     ML=MC-MLD-1
  22547.     MR=M-ML
  22548.     MZ=(MU*(MU+1))/2
  22549.     MA=M*MC-(ML*(ML+1))/2
  22550.     NM=N*M
  22551. C
  22552. C    MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT
  22553. C    (NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS)
  22554.     IER=0
  22555.     PIV=0.
  22556.     IF(MLD)14,14,6
  22557. 6    JJ=MA
  22558.     J=MA-MZ
  22559.     KST=J
  22560.     DO 9 K=1,KST
  22561.     TB=A(J)
  22562.     A(JJ)=TB
  22563.     TB=ABS(TB)
  22564.     IF(TB-PIV)8,8,7
  22565. 7    PIV=TB
  22566. 8    J=J-1
  22567. 9    JJ=JJ-1
  22568. C
  22569. C    INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0)
  22570.     IF(MZ)14,14,10
  22571. 10    JJ=1
  22572.     J=1+MZ
  22573.     IC=1+MUD
  22574.     DO 13 I=1,MU
  22575.     DO 12 K=1,MC
  22576.     A(JJ)=0.
  22577.     IF(K-IC)11,11,12
  22578. 11    A(JJ)=A(J)
  22579.     J=J+1
  22580. 12    JJ=JJ+1
  22581. 13    IC=IC+1
  22582. C
  22583. C    GENERATE TEST VALUE FOR SINGULARITY
  22584. 14    TOL=EPS*PIV
  22585. C
  22586. C
  22587. C    START DECOMPOSITION LOOP
  22588.     KST=1
  22589.     IDST=MC
  22590.     IC=MC-1
  22591.     DO 38 K=1,M
  22592.     IF(K-MR-1)16,16,15
  22593. 15    IDST=IDST-1
  22594. 16    ID=IDST
  22595.     ILR=K+MLD
  22596.     IF(ILR-M)18,18,17
  22597. 17    ILR=M
  22598. 18    II=KST
  22599. C
  22600. C    PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR)
  22601.     PIV=0.
  22602.     DO 22 I=K,ILR
  22603.     TB=ABS(A(II))
  22604.     IF(TB-PIV)20,20,19
  22605. 19    PIV=TB
  22606.     J=I
  22607.     JJ=II
  22608. 20    IF(I-MR)22,22,21
  22609. 21    ID=ID-1
  22610. 22    II=II+ID
  22611. C
  22612. C    TEST ON SINGULARITY
  22613.     IF(PIV)47,47,23
  22614. 23    IF(IER)26,24,26
  22615. 24    IF(PIV-TOL)25,25,26
  22616. 25    IER=K-1
  22617. 26    PIV=1./A(JJ)
  22618. C
  22619. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  22620.     ID=J-K
  22621.     DO 27 I=K,NM,M
  22622.     II=I+ID
  22623.     TB=PIV*R(II)
  22624.     R(II)=R(I)
  22625. 27    R(I)=TB
  22626. C
  22627. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A
  22628.     II=KST
  22629.     J=JJ+IC
  22630.     DO 28 I=JJ,J
  22631.     TB=PIV*A(I)
  22632.     A(I)=A(II)
  22633.     A(II)=TB
  22634. 28    II=II+1
  22635. C
  22636. C    ELEMENT REDUCTION
  22637.     IF(K-ILR)29,34,34
  22638. 29    ID=KST
  22639.     II=K+1
  22640.     MU=KST+1
  22641.     MZ=KST+IC
  22642.     DO 33 I=II,ILR
  22643. C
  22644. C    IN MATRIX A
  22645.     ID=ID+MC
  22646.     JJ=I-MR-1
  22647.     IF(JJ)31,31,30
  22648. 30    ID=ID-JJ
  22649. 31    PIV=-A(ID)
  22650.     J=ID+1
  22651.     DO 32 JJ=MU,MZ
  22652.     A(J-1)=A(J)+PIV*A(JJ)
  22653. 32    J=J+1
  22654.     A(J-1)=0.
  22655. C
  22656. C    IN MATRIX R
  22657.     J=K
  22658.     DO 33 JJ=I,NM,M
  22659.     R(JJ)=R(JJ)+PIV*R(J)
  22660. 33    J=J+M
  22661. 34    KST=KST+MC
  22662.     IF(ILR-MR)36,35,35
  22663. 35    IC=IC-1
  22664. 36    ID=K-MR
  22665.     IF(ID)38,38,37
  22666. 37    KST=KST-ID
  22667. 38    CONTINUE
  22668. C    END OF DECOMPOSITION LOOP
  22669. C
  22670. C
  22671. C    BACK SUBSTITUTION
  22672.     IF(MC-1)46,46,39
  22673. 39    IC=2
  22674.     KST=MA+ML-MC+2
  22675.     II=M
  22676.     DO 45 I=2,M
  22677.     KST=KST-MC
  22678.     II=II-1
  22679.     J=II-MR
  22680.     IF(J)41,41,40
  22681. 40    KST=KST+J
  22682. 41    DO 43 J=II,NM,M
  22683.     TB=R(J)
  22684.     MZ=KST+IC-2
  22685.     ID=J
  22686.     DO 42 JJ=KST,MZ
  22687.     ID=ID+1
  22688. 42    TB=TB-A(JJ)*R(ID)
  22689. 43    R(J)=TB
  22690.     IF(IC-MC)44,45,45
  22691. 44    IC=IC+1
  22692. 45    CONTINUE
  22693. 46    RETURN
  22694. C
  22695. C
  22696. C    ERROR RETURN
  22697. 47    IER=-1
  22698.     RETURN
  22699.     END
  22700. C
  22701. C    ..................................................................
  22702. C
  22703. C       SUBROUTINE GELG
  22704. C
  22705. C       PURPOSE
  22706. C          TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS.
  22707. C
  22708. C       USAGE
  22709. C          CALL GELG(R,A,M,N,EPS,IER)
  22710. C
  22711. C       DESCRIPTION OF PARAMETERS
  22712. C          R      - THE M BY N MATRIX OF RIGHT HAND SIDES.  (DESTROYED)
  22713. C                   ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
  22714. C          A      - THE M BY M COEFFICIENT MATRIX.  (DESTROYED)
  22715. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  22716. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  22717. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
  22718. C                   TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
  22719. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  22720. C                   IER=0  - NO ERROR,
  22721. C                   IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
  22722. C                            PIVOT ELEMENT AT ANY ELIMINATION STEP
  22723. C                            EQUAL TO 0,
  22724. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  22725. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  22726. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  22727. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  22728. C                            ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
  22729. C
  22730. C       REMARKS
  22731. C          INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE
  22732. C          IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN
  22733. C          SOLUTION MATRIX R IS STORED COLUMNWISE TOO.
  22734. C          THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
  22735. C          GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
  22736. C          ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
  22737. C          INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
  22738. C          SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
  22739. C          INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
  22740. C          GIVEN IN CASE M=1.
  22741. C
  22742. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22743. C          NONE
  22744. C
  22745. C       METHOD
  22746. C          SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
  22747. C          COMPLETE PIVOTING.
  22748. C
  22749. C    ..................................................................
  22750. C
  22751.     SUBROUTINE GELG(R,A,M,N,EPS,IER)
  22752. C
  22753. C
  22754.     DIMENSION A(1),R(1)
  22755.     IF(M)23,23,1
  22756. C
  22757. C    SEARCH FOR GREATEST ELEMENT IN MATRIX A
  22758. 1    IER=0
  22759.     PIV=0.
  22760.     MM=M*M
  22761.     NM=N*M
  22762.     DO 3 L=1,MM
  22763.     TB=ABS(A(L))
  22764.     IF(TB-PIV)3,3,2
  22765. 2    PIV=TB
  22766.     I=L
  22767. 3    CONTINUE
  22768.     TOL=EPS*PIV
  22769. C    A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
  22770. C
  22771. C
  22772. C    START ELIMINATION LOOP
  22773.     LST=1
  22774.     DO 17 K=1,M
  22775. C
  22776. C    TEST ON SINGULARITY
  22777.     IF(PIV)23,23,4
  22778. 4    IF(IER)7,5,7
  22779. 5    IF(PIV-TOL)6,6,7
  22780. 6    IER=K-1
  22781. 7    PIVI=1./A(I)
  22782.     J=(I-1)/M
  22783.     I=I-J*M-K
  22784.     J=J+1-K
  22785. C    I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT
  22786. C
  22787. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  22788.     DO 8 L=K,NM,M
  22789.     LL=L+I
  22790.     TB=PIVI*R(LL)
  22791.     R(LL)=R(L)
  22792. 8    R(L)=TB
  22793. C
  22794. C    IS ELIMINATION TERMINATED
  22795.     IF(K-M)9,18,18
  22796. C
  22797. C    COLUMN INTERCHANGE IN MATRIX A
  22798. 9    LEND=LST+M-K
  22799.     IF(J)12,12,10
  22800. 10    II=J*M
  22801.     DO 11 L=LST,LEND
  22802.     TB=A(L)
  22803.     LL=L+II
  22804.     A(L)=A(LL)
  22805. 11    A(LL)=TB
  22806. C
  22807. C    ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A
  22808. 12    DO 13 L=LST,MM,M
  22809.     LL=L+I
  22810.     TB=PIVI*A(LL)
  22811.     A(LL)=A(L)
  22812. 13    A(L)=TB
  22813. C
  22814. C    SAVE COLUMN INTERCHANGE INFORMATION
  22815.     A(LST)=J
  22816. C
  22817. C    ELEMENT REDUCTION AND NEXT PIVOT SEARCH
  22818.     PIV=0.
  22819.     LST=LST+1
  22820.     J=0
  22821.     DO 16 II=LST,LEND
  22822.     PIVI=-A(II)
  22823.     IST=II+M
  22824.     J=J+1
  22825.     DO 15 L=IST,MM,M
  22826.     LL=L-J
  22827.     A(L)=A(L)+PIVI*A(LL)
  22828.     TB=ABS(A(L))
  22829.     IF(TB-PIV)15,15,14
  22830. 14    PIV=TB
  22831.     I=L
  22832. 15    CONTINUE
  22833.     DO 16 L=K,NM,M
  22834.     LL=L+J
  22835. 16    R(LL)=R(LL)+PIVI*R(L)
  22836. 17    LST=LST+M
  22837. C    END OF ELIMINATION LOOP
  22838. C
  22839. C
  22840. C    BACK SUBSTITUTION AND BACK INTERCHANGE
  22841. 18    IF(M-1)23,22,19
  22842. 19    IST=MM+M
  22843.     LST=M+1
  22844.     DO 21 I=2,M
  22845.     II=LST-I
  22846.     IST=IST-LST
  22847.     L=IST-M
  22848.     L=A(L)+.5
  22849.     DO 21 J=II,NM,M
  22850.     TB=R(J)
  22851.     LL=J
  22852.     DO 20 K=IST,MM,M
  22853.     LL=LL+1
  22854. 20    TB=TB-A(K)*R(LL)
  22855.     K=J+L
  22856.     R(J)=R(K)
  22857. 21    R(K)=TB
  22858. 22    RETURN
  22859. C
  22860. C
  22861. C    ERROR RETURN
  22862. 23    IER=-1
  22863.     RETURN
  22864.     END
  22865. C
  22866. C    ..................................................................
  22867. C
  22868. C       SUBROUTINE GELS
  22869. C
  22870. C       PURPOSE
  22871. C          TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH
  22872. C          SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH
  22873. C          IS ASSUMED TO BE STORED COLUMNWISE.
  22874. C
  22875. C       USAGE
  22876. C          CALL GELS(R,A,M,N,EPS,IER,AUX)
  22877. C
  22878. C       DESCRIPTION OF PARAMETERS
  22879. C          R      - M BY N RIGHT HAND SIDE MATRIX.  (DESTROYED)
  22880. C                   ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
  22881. C          A      - UPPER TRIANGULAR PART OF THE SYMMETRIC
  22882. C                   M BY M COEFFICIENT MATRIX.  (DESTROYED)
  22883. C          M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
  22884. C          N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
  22885. C          EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
  22886. C                   TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
  22887. C          IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
  22888. C                   IER=0  - NO ERROR,
  22889. C                   IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
  22890. C                            PIVOT ELEMENT AT ANY ELIMINATION STEP
  22891. C                            EQUAL TO 0,
  22892. C                   IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
  22893. C                            CANCE INDICATED AT ELIMINATION STEP K+1,
  22894. C                            WHERE PIVOT ELEMENT WAS LESS THAN OR
  22895. C                            EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
  22896. C                            ABSOLUTELY GREATEST MAIN DIAGONAL
  22897. C                            ELEMENT OF MATRIX A.
  22898. C          AUX    - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1.
  22899. C
  22900. C       REMARKS
  22901. C          UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED
  22902. C          COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT
  22903. C          HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE
  22904. C          LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE
  22905. C          TOO.
  22906. C          THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
  22907. C          GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
  22908. C          ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
  22909. C          INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
  22910. C          SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
  22911. C          INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
  22912. C          GIVEN IN CASE M=1.
  22913. C          ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT
  22914. C          MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS
  22915. C          ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH
  22916. C          WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION.
  22917. C
  22918. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  22919. C          NONE
  22920. C
  22921. C       METHOD
  22922. C          SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
  22923. C          PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE
  22924. C          SYMMETRY IN REMAINING COEFFICIENT MATRICES.
  22925. C
  22926. C    ..................................................................
  22927. C
  22928.     SUBROUTINE GELS(R,A,M,N,EPS,IER,AUX)
  22929. C
  22930. C
  22931.     DIMENSION A(1),R(1),AUX(1)
  22932.     IF(M)24,24,1
  22933. C
  22934. C    SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT
  22935. 1    IER=0
  22936.     PIV=0.
  22937.     L=0
  22938.     DO 3 K=1,M
  22939.     L=L+K
  22940.     TB=ABS(A(L))
  22941.     IF(TB-PIV)3,3,2
  22942. 2    PIV=TB
  22943.     I=L
  22944.     J=K
  22945. 3    CONTINUE
  22946.     TOL=EPS*PIV
  22947. C    MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT.
  22948. C    PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
  22949. C
  22950. C
  22951. C    START ELIMINATION LOOP
  22952.     LST=0
  22953.     NM=N*M
  22954.     LEND=M-1
  22955.     DO 18 K=1,M
  22956. C
  22957. C    TEST ON USEFULNESS OF SYMMETRIC ALGORITHM
  22958.     IF(PIV)24,24,4
  22959. 4    IF(IER)7,5,7
  22960. 5    IF(PIV-TOL)6,6,7
  22961. 6    IER=K-1
  22962. 7    LT=J-K
  22963.     LST=LST+K
  22964. C
  22965. C    PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
  22966.     PIVI=1./A(I)
  22967.     DO 8 L=K,NM,M
  22968.     LL=L+LT
  22969.     TB=PIVI*R(LL)
  22970.     R(LL)=R(L)
  22971. 8    R(L)=TB
  22972. C
  22973. C    IS ELIMINATION TERMINATED
  22974.     IF(K-M)9,19,19
  22975. C
  22976. C    ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A.
  22977. C    ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX.
  22978. 9    LR=LST+(LT*(K+J-1))/2
  22979.     LL=LR
  22980.     L=LST
  22981.     DO 14 II=K,LEND
  22982.     L=L+II
  22983.     LL=LL+1
  22984.     IF(L-LR)12,10,11
  22985. 10    A(LL)=A(LST)
  22986.     TB=A(L)
  22987.     GO TO 13
  22988. 11    LL=L+LT
  22989. 12    TB=A(LL)
  22990.     A(LL)=A(L)
  22991. 13    AUX(II)=TB
  22992. 14    A(L)=PIVI*TB
  22993. C
  22994. C    SAVE COLUMN INTERCHANGE INFORMATION
  22995.     A(LST)=LT
  22996. C
  22997. C    ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT
  22998.     PIV=0.
  22999.     LLST=LST
  23000.     LT=0
  23001.     DO 18 II=K,LEND
  23002.     PIVI=-AUX(II)
  23003.     LL=LLST
  23004.     LT=LT+1
  23005.     DO 15 LLD=II,LEND
  23006.     LL=LL+LLD
  23007.     L=LL+LT
  23008. 15    A(L)=A(L)+PIVI*A(LL)
  23009.     LLST=LLST+II
  23010.     LR=LLST+LT
  23011.     TB=ABS(A(LR))
  23012.     IF(TB-PIV)17,17,16
  23013. 16    PIV=TB
  23014.     I=LR
  23015.     J=II+1
  23016. 17    DO 18 LR=K,NM,M
  23017.     LL=LR+LT
  23018. 18    R(LL)=R(LL)+PIVI*R(LR)
  23019. C    END OF ELIMINATION LOOP
  23020. C
  23021. C
  23022. C    BACK SUBSTITUTION AND BACK INTERCHANGE
  23023. 19    IF(LEND)24,23,20
  23024. 20    II=M
  23025.     DO 22 I=2,M
  23026.     LST=LST-II
  23027.     II=II-1
  23028.     L=A(LST)+.5
  23029.     DO 22 J=II,NM,M
  23030.     TB=R(J)
  23031.     LL=J
  23032.     K=LST
  23033.     DO 21 LT=II,LEND
  23034.     LL=LL+1
  23035.     K=K+LT
  23036. 21    TB=TB-A(K)*R(LL)
  23037.     K=J+L
  23038.     R(J)=R(K)
  23039. 22    R(K)=TB
  23040. 23    RETURN
  23041. C
  23042. C
  23043. C    ERROR RETURN
  23044. 24    IER=-1
  23045.     RETURN
  23046.     END
  23047. C
  23048. C    ..................................................................
  23049. C
  23050. C       SUBROUTINE GMADD
  23051. C
  23052. C       PURPOSE
  23053. C          ADD TWO GENERAL MATRICES TO FORM RESULTANT GENERAL MATRIX
  23054. C
  23055. C       USAGE
  23056. C          CALL GMADD(A,B,R,N,M)
  23057. C
  23058. C       DESCRIPTION OF PARAMETERS
  23059. C          A - NAME OF FIRST INPUT MATRIX
  23060. C          B - NAME OF SECOND INPUT MATRIX
  23061. C          R - NAME OF OUTPUT MATRIX
  23062. C          N - NUMBER OF ROWS IN A,B,R
  23063. C          M - NUMBER OF COLUMNS IN A,B,R
  23064. C
  23065. C       REMARKS
  23066. C          ALL MATRICES MUST BE STORED AS GENERAL MATRICES
  23067. C
  23068. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23069. C          NONE
  23070. C
  23071. C       METHOD
  23072. C          ADDITION IS PERFORMED ELEMENT BY ELEMENT
  23073. C
  23074. C    ..................................................................
  23075. C
  23076.     SUBROUTINE GMADD(A,B,R,N,M)
  23077.     DIMENSION A(1),B(1),R(1)
  23078. C
  23079. C       CALCULATE NUMBER OF ELEMENTS
  23080. C
  23081.     NM=N*M
  23082. C
  23083. C       ADD MATRICES
  23084. C
  23085.     DO 10 I=1,NM
  23086. 10    R(I)=A(I)+B(I)
  23087.     RETURN
  23088.     END
  23089. C
  23090. C    ..................................................................
  23091. C
  23092. C       SUBROUTINE GMMMA
  23093. C
  23094. C       PURPOSE
  23095. C          COMPUTES THE GAMMA FUNCTION FOR A GIVEN ARGUMENT
  23096. C
  23097. C       USAGE
  23098. C          CALL GMMMA(XX,GX,IER)
  23099. C
  23100. C       DESCRIPTION OF PARAMETERS
  23101. C          XX -THE ARGUMENT FOR THE GAMMA FUNCTION
  23102. C          GX -THE RESULTANT GAMMA FUNCTION VALUE
  23103. C          IER-RESULTANT ERROR CODE WHERE
  23104. C              IER=0  NO ERROR
  23105. C              IER=1  XX IS WITHIN .000001 OF BEING A NEGATIVE INTEGER
  23106. C              IER=2  XX GT 57, OVERFLOW, GX SET TO 1.0E75
  23107. C
  23108. C       REMARKS
  23109. C          NONE
  23110. C
  23111. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23112. C          NONE
  23113. C
  23114. C       METHOD
  23115. C          THE RECURSION RELATION AND POLYNOMIAL APPROXIMATION
  23116. C          BY C.HASTINGS,JR., 'APPROXIMATIONS FOR DIGITAL COMPUTERS',
  23117. C          PRINCETON UNIVERSITY PRESS, 1955
  23118. C
  23119. C    ..................................................................
  23120. C
  23121.     SUBROUTINE GMMMA(XX,GX,IER)
  23122.     IF(XX-57.)6,6,4
  23123. 4    IER=2
  23124.     GX=1.7E38                                                                 0
  23125.     RETURN
  23126. 6    X=XX
  23127.     ERR=1.0E-6
  23128.     IER=0
  23129.     GX=1.0
  23130.     IF(X-2.0)50,50,15
  23131. 10    IF(X-2.0)110,110,15
  23132. 15    X=X-1.0
  23133.     GX=GX*X
  23134.     GO TO 10
  23135. 50    IF(X-1.0)60,120,110
  23136. C
  23137. C       SEE IF X IS NEAR NEGATIVE INTEGER OR ZERO
  23138. C
  23139. 60    IF(X-ERR)62,62,80
  23140. 62    Y=FLOAT(INT(X))-X
  23141.     IF(ABS(Y)-ERR)130,130,64
  23142. 64    IF(1.0-Y-ERR)130,130,70
  23143. C
  23144. C       X NOT NEAR A NEGATIVE INTEGER OR ZERO
  23145. C
  23146. 70    IF(X-1.0)80,80,110
  23147. 80    GX=GX/X
  23148.     X=X+1.0
  23149.     GO TO 70
  23150. 110    Y=X-1.0
  23151.     GY=1.0+Y*(-0.5771017+Y*(+0.9858540+Y*(-0.8764218+Y*(+0.8328212+
  23152.      1Y*(-0.5684729+Y*(+0.2548205+Y*(-0.05149930)))))))
  23153.     GX=GX*GY
  23154. 120    RETURN
  23155. 130    IER=1
  23156.     RETURN
  23157.     END
  23158. C
  23159. C    ..................................................................
  23160. C
  23161. C       SUBROUTINE GMPRD
  23162. C
  23163. C       PURPOSE
  23164. C          MULTIPLY TWO GENERAL MATRICES TO FORM A RESULTANT GENERAL
  23165. C          MATRIX
  23166. C
  23167. C       USAGE
  23168. C          CALL GMPRD(A,B,R,N,M,L)
  23169. C
  23170. C       DESCRIPTION OF PARAMETERS
  23171. C          A - NAME OF FIRST INPUT MATRIX
  23172. C          B - NAME OF SECOND INPUT MATRIX
  23173. C          R - NAME OF OUTPUT MATRIX
  23174. C          N - NUMBER OF ROWS IN A
  23175. C          M - NUMBER OF COLUMNS IN A AND ROWS IN B
  23176. C          L - NUMBER OF COLUMNS IN B
  23177. C
  23178. C       REMARKS
  23179. C          ALL MATRICES MUST BE STORED AS GENERAL MATRICES
  23180. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
  23181. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B
  23182. C          NUMBER OF COLUMNS OF MATRIX A MUST BE EQUAL TO NUMBER OF ROW
  23183. C          OF MATRIX B
  23184. C
  23185. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23186. C          NONE
  23187. C
  23188. C       METHOD
  23189. C          THE M BY L MATRIX B IS PREMULTIPLIED BY THE N BY M MATRIX A
  23190. C          AND THE RESULT IS STORED IN THE N BY L MATRIX R.
  23191. C
  23192. C    ..................................................................
  23193. C
  23194.     SUBROUTINE GMPRD(A,B,R,N,M,L)
  23195.     DIMENSION A(1),B(1),R(1)
  23196. C
  23197.     IR=0
  23198.     IK=-M
  23199.     DO 10 K=1,L
  23200.     IK=IK+M
  23201.     DO 10 J=1,N
  23202.     IR=IR+1
  23203.     JI=J-N
  23204.     IB=IK
  23205.     R(IR)=0
  23206.     DO 10 I=1,M
  23207.     JI=JI+N
  23208.     IB=IB+1
  23209. 10    R(IR)=R(IR)+A(JI)*B(IB)
  23210.     RETURN
  23211.     END
  23212. C
  23213. C    ..................................................................
  23214. C
  23215. C       SUBROUTINE GMSUB
  23216. C
  23217. C       PURPOSE
  23218. C          SUBTRACT ONE GENERAL MATRIX FROM ANOTHER TO FORM RESULTANT
  23219. C          MATRIX
  23220. C
  23221. C       USAGE
  23222. C          CALL GMSUB(A,B,R,N,M)
  23223. C
  23224. C       DESCRIPTION OF PARAMETERS
  23225. C          A - NAME OF FIRST INPUT MATRIX
  23226. C          B - NAME OF SECOND INPUT MATRIX
  23227. C          R - NAME OF OUTPUT MATRIX
  23228. C          N - NUMBER OF ROWS IN A,B,R
  23229. C          M - NUMBER OF COLUMNS IN A,B,R
  23230. C
  23231. C       REMARKS
  23232. C          ALL MATRICES MUST BE STORED AS GENERAL MATRICES
  23233. C
  23234. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23235. C          NONE
  23236. C
  23237. C       METHOD
  23238. C          MATRIX B ELEMENTS ARE SUBTRACTED FROM CORRESPONDING MATRIX A
  23239. C          ELEMENTS
  23240. C
  23241. C    ..................................................................
  23242. C
  23243.     SUBROUTINE GMSUB(A,B,R,N,M)
  23244.     DIMENSION A(1),B(1),R(1)
  23245. C
  23246. C       CALCULATE NUMBER OF ELEMENTS
  23247. C
  23248.     NM=N*M
  23249. C
  23250. C       SUBTRACT MATRICES
  23251. C
  23252.     DO 10 I=1,NM
  23253. 10    R(I)=A(I)-B(I)
  23254.     RETURN
  23255.     END
  23256. C
  23257. C    ..................................................................
  23258. C
  23259. C       SUBROUTINE GMTRA
  23260. C
  23261. C       PURPOSE
  23262. C          TRANSPOSE A GENERAL MATRIX
  23263. C
  23264. C       USAGE
  23265. C          CALL GMTRA(A,R,N,M)
  23266. C
  23267. C       DESCRIPTION OF PARAMETERS
  23268. C          A - NAME OF MATRIX TO BE TRANSPOSED
  23269. C          R - NAME OF RESULTANT MATRIX
  23270. C          N - NUMBER OF ROWS OF A AND COLUMNS OF R
  23271. C          M - NUMBER OF COLUMNS OF A AND ROWS OF R
  23272. C
  23273. C       REMARKS
  23274. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
  23275. C          MATRICES A AND R MUST BE STORED AS GENERAL MATRICES
  23276. C
  23277. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23278. C          NONE
  23279. C
  23280. C       METHOD
  23281. C          TRANSPOSE N BY M MATRIX A TO FORM M BY N MATRIX R
  23282. C
  23283. C    ..................................................................
  23284. C
  23285.     SUBROUTINE GMTRA(A,R,N,M)
  23286.     DIMENSION A(1),R(1)
  23287. C
  23288.     IR=0
  23289.     DO 10 I=1,N
  23290.     IJ=I-N
  23291.     DO 10 J=1,M
  23292.     IJ=IJ+N
  23293.     IR=IR+1
  23294. 10    R(IR)=A(IJ)
  23295.     RETURN
  23296.     END
  23297. C
  23298. C    ..................................................................
  23299. C
  23300. C       SUBROUTINE GTPRD
  23301. C
  23302. C       PURPOSE
  23303. C          PREMULTIPLY A GENERAL MATRIX BY THE TRANSPOSE OF ANOTHER
  23304. C          GENERAL MATRIX
  23305. C
  23306. C       USAGE
  23307. C          CALL GTPRD(A,B,R,N,M,L)
  23308. C
  23309. C       DESCRIPTION OF PARAMETERS
  23310. C          A - NAME OF FIRST INPUT MATRIX
  23311. C          B - NAME OF SECOND INPUT MATRIX
  23312. C          R - NAME OF OUTPUT MATRIX
  23313. C          N - NUMBER OF ROWS IN A AND B
  23314. C          M - NUMBER OF COLUMNS IN A AND ROWS IN R
  23315. C          L - NUMBER OF COLUMNS IN B AND R
  23316. C
  23317. C       REMARKS
  23318. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
  23319. C          MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B
  23320. C          ALL MATRICES MUST BE STORED AS GENERAL MATRICES
  23321. C
  23322. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23323. C          NONE
  23324. C
  23325. C       METHOD
  23326. C          MATRIX TRANSPOSE OF A IS NOT ACTUALLY CALCULATED. INSTEAD,
  23327. C          ELEMENTS OF MATRIX A ARE TAKEN COLUMNWISE RATHER THAN
  23328. C          ROWWISE FOR POSTMULTIPLICATION BY MATRIX B.
  23329. C
  23330. C    ..................................................................
  23331. C
  23332.     SUBROUTINE GTPRD(A,B,R,N,M,L)
  23333.     DIMENSION A(1),B(1),R(1)
  23334. C
  23335.     IR=0
  23336.     IK=-N
  23337.     DO 10 K=1,L
  23338.     IJ=0
  23339.     IK=IK+N
  23340.     DO 10 J=1,M
  23341.     IB=IK
  23342.     IR=IR+1
  23343.     R(IR)=0
  23344.     DO 10 I=1,N
  23345.     IJ=IJ+1
  23346.     IB=IB+1
  23347. 10    R(IR)=R(IR)+A(IJ)*B(IB)
  23348.     RETURN
  23349.     END
  23350. C
  23351. C    ..................................................................
  23352. C
  23353. C       SUBROUTINE HARM
  23354. C
  23355. C       PURPOSE
  23356. C          PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX
  23357. C          THREE DIMENSIONAL ARRAY
  23358. C
  23359. C       USAGE
  23360. C          CALL HARM (A,M,INV,S,IFSET,IFERR)
  23361. C
  23362. C       DESCRIPTION OF PARAMETERS
  23363. C          A     - AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL
  23364. C                  ARRAY TO BE TRANSFORMED.  THE REAL PART OF
  23365. C                  A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL
  23366. C                  WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE
  23367. C                  NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC.
  23368. C                  THE IMAGINARY PART IS IN THE CELL IMMEDIATELY
  23369. C                  FOLLOWING.  NOTE THAT THE SUBSCRIPT I1 INCREASES
  23370. C                  MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY.
  23371. C                  AS OUTPUT, A CONTAINS THE COMPLEX FOURIER
  23372. C                  TRANSFORM.  THE NUMBER OF CORE LOCATIONS OF
  23373. C                  ARRAY A IS 2*(N1*N2*N3)
  23374. C          M     - A THREE CELL VECTOR WHICH DETERMINES THE SIZES
  23375. C                  OF THE 3 DIMENSIONS OF THE ARRAY A.   THE SIZE,
  23376. C                  NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3
  23377. C          INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION
  23378. C                  OF DIMENSION ONE FOURTH OF THE QUANTITY
  23379. C                  MAX(N1,N2,N3)
  23380. C          S     - A VECTOR WORK AREA FOR SINE TABLES WITH DIMENSION
  23381. C                  THE SAME AS INV
  23382. C          IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS
  23383. C                     0    SET UP SINE AND INV TABLES ONLY
  23384. C                     1    SET UP SINE AND INV TABLES ONLY AND
  23385. C                          CALCULATE FOURIER TRANSFORM
  23386. C                    -1    SET UP SINE AND INV TABLES ONLY AND
  23387. C                          CALCULATE INVERSE FOURIER TRANSFORM (FOR
  23388. C                          THE MEANING OF INVERSE SEE THE EQUATIONS
  23389. C                          UNDER METHOD BELOW)
  23390. C                     2    CALCULATE FOURIER TRANSFORM ONLY (ASSUME
  23391. C                          SINE AND INV TABLES EXIST)
  23392. C                    -2    CALCULATE INVERSE FOURIER TRANSFORM ONLY
  23393. C                          (ASSUME SINE AND INV TABLES EXIST)
  23394. C          IFERR - ERROR INDICATOR.   WHEN IFSET IS 0,+1,-1,
  23395. C                  IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN
  23396. C                 20 , I=1,2,3   WHEN IFSET IS 2,-2 , IFERR = 1
  23397. C                  MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE
  23398. C                  ENOUGH OR HAVE NOT BEEN COMPUTED .
  23399. C                  IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE
  23400. C                  CONDITIONS ARE PRESENT
  23401. C
  23402. C       REMARKS
  23403. C          THIS SUBROUTINE IS TO BE USED FOR COMPLEX, 3-DIMENSIONAL
  23404. C          ARRAYS IN WHICH EACH DIMENSION IS A POWER OF 2.  THE
  23405. C          MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN 20,
  23406. C          I = 1,2,3
  23407. C
  23408. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23409. C          NONE
  23410. C
  23411. C       METHOD
  23412. C          FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX
  23413. C          ARRAY A IS OBTAINED.
  23414. C
  23415. C                 N1-1   N2-1   N3-1                L1   L2   L3
  23416. C    X(J1,J2,J3)=SUM    SUM    SUM    A(K1,K2,K3)*W1  *W2  *W3
  23417. C                 K1=0   K2=0   K3=0
  23418. C
  23419. C                 WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1,
  23420. C                       L2=K2*J2, L3=K3*J3
  23421. C
  23422. C
  23423. C          FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF
  23424. C          COMPLEX ARRAY X IS OBTAINED.
  23425. C
  23426. C    A(K1,K2,K3)=
  23427. C              1      N1-1   N2-1   N3-1                -L1  -L2  -L3
  23428. C          -------- *SUM    SUM    SUM    X(J1,J2,J3)*W1  *W2  *W3
  23429. C          N1*N2*N3   J1=0   J2=0   J3=0
  23430. C
  23431. C
  23432. C          SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE
  23433. C          MACHINE CALCULATION OF COMPLEX FOURIER SERIES',
  23434. C          MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297.
  23435. C
  23436. C    ..................................................................
  23437. C
  23438.     SUBROUTINE HARM(A,M,INV,S,IFSET, IFERR)
  23439.     DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2)
  23440.     EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3)
  23441. 10    IF( IABS(IFSET) - 1) 900,900,12
  23442. 12    MTT=MAX0(M(1),M(2),M(3)) -2
  23443.     ROOT2 = SQRT(2.)
  23444.     IF (MTT-MT ) 14,14,13
  23445. 13    IFERR=1
  23446.     RETURN
  23447. 14    IFERR=0
  23448.     M1=M(1)
  23449.     M2=M(2)
  23450.     M3=M(3)
  23451.     N1=2**M1
  23452.     N2=2**M2
  23453.     N3=2**M3
  23454. 16    IF(IFSET) 18,18,20
  23455. 18    NX= N1*N2*N3
  23456.     FN = NX
  23457.     DO 19 I = 1,NX
  23458.     A(2*I-1) = A(2*I-1)/FN
  23459. 19    A(2*I) = -A(2*I)/FN
  23460. 20    NP(1)=N1*2
  23461.     NP(2)= NP(1)*N2
  23462.     NP(3)=NP(2)*N3
  23463.     DO 250 ID=1,3
  23464.     IL = NP(3)-NP(ID)
  23465.     IL1 = IL+1
  23466.     MI = M(ID)
  23467.     IF (MI)250,250,30
  23468. 30    IDIF=NP(ID)
  23469.     KBIT=NP(ID)
  23470.     MEV = 2*(MI/2)
  23471.     IF (MI - MEV )60,60,40
  23472. C
  23473. C    M IS ODD. DO L=1 CASE
  23474. 40    KBIT=KBIT/2
  23475.     KL=KBIT-2
  23476.     DO 50 I=1,IL1,IDIF
  23477.     KLAST=KL+I
  23478.     DO 50 K=I,KLAST,2
  23479.     KD=K+KBIT
  23480. C
  23481. C    DO ONE STEP WITH L=1,J=0
  23482. C    A(K)=A(K)+A(KD)
  23483. C    A(KD)=A(K)-A(KD)
  23484. C
  23485.     T=A(KD)
  23486.     A(KD)=A(K)-T
  23487.     A(K)=A(K)+T
  23488.     T=A(KD+1)
  23489.     A(KD+1)=A(K+1)-T
  23490. 50    A(K+1)=A(K+1)+T
  23491.     IF (MI - 1)250,250,52
  23492. 52    LFIRST =3
  23493. C
  23494. C    DEF - JLAST = 2**(L-2) -1
  23495.     JLAST=1
  23496.     GO TO 70
  23497. C
  23498. C    M IS EVEN
  23499. 60    LFIRST = 2
  23500.     JLAST=0
  23501. 70    DO 240 L=LFIRST,MI,2
  23502.     JJDIF=KBIT
  23503.     KBIT=KBIT/4
  23504.     KL=KBIT-2
  23505. C
  23506. C    DO FOR J=0
  23507.     DO 80 I=1,IL1,IDIF
  23508.     KLAST=I+KL
  23509.     DO 80 K=I,KLAST,2
  23510.     K1=K+KBIT
  23511.     K2=K1+KBIT
  23512.     K3=K2+KBIT
  23513. C
  23514. C    DO TWO STEPS WITH J=0
  23515. C    A(K)=A(K)+A(K2)
  23516. C    A(K2)=A(K)-A(K2)
  23517. C    A(K1)=A(K1)+A(K3)
  23518. C    A(K3)=A(K1)-A(K3)
  23519. C
  23520. C    A(K)=A(K)+A(K1)
  23521. C    A(K1)=A(K)-A(K1)
  23522. C    A(K2)=A(K2)+A(K3)*I
  23523. C    A(K3)=A(K2)-A(K3)*I
  23524. C
  23525.     T=A(K2)
  23526.     A(K2)=A(K)-T
  23527.     A(K)=A(K)+T
  23528.     T=A(K2+1)
  23529.     A(K2+1)=A(K+1)-T
  23530.     A(K+1)=A(K+1)+T
  23531. C
  23532.     T=A(K3)
  23533.     A(K3)=A(K1)-T
  23534.     A(K1)=A(K1)+T
  23535.     T=A(K3+1)
  23536.     A(K3+1)=A(K1+1)-T
  23537.     A(K1+1)=A(K1+1)+T
  23538. C
  23539.     T=A(K1)
  23540.     A(K1)=A(K)-T
  23541.     A(K)=A(K)+T
  23542.     T=A(K1+1)
  23543.     A(K1+1)=A(K+1)-T
  23544.     A(K+1)=A(K+1)+T
  23545. C
  23546.     R=-A(K3+1)
  23547.     T = A(K3)
  23548.     A(K3)=A(K2)-R
  23549.     A(K2)=A(K2)+R
  23550.     A(K3+1)=A(K2+1)-T
  23551. 80    A(K2+1)=A(K2+1)+T
  23552.     IF (JLAST) 235,235,82
  23553. 82    JJ=JJDIF   +1
  23554. C
  23555. C    DO FOR J=1
  23556.     ILAST= IL +JJ
  23557.     DO 85 I = JJ,ILAST,IDIF
  23558.     KLAST = KL+I
  23559.     DO 85 K=I,KLAST,2
  23560.     K1 = K+KBIT
  23561.     K2 = K1+KBIT
  23562.     K3 = K2+KBIT
  23563. C
  23564. C    LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I,
  23565. C    A(K)=A(K)+A(K2)*I
  23566. C    A(K2)=A(K)-A(K2)*I
  23567. C    A(K1)=A(K1)*W+A(K3)*W3
  23568. C    A(K3)=A(K1)*W-A(K3)*W3
  23569. C
  23570. C    A(K)=A(K)+A(K1)
  23571. C    A(K1)=A(K)-A(K1)
  23572. C    A(K2)=A(K2)+A(K3)*I
  23573. C    A(K3)=A(K2)-A(K3)*I
  23574. C
  23575.     R =-A(K2+1)
  23576.     T = A(K2)
  23577.     A(K2) = A(K)-R
  23578.     A(K) = A(K)+R
  23579.     A(K2+1)=A(K+1)-T
  23580.     A(K+1)=A(K+1)+T
  23581. C
  23582.     AWR=A(K1)-A(K1+1)
  23583.     AWI = A(K1+1)+A(K1)
  23584.     R=-A(K3)-A(K3+1)
  23585.     T=A(K3)-A(K3+1)
  23586.     A(K3)=(AWR-R)/ROOT2
  23587.     A(K3+1)=(AWI-T)/ROOT2
  23588.     A(K1)=(AWR+R)/ROOT2
  23589.     A(K1+1)=(AWI+T)/ROOT2
  23590.     T= A(K1)
  23591.     A(K1)=A(K)-T
  23592.     A(K)=A(K)+T
  23593.     T=A(K1+1)
  23594.     A(K1+1)=A(K+1)-T
  23595.     A(K+1)=A(K+1)+T
  23596.     R=-A(K3+1)
  23597.     T=A(K3)
  23598.     A(K3)=A(K2)-R
  23599.     A(K2)=A(K2)+R
  23600.     A(K3+1)=A(K2+1)-T
  23601. 85    A(K2+1)=A(K2+1)+T
  23602.     IF(JLAST-1) 235,235,90
  23603. 90    JJ= JJ + JJDIF
  23604. C
  23605. C    NOW DO THE REMAINING J'S
  23606.     DO 230 J=2,JLAST
  23607. C
  23608. C    FETCH W'S
  23609. C    DEF- W=W**INV(J), W2=W**2, W3=W**3
  23610. 96    I=INV(J+1)
  23611. 98    IC=NT-I
  23612.     W(1)=S(IC)
  23613.     W(2)=S(I)
  23614.     I2=2*I
  23615.     I2C=NT-I2
  23616.     IF(I2C)120,110,100
  23617. C
  23618. C    2*I IS IN FIRST QUADRANT
  23619. 100    W2(1)=S(I2C)
  23620.     W2(2)=S(I2)
  23621.     GO TO 130
  23622. 110    W2(1)=0.
  23623.     W2(2)=1.
  23624.     GO TO 130
  23625. C
  23626. C    2*I IS IN SECOND QUADRANT
  23627. 120    I2CC = I2C+NT
  23628.     I2C=-I2C
  23629.     W2(1)=-S(I2C)
  23630.     W2(2)=S(I2CC)
  23631. 130    I3=I+I2
  23632.     I3C=NT-I3
  23633.     IF(I3C)160,150,140
  23634. C
  23635. C    I3 IN FIRST QUADRANT
  23636. 140    W3(1)=S(I3C)
  23637.     W3(2)=S(I3)
  23638.     GO TO 200
  23639. 150    W3(1)=0.
  23640.     W3(2)=1.
  23641.     GO TO 200
  23642. C
  23643. 160    I3CC=I3C+NT
  23644.     IF(I3CC)190,180,170
  23645. C
  23646. C    I3 IN SECOND QUADRANT
  23647. 170    I3C=-I3C
  23648.     W3(1)=-S(I3C)
  23649.     W3(2)=S(I3CC)
  23650.     GO TO 200
  23651. 180    W3(1)=-1.
  23652.     W3(2)=0.
  23653.     GO TO 200
  23654. C
  23655. C    3*I IN THIRD QUADRANT
  23656. 190    I3CCC=NT+I3CC
  23657.     I3CC = -I3CC
  23658.     W3(1)=-S(I3CCC)
  23659.     W3(2)=-S(I3CC)
  23660. 200    ILAST=IL+JJ
  23661.     DO 220 I=JJ,ILAST,IDIF
  23662.     KLAST=KL+I
  23663.     DO 220 K=I,KLAST,2
  23664.     K1=K+KBIT
  23665.     K2=K1+KBIT
  23666.     K3=K2+KBIT
  23667. C
  23668. C    DO TWO STEPS WITH J NOT 0
  23669. C    A(K)=A(K)+A(K2)*W2
  23670. C    A(K2)=A(K)-A(K2)*W2
  23671. C    A(K1)=A(K1)*W+A(K3)*W3
  23672. C    A(K3)=A(K1)*W-A(K3)*W3
  23673. C
  23674. C    A(K)=A(K)+A(K1)
  23675. C    A(K1)=A(K)-A(K1)
  23676. C    A(K2)=A(K2)+A(K3)*I
  23677. C    A(K3)=A(K2)-A(K3)*I
  23678. C
  23679.     R=A(K2)*W2(1)-A(K2+1)*W2(2)
  23680.     T=A(K2)*W2(2)+A(K2+1)*W2(1)
  23681.     A(K2)=A(K)-R
  23682.     A(K)=A(K)+R
  23683.     A(K2+1)=A(K+1)-T
  23684.     A(K+1)=A(K+1)+T
  23685. C
  23686.     R=A(K3)*W3(1)-A(K3+1)*W3(2)
  23687.     T=A(K3)*W3(2)+A(K3+1)*W3(1)
  23688.     AWR=A(K1)*W(1)-A(K1+1)*W(2)
  23689.     AWI=A(K1)*W(2)+A(K1+1)*W(1)
  23690.     A(K3)=AWR-R
  23691.     A(K3+1)=AWI-T
  23692.     A(K1)=AWR+R
  23693.     A(K1+1)=AWI+T
  23694.     T=A(K1)
  23695.     A(K1)=A(K)-T
  23696.     A(K)=A(K)+T
  23697.     T=A(K1+1)
  23698.     A(K1+1)=A(K+1)-T
  23699.     A(K+1)=A(K+1)+T
  23700.     R=-A(K3+1)
  23701.     T=A(K3)
  23702.     A(K3)=A(K2)-R
  23703.     A(K2)=A(K2)+R
  23704.     A(K3+1)=A(K2+1)-T
  23705. 220    A(K2+1)=A(K2+1)+T
  23706. C    END OF I AND K LOOPS
  23707. C
  23708. 230    JJ=JJDIF+JJ
  23709. C    END OF J-LOOP
  23710. C
  23711. 235    JLAST=4*JLAST+3
  23712. 240    CONTINUE
  23713. C    END OF  L  LOOP
  23714. C
  23715. 250    CONTINUE
  23716. C    END OF  ID  LOOP
  23717. C
  23718. C    WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE
  23719. C    BIT-REVERSED.  THE FOLLOWING ROUTINE PUTS THEM IN ORDER
  23720.     NTSQ=NT*NT
  23721.     M3MT=M3-MT
  23722. 350    IF(M3MT) 370,360,360
  23723. C
  23724. C    M3 GR. OR EQ. MT
  23725. 360    IGO3=1
  23726.     N3VNT=N3/NT
  23727.     MINN3=NT
  23728.     GO TO 380
  23729. C
  23730. C    M3 LESS THAN MT
  23731. 370    IGO3=2
  23732.     N3VNT=1
  23733.     NTVN3=NT/N3
  23734.     MINN3=N3
  23735. 380    JJD3 = NTSQ/N3
  23736.     M2MT=M2-MT
  23737. 450    IF (M2MT)470,460,460
  23738. C
  23739. C    M2 GR. OR EQ. MT
  23740. 460    IGO2=1
  23741.     N2VNT=N2/NT
  23742.     MINN2=NT
  23743.     GO TO 480
  23744. C
  23745. C    M2 LESS THAN MT
  23746. 470    IGO2 = 2
  23747.     N2VNT=1
  23748.     NTVN2=NT/N2
  23749.     MINN2=N2
  23750. 480    JJD2=NTSQ/N2
  23751.     M1MT=M1-MT
  23752. 550    IF(M1MT)570,560,560
  23753. C
  23754. C    M1 GR. OR EQ. MT
  23755. 560    IGO1=1
  23756.     N1VNT=N1/NT
  23757.     MINN1=NT
  23758.     GO TO 580
  23759. C
  23760. C    M1 LESS THAN MT
  23761. 570    IGO1=2
  23762.     N1VNT=1
  23763.     NTVN1=NT/N1
  23764.     MINN1=N1
  23765. 580    JJD1=NTSQ/N1
  23766. 600    JJ3=1
  23767.     J=1
  23768.     DO 880 JPP3=1,N3VNT
  23769.     IPP3=INV(JJ3)
  23770.     DO 870 JP3=1,MINN3
  23771.     GO TO (610,620),IGO3
  23772. 610    IP3=INV(JP3)*N3VNT
  23773.     GO TO 630
  23774. 620    IP3=INV(JP3)/NTVN3
  23775. 630    I3=(IPP3+IP3)*N2
  23776. 700    JJ2=1
  23777.     DO 870 JPP2=1,N2VNT
  23778.     IPP2=INV(JJ2)+I3
  23779.     DO 860 JP2=1,MINN2
  23780.     GO TO (710,720),IGO2
  23781. 710    IP2=INV(JP2)*N2VNT
  23782.     GO TO 730
  23783. 720    IP2=INV(JP2)/NTVN2
  23784. 730    I2=(IPP2+IP2)*N1
  23785. 800    JJ1=1
  23786.     DO 860 JPP1=1,N1VNT
  23787.     IPP1=INV(JJ1)+I2
  23788.     DO 850 JP1=1,MINN1
  23789.     GO TO (810,820),IGO1
  23790. 810    IP1=INV(JP1)*N1VNT
  23791.     GO TO 830
  23792. 820    IP1=INV(JP1)/NTVN1
  23793. 830    I=2*(IPP1+IP1)+1
  23794.     IF (J-I) 840,850,850
  23795. 840    T=A(I)
  23796.     A(I)=A(J)
  23797.     A(J)=T
  23798.     T=A(I+1)
  23799.     A(I+1)=A(J+1)
  23800.     A(J+1)=T
  23801. 850    J=J+2
  23802. 860    JJ1=JJ1+JJD1
  23803. C    END OF JPP1 AND JP2
  23804. C
  23805. 870    JJ2=JJ2+JJD2
  23806. C    END OF JPP2 AND JP3 LOOPS
  23807. C
  23808. 880    JJ3 = JJ3+JJD3
  23809. C    END OF JPP3 LOOP
  23810. C
  23811. 890    IF(IFSET)891,895,895
  23812. 891    DO 892 I = 1,NX
  23813. 892    A(2*I) = -A(2*I)
  23814. 895    RETURN
  23815. C
  23816. C    THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES.
  23817. C
  23818. 900    MT=MAX0(M(1),M(2),M(3)) -2
  23819.     MT = MAX0(2,MT)
  23820. 904    IF (MT-18) 906,906,13
  23821. 906    IFERR=0
  23822.     NT=2**MT
  23823.     NTV2=NT/2
  23824. C
  23825. C    SET UP SIN TABLE
  23826. C    THETA=PIE/2**(L+1) FOR L=1
  23827. 910    THETA=.7853981634
  23828. C
  23829. C    JSTEP=2**(MT-L+1) FOR L=1
  23830.     JSTEP=NT
  23831. C
  23832. C    JDIF=2**(MT-L) FOR L=1
  23833.     JDIF=NTV2
  23834.     S(JDIF)=SIN(THETA)
  23835.     DO 950 L=2,MT
  23836.     THETA=THETA/2.
  23837.     JSTEP2=JSTEP
  23838.     JSTEP=JDIF
  23839.     JDIF=JSTEP/2
  23840.     S(JDIF)=SIN(THETA)
  23841.     JC1=NT-JDIF
  23842.     S(JC1)=COS(THETA)
  23843.     JLAST=NT-JSTEP2
  23844.     IF(JLAST - JSTEP) 950,920,920
  23845. 920    DO 940 J=JSTEP,JLAST,JSTEP
  23846.     JC=NT-J
  23847.     JD=J+JDIF
  23848. 940    S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC)
  23849. 950    CONTINUE
  23850. C
  23851. C    SET UP INV(J) TABLE
  23852. C
  23853. 960    MTLEXP=NTV2
  23854. C
  23855. C    MTLEXP=2**(MT-L). FOR L=1
  23856.     LM1EXP=1
  23857. C
  23858. C    LM1EXP=2**(L-1). FOR L=1
  23859.     INV(1)=0
  23860.     DO 980 L=1,MT
  23861.     INV(LM1EXP+1) = MTLEXP
  23862.     DO 970 J=2,LM1EXP
  23863.     JJ=J+LM1EXP
  23864. 970    INV(JJ)=INV(J)+MTLEXP
  23865.     MTLEXP=MTLEXP/2
  23866. 980    LM1EXP=LM1EXP*2
  23867. 982    IF(IFSET)12,895,12
  23868.     END
  23869. C
  23870. C    ..................................................................
  23871. C
  23872. C       SUBROUTINE HEP
  23873. C
  23874. C       PURPOSE
  23875. C          COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X)
  23876. C          FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
  23877. C
  23878. C       USAGE
  23879. C          CALL HEP(Y,X,N)
  23880. C
  23881. C       DESCRIPTION OF PARAMETERS
  23882. C          Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
  23883. C                  OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N
  23884. C                  FOR GIVEN ARGUMENT X.
  23885. C                  VALUES ARE ORDERED FROM LOW TO HIGH ORDER
  23886. C          X     - ARGUMENT OF HERMITE POLYNOMIAL
  23887. C          N     - ORDER OF HERMITE POLYNOMIAL
  23888. C
  23889. C       REMARKS
  23890. C          N LESS THAN 0 IS TREATED AS IF N WERE 0
  23891. C
  23892. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23893. C          NONE
  23894. C
  23895. C       METHOD
  23896. C          EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
  23897. C          HERMITE POLYNOMIALS H(N,X)
  23898. C          H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X))
  23899. C          WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
  23900. C          THE SECOND IS THE ARGUMENT.
  23901. C          STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X.
  23902. C
  23903. C    ..................................................................
  23904. C
  23905.     SUBROUTINE HEP(Y,X,N)
  23906. C
  23907.     DIMENSION Y(1)
  23908. C
  23909. C       TEST OF ORDER
  23910.     Y(1)=1.
  23911.     IF(N)1,1,2
  23912. 1    RETURN
  23913. C
  23914. 2    Y(2)=X+X
  23915.     IF(N-1)1,1,3
  23916. C
  23917. 3    DO 4 I=2,N
  23918.     F=X*Y(I)-FLOAT(I-1)*Y(I-1)
  23919. 4    Y(I+1)=F+F
  23920.     RETURN
  23921.     END
  23922. C
  23923. C    ..................................................................
  23924. C
  23925. C       SUBROUTINE HEPS
  23926. C
  23927. C       PURPOSE
  23928. C          COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE
  23929. C          POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
  23930. C
  23931. C       USAGE
  23932. C          CALL HEPS(Y,X,C,N)
  23933. C
  23934. C       DESCRIPTION OF PARAMETERS
  23935. C          Y     - RESULT VALUE
  23936. C          X     - ARGUMENT VALUE
  23937. C          C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
  23938. C                  COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
  23939. C          N     - DIMENSION OF COEFFICIENT VECTOR C
  23940. C
  23941. C       REMARKS
  23942. C          OPERATION IS BYPASSED IN CASE N LESS THAN 1
  23943. C
  23944. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  23945. C          NONE
  23946. C
  23947. C       METHOD
  23948. C          DEFINITION
  23949. C          Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
  23950. C          EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
  23951. C          USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS
  23952. C          H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)).
  23953. C
  23954. C    ..................................................................
  23955. C
  23956.     SUBROUTINE HEPS(Y,X,C,N)
  23957. C
  23958.     DIMENSION C(1)
  23959. C
  23960. C       TEST OF DIMENSION
  23961.     IF(N)1,1,2
  23962. 1    RETURN
  23963. C
  23964. 2    Y=C(1)
  23965.     IF(N-2)1,3,3
  23966. C
  23967. C       INITIALIZATION
  23968. 3    H0=1.
  23969.     H1=X+X
  23970. C
  23971.     DO 4 I=2,N
  23972.     H2=X*H1-FLOAT(I-1)*H0
  23973.     H0=H1
  23974.     H1=H2+H2
  23975. 4    Y=Y+C(I)*H0
  23976.     RETURN
  23977.     END
  23978. C
  23979. C    ..................................................................
  23980. C
  23981. C       SUBROUTINE HIST
  23982. C
  23983. C       PURPOSE
  23984. C          PRINT A HISTOGRAM OF FREQUENCIES VERSUS INTERVALS
  23985. C
  23986. C       USAGE
  23987. C          CALL HIST(NU,FREQ,IN)
  23988. C
  23989. C       DESCRIPTION OF PARAMETERS
  23990. C          NU   - HISTOGRAM NUMBER (3 DIGITS MAXIMUM)
  23991. C          FREQ - VECTOR OF FREQUENCIES
  23992. C          IN   - NUMBER OF INTERVALS AND LENGTH OF FREQ (MAX IS 20)
  23993. C                 NORMALLY, FREQ(1) CONTAINS THE FREQUENCY SMALLER THAN
  23994. C                 THE LOWER BOUND AND FREQ(IN) CONTAINS THE FREQUENCY
  23995. C                 LARGER THAN THE UPPER BOUND
  23996. C
  23997. C       REMARKS
  23998. C          FREQUENCIES MUST BE POSITIVE NUMBERS
  23999. C
  24000. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  24001. C          NONE
  24002. C
  24003. C       METHOD
  24004. C          THE LARGEST FREQUENCY IS DETERMINED AND SCALING IS USED
  24005. C          IF REQUIRED
  24006. C
  24007. C    ..................................................................
  24008. C
  24009.     SUBROUTINE HIST(NU,FREQ,IN)
  24010.     DIMENSION JOUT(20),FREQ(20)
  24011. C
  24012. 1    FORMAT(6H EACH ,A1,8H EQUALS ,I2,7H POINTS,/)
  24013. 2    FORMAT(I6,4X,20(4X,A1))
  24014. 3    FORMAT(9H0INTERVAL,4X,19(I2,3X),I2)
  24015. 4    FORMAT(1H1,47X,11H HISTOGRAM ,I3)
  24016. 5    FORMAT(10H0FREQUENCY,20I5)
  24017. 6    FORMAT(6H CLASS)
  24018. 7     FORMAT(113H   ----------------------------------------------------
  24019.      1----------------------------------------------------------)
  24020. 8    FORMAT(1H )
  24021. 9    FORMAT(A1)
  24022. 10    FORMAT(1H*)
  24023. C
  24024.     REWIND 13
  24025.     WRITE(13,10)
  24026.     REWIND 13
  24027.     READ(13,9) K
  24028.     REWIND 13
  24029.     WRITE(13,8)
  24030.     REWIND 13
  24031.     READ(13,9) NOTH
  24032.     REWIND 13
  24033. C
  24034. C       PRINT TITLE AND FREQUENCY VECTOR
  24035. C
  24036.     WRITE(6,4) NU
  24037.     DO 12 I=1,IN
  24038. 12    JOUT(I)=FREQ(I)
  24039.     WRITE(6,5)(JOUT(I),I=1,IN)
  24040.     WRITE(6,7)
  24041. C
  24042. C       FIND LARGEST FREQUENCY
  24043. C
  24044.     FMAX=0.0
  24045.     DO 20 I=1,IN
  24046.     IF(FREQ(I)-FMAX) 20,20,15
  24047. 15    FMAX=FREQ(I)
  24048. 20    CONTINUE
  24049. C
  24050. C       SCALE IF NECESSARY
  24051. C
  24052.     JSCAL=1
  24053.     IF(FMAX-50.0) 40,40,30
  24054. 30    JSCAL=(FMAX+49.0)/50.0
  24055.     WRITE(6,1)K,JSCAL
  24056. C
  24057. C       CLEAR OUTPUT AREA TO BLANKS
  24058. C
  24059. 40    DO 50 I=1,IN
  24060. 50    JOUT(I)=NOTH
  24061. C
  24062. C       LOCATE FREQUENCIES IN EACH INTERVAL
  24063. C
  24064.     MAX=FMAX/FLOAT(JSCAL)
  24065.     DO 80 I=1,MAX
  24066.     X=MAX-(I-1)
  24067.     DO 70 J=1,IN
  24068.     IF(FREQ(J)/FLOAT(JSCAL)-X) 70,60,60
  24069. 60    JOUT(J)=K
  24070. 70    CONTINUE
  24071.     IX=X*FLOAT(JSCAL)
  24072. C
  24073. C       PRINT LINE OF FREQUENCIES
  24074. C
  24075. 80    WRITE(6,2)IX,(JOUT(J),J=1,IN)
  24076. C
  24077. C       GENERATE CONSTANTS
  24078. C
  24079.     DO 90 I=1,IN
  24080. 90    JOUT(I)=I
  24081. C
  24082. C       PRINT INTERVAL NUMBERS
  24083. C
  24084.     WRITE(6,7)
  24085.     WRITE(6,3)(JOUT(J),J=1,IN)
  24086.     WRITE(6,6)
  24087.     RETURN
  24088.     END
  24089. C
  24090. C
  24091. C    ..................................................................
  24092. C
  24093. C       SUBROUTINE HPCG
  24094. C
  24095. C       PURPOSE
  24096. C          TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL
  24097. C          DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
  24098. C
  24099. C       USAGE
  24100. C          CALL HPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  24101. C          PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
  24102. C
  24103. C       DESCRIPTION OF PARAMETERS
  24104. C          PRMT   - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER
  24105. C                   OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF
  24106. C                   THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR
  24107. C                   COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED
  24108. C                   BY THE USER) AND SUBROUTINE HPCG. EXCEPT PRMT(5)
  24109. C                   THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE
  24110. C                   HPCG AND THEY ARE
  24111. C          PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
  24112. C          PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
  24113. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  24114. C                   (INPUT),
  24115. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
  24116. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  24117. C                   IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
  24118. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  24119. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  24120. C                   OUTPUT SUBROUTINE.
  24121. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCG INITIALIZES
  24122. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  24123. C                   SUBROUTINE HPCG AT ANY OUTPUT POINT, HE HAS TO
  24124. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  24125. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  24126. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  24127. C                   THAN 5. HOWEVER SUBROUTINE HPCG DOES NOT REQUIRE
  24128. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  24129. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  24130. C                   (CALLING HPCG) WHICH ARE OBTAINED BY SPECIAL
  24131. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  24132. C          Y      - INPUT VECTOR OF INITIAL VALUES.  (DESTROYED)
  24133. C                   LATERON Y IS THE RESULTING VECTOR OF DEPENDENT
  24134. C                   VARIABLES COMPUTED AT INTERMEDIATE POINTS X.
  24135. C          DERY   - INPUT VECTOR OF ERROR WEIGHTS.  (DESTROYED)
  24136. C                   THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1.
  24137. C                   LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH
  24138. C                   BELONG TO FUNCTION VALUES Y AT A POINT X.
  24139. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  24140. C                   EQUATIONS IN THE SYSTEM.
  24141. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  24142. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  24143. C                   GREATER THAN 10, SUBROUTINE HPCG RETURNS WITH
  24144. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  24145. C                   ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  24146. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  24147. C                   PRMT(1)) RESPECTIVELY.
  24148. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  24149. C                   COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM
  24150. C                   TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST
  24151. C                   MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT
  24152. C                   DESTROY X AND Y.
  24153. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  24154. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  24155. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  24156. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  24157. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  24158. C                   SUBROUTINE HPCG IS TERMINATED.
  24159. C          AUX    - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM
  24160. C                   COLUMNS.
  24161. C
  24162. C       REMARKS
  24163. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  24164. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  24165. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  24166. C              IHLF=11),
  24167. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
  24168. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  24169. C          (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  24170. C          (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  24171. C
  24172. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  24173. C          THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
  24174. C          OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
  24175. C
  24176. C       METHOD
  24177. C          EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
  24178. C          CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
  24179. C          PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
  24180. C          DEPENDENT VARIABLES.
  24181. C          FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
  24182. C          USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
  24183. C          COMPUTATION OF STARTING VALUES.
  24184. C          SUBROUTINE HPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING
  24185. C          THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
  24186. C          TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
  24187. C          MUST BE CODED BY THE USER.
  24188. C          FOR REFERENCE, SEE
  24189. C          (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
  24190. C               COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
  24191. C          (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
  24192. C               MTAC, VOL.16, ISS.80 (1962), PP.431-437.
  24193. C
  24194. C    ..................................................................
  24195. C
  24196.     SUBROUTINE HPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
  24197. C
  24198. C
  24199.     DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1)
  24200.     N=1
  24201.     IHLF=0
  24202.     X=PRMT(1)
  24203.     H=PRMT(3)
  24204.     PRMT(5)=0.
  24205.     DO 1 I=1,NDIM
  24206.     AUX(16,I)=0.
  24207.     AUX(15,I)=DERY(I)
  24208. 1    AUX(1,I)=Y(I)
  24209.     IF(H*(PRMT(2)-X))3,2,4
  24210. C
  24211. C    ERROR RETURNS
  24212. 2    IHLF=12
  24213.     GOTO 4
  24214. 3    IHLF=13
  24215. C
  24216. C    COMPUTATION OF DERY FOR STARTING VALUES
  24217. 4    CALL FCT(X,Y,DERY)
  24218. C
  24219. C    RECORDING OF STARTING VALUES
  24220.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24221.     IF(PRMT(5))6,5,6
  24222. 5    IF(IHLF)7,7,6
  24223. 6    RETURN
  24224. 7    DO 8 I=1,NDIM
  24225. 8    AUX(8,I)=DERY(I)
  24226. C
  24227. C    COMPUTATION OF AUX(2,I)
  24228.     ISW=1
  24229.     GOTO 100
  24230. C
  24231. 9    X=X+H
  24232.     DO 10 I=1,NDIM
  24233. 10    AUX(2,I)=Y(I)
  24234. C
  24235. C    INCREMENT H IS TESTED BY MEANS OF BISECTION
  24236. 11    IHLF=IHLF+1
  24237.     X=X-H
  24238.     DO 12 I=1,NDIM
  24239. 12    AUX(4,I)=AUX(2,I)
  24240.     H=.5*H
  24241.     N=1
  24242.     ISW=2
  24243.     GOTO 100
  24244. C
  24245. 13    X=X+H
  24246.     CALL FCT(X,Y,DERY)
  24247.     N=2
  24248.     DO 14 I=1,NDIM
  24249.     AUX(2,I)=Y(I)
  24250. 14    AUX(9,I)=DERY(I)
  24251.     ISW=3
  24252.     GOTO 100
  24253. C
  24254. C    COMPUTATION OF TEST VALUE DELT
  24255. 15    DELT=0.
  24256.     DO 16 I=1,NDIM
  24257. 16    DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I))
  24258.     DELT=.06666667*DELT
  24259.     IF(DELT-PRMT(4))19,19,17
  24260. 17    IF(IHLF-10)11,18,18
  24261. C
  24262. C    NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
  24263. 18    IHLF=11
  24264.     X=X+H
  24265.     GOTO 4
  24266. C
  24267. C    THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS.
  24268. 19    X=X+H
  24269.     CALL FCT(X,Y,DERY)
  24270.     DO 20 I=1,NDIM
  24271.     AUX(3,I)=Y(I)
  24272. 20    AUX(10,I)=DERY(I)
  24273.     N=3
  24274.     ISW=4
  24275.     GOTO 100
  24276. C
  24277. 21    N=1
  24278.     X=X+H
  24279.     CALL FCT(X,Y,DERY)
  24280.     X=PRMT(1)
  24281.     DO 22 I=1,NDIM
  24282.     AUX(11,I)=DERY(I)
  24283.    22    Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I)
  24284.      1-.2083333*AUX(10,I)+.04166667*DERY(I))
  24285. 23    X=X+H
  24286.     N=N+1
  24287.     CALL FCT(X,Y,DERY)
  24288.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24289.     IF(PRMT(5))6,24,6
  24290. 24    IF(N-4)25,200,200
  24291. 25    DO 26 I=1,NDIM
  24292.     AUX(N,I)=Y(I)
  24293. 26    AUX(N+7,I)=DERY(I)
  24294.     IF(N-3)27,29,200
  24295. C
  24296. 27    DO 28 I=1,NDIM
  24297.     DELT=AUX(9,I)+AUX(9,I)
  24298.     DELT=DELT+DELT
  24299. 28    Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I))
  24300.     GOTO 23
  24301. C
  24302. 29    DO 30 I=1,NDIM
  24303.     DELT=AUX(9,I)+AUX(10,I)
  24304.     DELT=DELT+DELT+DELT
  24305. 30    Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I))
  24306.     GOTO 23
  24307. C
  24308. C    THE FOLLOWING PART OF SUBROUTINE HPCG COMPUTES BY MEANS OF
  24309. C    RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
  24310. C    PREDICTOR-CORRECTOR METHOD.
  24311. 100    DO 101 I=1,NDIM
  24312.     Z=H*AUX(N+7,I)
  24313.     AUX(5,I)=Z
  24314. 101    Y(I)=AUX(N,I)+.4*Z
  24315. C    Z IS AN AUXILIARY STORAGE LOCATION
  24316. C
  24317.     Z=X+.4*H
  24318.     CALL FCT(Z,Y,DERY)
  24319.     DO 102 I=1,NDIM
  24320.     Z=H*DERY(I)
  24321.     AUX(6,I)=Z
  24322. 102    Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*Z
  24323. C
  24324.     Z=X+.4557372*H
  24325.     CALL FCT(Z,Y,DERY)
  24326.     DO 103 I=1,NDIM
  24327.     Z=H*DERY(I)
  24328.     AUX(7,I)=Z
  24329. 103    Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*Z
  24330. C
  24331.     Z=X+H
  24332.     CALL FCT(Z,Y,DERY)
  24333.     DO 104 I=1,NDIM
  24334.   104    Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I)
  24335.      1+1.205536*AUX(7,I)+.1711848*H*DERY(I)
  24336.     GOTO(9,13,15,21),ISW
  24337. C
  24338. C    POSSIBLE BREAK-POINT FOR LINKAGE
  24339. C
  24340. C    STARTING VALUES ARE COMPUTED.
  24341. C    NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
  24342. 200    ISTEP=3
  24343. 201    IF(N-8)204,202,204
  24344. C
  24345. C    N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
  24346. 202    DO 203 N=2,7
  24347.     DO 203 I=1,NDIM
  24348.     AUX(N-1,I)=AUX(N,I)
  24349. 203    AUX(N+6,I)=AUX(N+7,I)
  24350.     N=7
  24351. C
  24352. C    N LESS THAN 8 CAUSES N+1 TO GET N
  24353. 204    N=N+1
  24354. C
  24355. C    COMPUTATION OF NEXT VECTOR Y
  24356.     DO 205 I=1,NDIM
  24357.     AUX(N-1,I)=Y(I)
  24358. 205    AUX(N+6,I)=DERY(I)
  24359.     X=X+H
  24360. 206    ISTEP=ISTEP+1
  24361.     DO 207 I=1,NDIM
  24362.     DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+
  24363.      1AUX(N+4,I)+AUX(N+4,I))
  24364.     Y(I)=DELT-.9256198*AUX(16,I)
  24365. 207    AUX(16,I)=DELT
  24366. C    PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
  24367. C    IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
  24368. C
  24369.     CALL FCT(X,Y,DERY)
  24370. C    DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
  24371. C
  24372.     DO 208 I=1,NDIM
  24373.     DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+
  24374.      1AUX(N+6,I)-AUX(N+5,I)))
  24375.     AUX(16,I)=AUX(16,I)-DELT
  24376. 208    Y(I)=DELT+.07438017*AUX(16,I)
  24377. C
  24378. C    TEST WHETHER H MUST BE HALVED OR DOUBLED
  24379.     DELT=0.
  24380.     DO 209 I=1,NDIM
  24381. 209    DELT=DELT+AUX(15,I)*ABS(AUX(16,I))
  24382.     IF(DELT-PRMT(4))210,222,222
  24383. C
  24384. C    H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
  24385. 210    CALL FCT(X,Y,DERY)
  24386.     CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24387.     IF(PRMT(5))212,211,212
  24388. 211    IF(IHLF-11)213,212,212
  24389. 212    RETURN
  24390. 213    IF(H*(X-PRMT(2)))214,212,212
  24391. 214    IF(ABS(X-PRMT(2))-.1*ABS(H))212,215,215
  24392. 215    IF(DELT-.02*PRMT(4))216,216,201
  24393. C
  24394. C
  24395. C    H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
  24396. C    AVAILABLE
  24397. 216    IF(IHLF)201,201,217
  24398. 217    IF(N-7)201,218,218
  24399. 218    IF(ISTEP-4)201,219,219
  24400. 219    IMOD=ISTEP/2
  24401.     IF(ISTEP-IMOD-IMOD)201,220,201
  24402. 220    H=H+H
  24403.     IHLF=IHLF-1
  24404.     ISTEP=0
  24405.     DO 221 I=1,NDIM
  24406.     AUX(N-1,I)=AUX(N-2,I)
  24407.     AUX(N-2,I)=AUX(N-4,I)
  24408.     AUX(N-3,I)=AUX(N-6,I)
  24409.     AUX(N+6,I)=AUX(N+5,I)
  24410.     AUX(N+5,I)=AUX(N+3,I)
  24411.     AUX(N+4,I)=AUX(N+1,I)
  24412.     DELT=AUX(N+6,I)+AUX(N+5,I)
  24413.     DELT=DELT+DELT+DELT
  24414.   221    AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT
  24415.      1+AUX(N+4,I))
  24416.     GOTO 201
  24417. C
  24418. C
  24419. C    H MUST BE HALVED
  24420. 222    IHLF=IHLF+1
  24421.     IF(IHLF-10)223,223,210
  24422. 223    H=.5*H
  24423.     ISTEP=0
  24424.     DO 224 I=1,NDIM
  24425.     Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+
  24426.      1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H
  24427.     AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+
  24428.      1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)-
  24429.      29.*AUX(N+4,I))*H
  24430.     AUX(N-3,I)=AUX(N-2,I)
  24431. 224    AUX(N+4,I)=AUX(N+5,I)
  24432.     X=X-H
  24433.     DELT=X-(H+H)
  24434.     CALL FCT(DELT,Y,DERY)
  24435.     DO 225 I=1,NDIM
  24436.     AUX(N-2,I)=Y(I)
  24437.     AUX(N+5,I)=DERY(I)
  24438. 225    Y(I)=AUX(N-4,I)
  24439.     DELT=DELT-(H+H)
  24440.     CALL FCT(DELT,Y,DERY)
  24441.     DO 226 I=1,NDIM
  24442.     DELT=AUX(N+5,I)+AUX(N+4,I)
  24443.     DELT=DELT+DELT+DELT
  24444.     AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT
  24445.      1+DERY(I))
  24446. 226    AUX(N+3,I)=DERY(I)
  24447.     GOTO 206
  24448.     END
  24449. C
  24450. C    ..................................................................
  24451. C
  24452. C       SUBROUTINE HPCL
  24453. C
  24454. C       PURPOSE
  24455. C          TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR
  24456. C          DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
  24457. C
  24458. C       USAGE
  24459. C          CALL HPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
  24460. C          PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
  24461. C
  24462. C       DESCRIPTION OF PARAMETERS
  24463. C          PRMT   - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER
  24464. C                   OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF
  24465. C                   THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR
  24466. C                   COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED
  24467. C                   BY THE USER) AND SUBROUTINE HPCL. EXCEPT PRMT(5)
  24468. C                   THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE
  24469. C                   HPCL AND THEY ARE
  24470. C          PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
  24471. C          PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
  24472. C          PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
  24473. C                   (INPUT),
  24474. C          PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
  24475. C                   GREATER THAN PRMT(4), INCREMENT GETS HALVED.
  24476. C                   IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
  24477. C                   ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
  24478. C                   THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
  24479. C                   OUTPUT SUBROUTINE.
  24480. C          PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCL INITIALIZES
  24481. C                   PRMT(5)=0. IF THE USER WANTS TO TERMINATE
  24482. C                   SUBROUTINE HPCL AT ANY OUTPUT POINT, HE HAS TO
  24483. C                   CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
  24484. C                   OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
  24485. C                   FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
  24486. C                   THAN 5. HOWEVER SUBROUTINE HPCL DOES NOT REQUIRE
  24487. C                   AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
  24488. C                   FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
  24489. C                   (CALLING HPCL) WHICH ARE OBTAINED BY SPECIAL
  24490. C                   MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
  24491. C          Y      - INPUT VECTOR OF INITIAL VALUES.  (DESTROYED)
  24492. C                   LATERON Y IS THE RESULTING VECTOR OF DEPENDENT
  24493. C                   VARIABLES COMPUTED AT INTERMEDIATE POINTS X.
  24494. C          DERY   - INPUT VECTOR OF ERROR WEIGHTS.  (DESTROYED)
  24495. C                   THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1.
  24496. C                   LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH
  24497. C                   BELONG TO FUNCTION VALUES Y AT A POINT X.
  24498. C          NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  24499. C                   EQUATIONS IN THE SYSTEM.
  24500. C          IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
  24501. C                   BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
  24502. C                   GREATER THAN 10, SUBROUTINE HPCL RETURNS WITH
  24503. C                   ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
  24504. C                   ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
  24505. C                   PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
  24506. C                   PRMT(1)) RESPECTIVELY.
  24507. C          AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  24508. C                   COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE
  24509. C                   RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
  24510. C                   ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE
  24511. C                   SHOULD NOT DESTROY X.
  24512. C          FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
  24513. C                   COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
  24514. C                   RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
  24515. C                   ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE
  24516. C                   SHOULD NOT DESTROY X.
  24517. C          OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
  24518. C                   ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
  24519. C                   NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
  24520. C                   PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
  24521. C                   SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
  24522. C                   SUBROUTINE HPCL IS TERMINATED.
  24523. C          AUX    - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM
  24524. C                   COLUMNS.
  24525. C          A      - AN NDIM BY NDIM MATRIX, WHICH IS USED AS AUXILIARY
  24526. C                   STORAGE ARRAY.
  24527. C
  24528. C       REMARKS
  24529. C          THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
  24530. C          (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
  24531. C              NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
  24532. C              IHLF=11),
  24533. C          (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
  24534. C              (ERROR MESSAGES IHLF=12 OR IHLF=13),
  24535. C          (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
  24536. C          (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
  24537. C
  24538. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  24539. C          THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND
  24540. C          OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
  24541. C
  24542. C       METHOD
  24543. C          EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
  24544. C          CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
  24545. C          PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
  24546. C          DEPENDENT VARIABLES.
  24547. C          FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
  24548. C          USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
  24549. C          COMPUTATION OF STARTING VALUES.
  24550. C          SUBROUTINE HPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING
  24551. C          THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
  24552. C          TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
  24553. C          MUST BE CODED BY THE USER.
  24554. C          FOR REFERENCE, SEE
  24555. C          (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
  24556. C               COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
  24557. C          (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
  24558. C               MTAC, VOL.16, ISS.80 (1962), PP.431-437.
  24559. C
  24560. C    ..................................................................
  24561. C
  24562.     SUBROUTINE HPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
  24563. C
  24564. C
  24565. C    THE FOLLOWING FIRST PART OF SUBROUTINE HPCL (UNTIL FIRST BREAK-
  24566. C    POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE
  24567. C    COMPUTATION
  24568. C
  24569.     DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1)
  24570.     GOTO 100
  24571. C
  24572. C    THIS PART OF SUBROUTINE HPCL COMPUTES THE RIGHT HAND SIDE DERY OF
  24573. C    THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS.
  24574. 1    CALL AFCT(X,A)
  24575.     CALL FCT(X,DERY)
  24576.     DO 3 M=1,NDIM
  24577.     LL=M-NDIM
  24578.     HS=0.
  24579.     DO 2 L=1,NDIM
  24580.     LL=LL+NDIM
  24581. 2    HS=HS+A(LL)*Y(L)
  24582. 3    DERY(M)=HS+DERY(M)
  24583.     GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2
  24584. C
  24585. C    POSSIBLE BREAK-POINT FOR LINKAGE
  24586. C
  24587. 100    N=1
  24588.     IHLF=0
  24589.     X=PRMT(1)
  24590.     H=PRMT(3)
  24591.     PRMT(5)=0.
  24592.     DO 101 I=1,NDIM
  24593.     AUX(16,I)=0.
  24594.     AUX(15,I)=DERY(I)
  24595. 101    AUX(1,I)=Y(I)
  24596.     IF(H*(PRMT(2)-X))103,102,104
  24597. C
  24598. C    ERROR RETURNS
  24599. 102    IHLF=12
  24600.     GOTO 104
  24601. 103    IHLF=13
  24602. C
  24603. C    COMPUTATION OF DERY FOR STARTING VALUES
  24604. 104    ISW2=1
  24605.     GOTO 1
  24606. C
  24607. C    RECORDING OF STARTING VALUES
  24608. 105    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24609.     IF(PRMT(5))107,106,107
  24610. 106    IF(IHLF)108,108,107
  24611. 107    RETURN
  24612. 108    DO 109 I=1,NDIM
  24613. 109    AUX(8,I)=DERY(I)
  24614. C
  24615. C    COMPUTATION OF AUX(2,I)
  24616.     ISW1=1
  24617.     GOTO 200
  24618. C
  24619. 110    X=X+H
  24620.     DO 111 I=1,NDIM
  24621. 111    AUX(2,I)=Y(I)
  24622. C
  24623. C    INCREMENT H IS TESTED BY MEANS OF BISECTION
  24624. 112    IHLF=IHLF+1
  24625.     X=X-H
  24626.     DO 113 I=1,NDIM
  24627. 113    AUX(4,I)=AUX(2,I)
  24628.     H=.5*H
  24629.     N=1
  24630.     ISW1=2
  24631.     GOTO 200
  24632. C
  24633. 114    X=X+H
  24634.     ISW2=5
  24635.     GOTO 1
  24636. 115    N=2
  24637.     DO 116 I=1,NDIM
  24638.     AUX(2,I)=Y(I)
  24639. 116    AUX(9,I)=DERY(I)
  24640.     ISW1=3
  24641.     GOTO 200
  24642. C
  24643. C    COMPUTATION OF TEST VALUE DELT
  24644. 117    DELT=0.
  24645.     DO 118 I=1,NDIM
  24646. 118    DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I))
  24647.     DELT=.06666667*DELT
  24648.     IF(DELT-PRMT(4))121,121,119
  24649. 119    IF(IHLF-10)112,120,120
  24650. C
  24651. C    NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
  24652. 120    IHLF=11
  24653.     X=X+H
  24654.     GOTO 104
  24655. C
  24656. C    SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
  24657. 121    X=X+H
  24658.     ISW2=6
  24659.     GOTO 1
  24660. 122    DO 123 I=1,NDIM
  24661.     AUX(3,I)=Y(I)
  24662. 123    AUX(10,I)=DERY(I)
  24663.     N=3
  24664.     ISW1=4
  24665.     GOTO 200
  24666. C
  24667. 124    N=1
  24668.     X=X+H
  24669.     ISW2=7
  24670.     GOTO 1
  24671. 125    X=PRMT(1)
  24672.     DO 126 I=1,NDIM
  24673.     AUX(11,I)=DERY(I)
  24674.   126    Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I)
  24675.      1-.2083333*AUX(10,I)+.04166667*DERY(I))
  24676. 127    X=X+H
  24677.     N=N+1
  24678.     ISW2=12
  24679.     GOTO 1
  24680. 128    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24681.     IF(PRMT(5))107,129,107
  24682. 129    IF(N-4)130,300,300
  24683. 130    DO 131 I=1,NDIM
  24684.     AUX(N,I)=Y(I)
  24685. 131    AUX(N+7,I)=DERY(I)
  24686.     IF(N-3)132,134,300
  24687. C
  24688. 132    DO 133 I=1,NDIM
  24689.     DELT=AUX(9,I)+AUX(9,I)
  24690.     DELT=DELT+DELT
  24691. 133    Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I))
  24692.     GOTO 127
  24693. C
  24694. 134    DO 135 I=1,NDIM
  24695.     DELT=AUX(9,I)+AUX(10,I)
  24696.     DELT=DELT+DELT+DELT
  24697. 135    Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I))
  24698.     GOTO 127
  24699. C
  24700. C    THE FOLLOWING PART OF SUBROUTINE HPCL COMPUTES BY MEANS OF
  24701. C    RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
  24702. C    PREDICTOR-CORRECTOR METHOD.
  24703. 200    Z=X
  24704.     DO 201 I=1,NDIM
  24705.     X=H*AUX(N+7,I)
  24706.     AUX(5,I)=X
  24707. 201    Y(I)=AUX(N,I)+.4*X
  24708. C    X IS AN AUXILIARY STORAGE LOCATION
  24709. C
  24710.     X=Z+.4*H
  24711.     ISW2=2
  24712.     GOTO 1
  24713. 202    DO 203 I=1,NDIM
  24714.     X=H*DERY(I)
  24715.     AUX(6,I)=X
  24716. 203    Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X
  24717. C
  24718.     X=Z+.4557372*H
  24719.     ISW2=3
  24720.     GOTO 1
  24721. 204    DO 205 I=1,NDIM
  24722.     X=H*DERY(I)
  24723.     AUX(7,I)=X
  24724. 205    Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X
  24725. C
  24726.     X=Z+H
  24727.     ISW2=4
  24728.     GOTO 1
  24729. 206    DO 207 I=1,NDIM
  24730.   207    Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I)
  24731.      1+1.205536*AUX(7,I)+.1711848*H*DERY(I)
  24732.     X=Z
  24733.     GOTO(110,114,117,124),ISW1
  24734. C
  24735. C    POSSIBLE BREAK-POINT FOR LINKAGE
  24736. C
  24737. C    STARTING VALUES ARE COMPUTED.
  24738. C    NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
  24739. 300    ISTEP=3
  24740. 301    IF(N-8)304,302,304
  24741. C
  24742. C    N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
  24743. 302    DO 303 N=2,7
  24744.     DO 303 I=1,NDIM
  24745.     AUX(N-1,I)=AUX(N,I)
  24746. 303    AUX(N+6,I)=AUX(N+7,I)
  24747.     N=7
  24748. C
  24749. C    N LESS THAN 8 CAUSES N+1 TO GET N
  24750. 304    N=N+1
  24751. C
  24752. C    COMPUTATION OF NEXT VECTOR Y
  24753.     DO 305 I=1,NDIM
  24754.     AUX(N-1,I)=Y(I)
  24755. 305    AUX(N+6,I)=DERY(I)
  24756.     X=X+H
  24757. 306    ISTEP=ISTEP+1
  24758.     DO 307 I=1,NDIM
  24759.     DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+
  24760.      1AUX(N+4,I)+AUX(N+4,I))
  24761.     Y(I)=DELT-.9256198*AUX(16,I)
  24762. 307    AUX(16,I)=DELT
  24763. C    PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
  24764. C    IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
  24765.     ISW2=8
  24766.     GOTO 1
  24767. C    DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
  24768. C
  24769. 308    DO 309 I=1,NDIM
  24770.     DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+
  24771.      1AUX(N+6,I)-AUX(N+5,I)))
  24772.     AUX(16,I)=AUX(16,I)-DELT
  24773. 309    Y(I)=DELT+.07438017*AUX(16,I)
  24774. C
  24775. C    TEST WHETHER H MUST BE HALVED OR DOUBLED
  24776.     DELT=0.
  24777.     DO 310 I=1,NDIM
  24778. 310    DELT=DELT+AUX(15,I)*ABS(AUX(16,I))
  24779.     IF(DELT-PRMT(4))311,324,324
  24780. C
  24781. C    H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
  24782. 311    ISW2=9
  24783.     GOTO 1
  24784. 312    CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
  24785.     IF(PRMT(5))314,313,314
  24786. 313    IF(IHLF-11)315,314,314
  24787. 314    RETURN
  24788. 315    IF(H*(X-PRMT(2)))316,314,314
  24789. 316    IF(ABS(X-PRMT(2))-.1*ABS(H))314,317,317
  24790. 317    IF(DELT-.02*PRMT(4))318,318,301
  24791. C
  24792. C
  24793. C    H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
  24794. C    AVAILABLE
  24795. 318    IF(IHLF)301,301,319
  24796. 319    IF(N-7)301,320,320
  24797. 320    IF(ISTEP-4)301,321,321
  24798. 321    IMOD=ISTEP/2
  24799.     IF(ISTEP-IMOD-IMOD)301,322,301
  24800. 322    H=H+H
  24801.     IHLF=IHLF-1
  24802.     ISTEP=0
  24803.     DO 323 I=1,NDIM
  24804.     AUX(N-1,I)=AUX(N-2,I)
  24805.     AUX(N-2,I)=AUX(N-4,I)
  24806.     AUX(N-3,I)=AUX(N-6,I)
  24807.     AUX(N+6,I)=AUX(N+5,I)
  24808.     AUX(N+5,I)=AUX(N+3,I)
  24809.     AUX(N+4,I)=AUX(N+1,I)
  24810.     DELT=AUX(N+6,I)+AUX(N+5,I)
  24811.     DELT=DELT+DELT+DELT
  24812.   323    AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT
  24813.      1+AUX(N+4,I))
  24814.     GOTO 301
  24815. C
  24816. C
  24817. C    H MUST BE HALVED
  24818. 324    IHLF=IHLF+1
  24819.     IF(IHLF-10)325,325,311
  24820. 325    H=.5*H
  24821.     ISTEP=0
  24822.     DO 326 I=1,NDIM
  24823.     Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+
  24824.      1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H
  24825.     AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+
  24826.      1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)-
  24827.      29.*AUX(N+4,I))*H
  24828.     AUX(N-3,I)=AUX(N-2,I)
  24829. 326    AUX(N+4,I)=AUX(N+5,I)
  24830.     DELT=X-H
  24831.     X=DELT-(H+H)
  24832.     ISW2=10
  24833.     GOTO 1
  24834. 327    DO 328 I=1,NDIM
  24835.     AUX(N-2,I)=Y(I)
  24836.     AUX(N+5,I)=DERY(I)
  24837. 328    Y(I)=AUX(N-4,I)
  24838.     X=X-(H+H)
  24839.     ISW2=11
  24840.     GOTO 1
  24841. 329    X=DELT
  24842.     DO 330 I=1,NDIM
  24843.     DELT=AUX(N+5,I)+AUX(N+4,I)
  24844.     DELT=DELT+DELT+DELT
  24845.     AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT
  24846.      1+DERY(I))
  24847. 330    AUX(N+3,I)=DERY(I)
  24848.     GOTO 306
  24849.     END
  24850. C
  24851. C    ..................................................................
  24852. C
  24853. C       SUBROUTINE HSBG
  24854. C
  24855. C       PURPOSE
  24856. C          TO REDUCE A REAL MATRIX INTO UPPER ALMOST TRIANGULAR FORM
  24857. C
  24858. C       USAGE
  24859. C          CALL HSBG(N,A,IA)
  24860. C
  24861. C       DESCRIPTION OF THE PARAMETERS
  24862. C          N      ORDER OF THE MATRIX
  24863. C          A      THE INPUT MATRIX, N BY N
  24864. C          IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY
  24865. C                 A IN THE CALLING PROGRAM WHEN THE MATRIX IS IN
  24866. C                 DOUBLE SUBSCRIPTED DATA STORAGE MODE.  IA=N WHEN
  24867. C                 THE MATRIX IS IN SSP VECTOR STORAGE MODE.
  24868. C
  24869. C       REMARKS
  24870. C          THE HESSENBERG FORM REPLACES THE ORIGINAL MATRIX IN THE
  24871. C          ARRAY A.
  24872. C
  24873. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  24874. C          NONE
  24875. C
  24876. C       METHOD
  24877. C          SIMILARITY TRANSFORMATIONS USING ELEMENTARY ELIMINATION
  24878. C          MATRICES, WITH PARTIAL PIVOTING.
  24879. C
  24880. C       REFERENCES
  24881. C          J.H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
  24882. C          CLARENDON PRESS, OXFORD, 1965.
  24883. C
  24884. C    ..................................................................
  24885. C
  24886.     SUBROUTINE HSBG(N,A,IA)
  24887.     DIMENSION A(1)
  24888.     DOUBLE PRECISION S
  24889.     L=N
  24890.     NIA=L*IA
  24891.     LIA=NIA-IA
  24892. C
  24893. C       L IS THE ROW INDEX OF THE ELIMINATION
  24894. C
  24895. 20    IF(L-3) 360,40,40
  24896. 40    LIA=LIA-IA
  24897.     L1=L-1
  24898.     L2=L1-1
  24899. C
  24900. C       SEARCH FOR THE PIVOTAL ELEMENT IN THE LTH ROW
  24901. C
  24902.     ISUB=LIA+L
  24903.     IPIV=ISUB-IA
  24904.     PIV=ABS(A(IPIV))
  24905.     IF(L-3) 90,90,50
  24906. 50    M=IPIV-IA
  24907.     DO 80 I=L,M,IA
  24908.     T=ABS(A(I))
  24909.     IF(T-PIV) 80,80,60
  24910. 60    IPIV=I
  24911.     PIV=T
  24912. 80    CONTINUE
  24913. 90    IF(PIV) 100,320,100
  24914. 100    IF(PIV-ABS(A(ISUB))) 180,180,120
  24915. C
  24916. C       INTERCHANGE THE COLUMNS
  24917. C
  24918. 120    M=IPIV-L
  24919.     DO 140 I=1,L
  24920.     J=M+I
  24921.     T=A(J)
  24922.     K=LIA+I
  24923.     A(J)=A(K)
  24924. 140    A(K)=T
  24925. C
  24926. C       INTERCHANGE THE ROWS
  24927. C
  24928.     M=L2-M/IA
  24929.     DO 160 I=L1,NIA,IA
  24930.     T=A(I)
  24931.     J=I-M
  24932.     A(I)=A(J)
  24933. 160    A(J)=T
  24934. C
  24935. C       TERMS OF THE ELEMENTARY TRANSFORMATION
  24936. C
  24937. 180    DO 200 I=L,LIA,IA
  24938. 200    A(I)=A(I)/A(ISUB)
  24939. C
  24940. C       RIGHT TRANSFORMATION
  24941. C
  24942.     J=-IA
  24943.     DO 240 I=1,L2
  24944.     J=J+IA
  24945.     LJ=L+J
  24946.     DO 220 K=1,L1
  24947.     KJ=K+J
  24948.     KL=K+LIA
  24949. 220    A(KJ)=A(KJ)-A(LJ)*A(KL)
  24950. 240    CONTINUE
  24951. C
  24952. C       LEFT TRANSFORMATION
  24953. C
  24954.     K=-IA
  24955.     DO 300 I=1,N
  24956.     K=K+IA
  24957.     LK=K+L1
  24958.     S=A(LK)
  24959.     LJ=L-IA
  24960.     DO 280 J=1,L2
  24961.     JK=K+J
  24962.     LJ=LJ+IA
  24963. 280    S=S+A(LJ)*A(JK)*1.0D0
  24964. 300    A(LK)=S
  24965. C
  24966. C       SET THE LOWER PART OF THE MATRIX TO ZERO
  24967. C
  24968.     DO 310 I=L,LIA,IA
  24969. 310    A(I)=0.0
  24970. 320    L=L1
  24971.     GO TO 20
  24972. 360    RETURN
  24973.     END
  24974. C
  24975. C    ..................................................................
  24976. C
  24977. C       SUBROUTINE I0
  24978. C
  24979. C       PURPOSE
  24980. C           COMPUTE THE MODIFIED BESSEL FUNCTION I OF ORDER ZERO
  24981. C
  24982. C       USAGE
  24983. C           CALL I0(X,RI0)
  24984. C
  24985. C       DESCRIPTION OF PARAMETERS
  24986. C           X    -GIVEN ARGUMENT OF THE BESSEL FUNCTION I OF ORDER 0
  24987. C           RI0  -RESULTANT VALUE OF THE BESSEL FUNCTION I OF ORDER 0
  24988. C
  24989. C       REMARKS
  24990. C           LARGE VALUES OF THE ARGUMENT MAY CAUSE OVERFLOW IN THE
  24991. C           BUILTIN EXP-FUNCTION
  24992. C
  24993. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  24994. C          NONE
  24995. C
  24996. C       METHOD
  24997. C          POLYNOMIAL APPROXIMATIONS GIVEN BY E.E. ALLEN ARE USED FOR
  24998. C          CALCULATION.
  24999. C          FOR REFERENCE SEE
  25000. C          M. ABRAMOWITZ AND I.A. STEGUN,'HANDBOOK OF MATHEMATICAL
  25001. C          FUNCTIONS', U.S. DEPARTMENT OF COMMERCE, NATIONAL BUREAU OF
  25002. C          STANDARDS APPLIED MATHEMATICS SERIES, 1966, P.378.
  25003. C
  25004. C    ..................................................................
  25005. C
  25006.     SUBROUTINE I0(X,RI0)
  25007.     RI0=ABS(X)
  25008.     IF(RI0-3.75)1,1,2
  25009. 1    Z=X*X*7.111111E-2
  25010.     RI0=((((( 4.5813E-3*Z+3.60768E-2)*Z+2.659732E-1)*Z+1.206749E0)*Z
  25011.      1+3.089942E0)*Z+3.515623E0)*Z+1.
  25012.     RETURN
  25013. 2    Z=3.75/RI0
  25014.     RI0= EXP(RI0)/SQRT(RI0)*((((((((3.92377E-3*Z-1.647633E-2)*Z
  25015.      1+2.635537E-2)*Z-2.057706E-2)*Z+9.16281E-3)*Z-1.57565E-3)*Z
  25016.      2+2.25319E-3)*Z+1.328592E-2)*Z+3.989423E-1)
  25017.     RETURN
  25018.     END
  25019. C
  25020. C    ..................................................................
  25021. C
  25022. C       SUBROUTINE INUE
  25023. C
  25024. C       PURPOSE
  25025. C          COMPUTE THE MODIFIED BESSEL FUNCTIONS I FOR ORDERS 1 TO N
  25026. C
  25027. C       USAGE
  25028. C          CALL INUE(X,N,ZI,RI)
  25029. C
  25030. C       DESCRIPTION OF PARAMETERS
  25031. C          X     -GIVEN ARGUMENT OF THE BESSEL FUNCTIONS I
  25032. C          N     -GIVEN MAXIMUM ORDER OF BESSEL FUNCTIONS I
  25033. C          ZI    -GIVEN VALUE OF BESSEL FUNCTION I OF ORDER ZERO
  25034. C                 FOR ARGUMENT X
  25035. C          RI    -RESULTANT VECTOR OF DIMENSION N, CONTAINING THE
  25036. C                 VALUES OF THE FUNCTIONS I FOR ORDERS 1 TO N
  25037. C
  25038. C       REMARKS
  25039. C          THE VALUE OF ZI MAY BE CALCULATED USING SUBROUTINE I0.
  25040. C          USING A DIFFERENT VALUE HAS THE EFFECT THAT ALL VALUES OF
  25041. C          BESSEL FUNCTIONS I ARE MULTIPLIED BY THE  FACTOR ZI/I(0,X)
  25042. C          WHERE I(0,X) IS THE VALUE OF I FOR ORDER 0 AND ARGUMENT X.
  25043. C          THIS MAY BE USED DISADVANTAGEOUSLY IF ONLY THE RATIOS OF I
  25044. C          FOR DIFFERENT ORDERS ARE REQUIRED.
  25045. C
  25046. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  25047. C          NONE
  25048. C
  25049. C       METHOD
  25050. C          THE VALUES ARE OBTAINED USING BACKWARD RECURRENCE RELATION
  25051. C          TECHNIQUE. THE RATIO I(N+1,X)/I(N,X) IS OBTAINED FROM A
  25052. C          CONTINUED FRACTION.
  25053. C          FOR REFERENCE SEE
  25054. C          G. BLANCH,'NUMERICAL EVALUATION OF CONTINUED FRACTIONS',
  25055. C          SIAM REVIEW, VOL.6,NO.4,1964,PP.383-421.
  25056. C
  25057. C    ..................................................................
  25058. C
  25059.     SUBROUTINE INUE(X,N,ZI,RI)
  25060.     DIMENSION RI(1)
  25061.     IF(N)10,10,1
  25062. 1    FN=N+N
  25063.     Q1=X/FN
  25064.     IF(ABS(X)-5.E-4)6,6,2
  25065. 2    A0=1.
  25066.     A1=0.
  25067.     B0=0.
  25068.     B1=1.
  25069.     FI=FN
  25070. 3    FI=FI+2.
  25071.     AN=FI/ABS(X)
  25072.     A=AN*A1+A0
  25073.     B=AN*B1+B0
  25074.     A0=A1
  25075.     B0=B1
  25076.     A1=A
  25077.     B1=B
  25078.     Q0=Q1
  25079.     Q1=A/B
  25080.     IF(ABS((Q1-Q0)/Q1)-1.E-6)4,4,3
  25081. 4    IF(X)5,6,6
  25082. 5    Q1=-Q1
  25083. 6    K=N
  25084. 7    Q1=X/(FN+X*Q1)
  25085.     RI(K)=Q1
  25086.     FN=FN-2.
  25087.     K=K-1
  25088.     IF(K)8,8,7
  25089. 8    FI=ZI
  25090.     DO 9 I=1,N
  25091.     FI=FI*RI(I)
  25092. 9    RI(I)=FI
  25093. 10    RETURN
  25094.     END
  25095. C
  25096. C    ..................................................................
  25097. C
  25098. C       SUBROUTINE JELF
  25099. C
  25100. C       PURPOSE
  25101. C          COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN.
  25102. C
  25103. C       USAGE
  25104. C          CALL JELF(SN,CN,DN,X,SCK)
  25105. C
  25106. C       DESCRIPTION OF PARAMETERS
  25107. C          SN    - RESULT VALUE SN(X)
  25108. C          CN    - RESULT VALUE CN(X)
  25109. C          DN    - RESULT VALUE DN(X)
  25110. C          X     - ARGUMENT OF JACOBIAN ELLIPTIC FUNCTIONS
  25111. C          SCK   - SQUARE OF COMPLEMENTARY MODULUS
  25112. C
  25113. C       REMARKS
  25114. C          NONE
  25115. C
  25116. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  25117. C          NONE
  25118. C
  25119. C       METHOD
  25120. C          DEFINITION
  25121. C          X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER
  25122. C          T FROM 0 TO SN), WHERE K=SQRT(1-SCK).
  25123. C          SN*SN + CN*CN = 1
  25124. C          (K*SN)**2 + DN**2 = 1.
  25125. C          EVALUATION
  25126. C          CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC
  25127. C          GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION
  25128. C          BEFORE INVERSION OF THE INTEGRAL TAKES PLACE.
  25129. C          REFERENCE
  25130. C          R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
  25131. C                 ELLIPTIC FUNCTIOMS.
  25132. C                 HANDBOOK SERIES OF SPECIAL FUNCTIONS
  25133. C                 NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
  25134. C
  25135. C    ..................................................................
  25136. C
  25137.     SUBROUTINE JELF(SN,CN,DN,X,SCK)
  25138. C
  25139. C
  25140.     DIMENSION ARI(12),GEO(12)
  25141. C    TEST MODULUS
  25142.     CM=SCK
  25143.     Y=X
  25144.     IF(SCK)3,1,4
  25145. 1    D=EXP(X)
  25146.     A=1./D
  25147.     B=A+D
  25148.     CN=2./B
  25149.     DN=CN
  25150.     SN=TANH(X)
  25151. C       DEGENERATE CASE SCK=0 GIVES RESULTS
  25152. C          CN X = DN X = 1/COSH X
  25153. C          SN X = TANH X
  25154. 2    RETURN
  25155. C       JACOBIS MODULUS TRANSFORMATION
  25156. 3    D=1.-SCK
  25157.     CM=-SCK/D
  25158.     D=SQRT(D)
  25159.     Y=D*X
  25160. 4    A=1.
  25161.     DN=1.
  25162.     DO 6 I=1,12
  25163.     L=I
  25164.     ARI(I)=A
  25165.     CM=SQRT(CM)
  25166.     GEO(I)=CM
  25167.     C=(A+CM)*.5
  25168.     IF(ABS(A-CM)-1.E-4*A)7,7,5
  25169. 5    CM=A*CM
  25170. 6    A=C
  25171. C
  25172. C    START BACKWARD RECURSION
  25173. 7    Y=C*Y
  25174.     SN=SIN(Y)
  25175.     CN=COS(Y)
  25176.     IF(SN)8,13,8
  25177. 8    A=CN/SN
  25178.     C=A*C
  25179.     DO 9 I=1,L
  25180.     K=L-I+1
  25181.     B=ARI(K)
  25182.     A=C*A
  25183.     C=DN*C
  25184.     DN=(GEO(K)+A)/(B+A)
  25185. 9    A=C/B
  25186.     A=1./SQRT(C*C+1.)
  25187.     IF(SN)10,11,11
  25188. 10    SN=-A
  25189.     GOTO 12
  25190. 11    SN=A
  25191. 12    CN=C*SN
  25192. 13    IF(SCK)14,2,2
  25193. 14    A=DN
  25194.     DN=CN
  25195.     CN=A
  25196.     SN=SN/D
  25197.     RETURN
  25198.     END
  25199. C
  25200. C    ..................................................................
  25201. C
  25202. C       SAMPLE MAIN PROGRAM FOR THE KOLMOGOROV-SMIRNOV TEST-KOLM
  25203. C
  25204. C       PURPOSE
  25205. C          (1) READ THE CONTROL CARD FOR A ONE OR TWO SAMPLE TEST
  25206. C          (2) READ THE SAMPLE DATA AND DETERMINE THE SAMPLE SIZES
  25207. C          (3) PRINT RESULTS
  25208. C
  25209. C       REMARKS
  25210. C          THE USER SHOULD NOTE THE REMARKS GIVEN IN SUBROUTINES
  25211. C          KOLMO, KOLM2, AND SMIRN, AND THE MATHEMATICAL DESCRIPTIONS
  25212. C          FOR THESE SUBROUTINES.
  25213. C
  25214. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  25215. C          KOLMO
  25216. C          KOLM2
  25217. C          SMIRN
  25218. C          NDTR
  25219. C
  25220. C       METHOD
  25221. C          REFER TO SUBROUTINES KOLMO, KOLM2, AND SMIRN
  25222. C
  25223. C    ..................................................................
  25224. C
  25225. C    THE FOLLOWING DIMENSIONS MUST BE GREATER THAN THE NUMBER OF DATA
  25226. C    ELEMENTS IN THE TWO SAMPLES, M AND N
  25227. cC
  25228. c       DIMENSION X(501),Y(501)
  25229. cC
  25230. cC    ..................................................................
  25231. cC
  25232. c       DIMENSION TITLE(5),D(12),TIT1(20),DIST(5,3)
  25233. cC
  25234. cC    ..................................................................
  25235. cC
  25236. c1    FORMAT(5A4,3I1,5(F1.0,2F5.0))
  25237. c2    FORMAT(//'CC.21, CONTROL CARD, INCORRECT, OR SAMPLE SIZE IS TOO LA
  25238. c     1RGE.  JOB IGNORED.')
  25239. c3    FORMAT(12F6.0)
  25240. c4    FORMAT(1H1,5A4)
  25241. c5    FORMAT(//2H A,I2,' SAMPLE TEST WAS REQUESTED')
  25242. c6    FORMAT(20A4)
  25243. c7    FORMAT(//(10F10.3))
  25244. c8    FORMAT(//' SORTED SAMPLE ONE FOLLOWS')
  25245. c9    FORMAT(//' THE HYPOTHESIS THAT THE SAMPLE IS FROM A(N) ',4A4,  ' D
  25246. c     1ISTRIBUTION')
  25247. c10    FORMAT(//' SORTED SAMPLE TWO FOLLOWS')
  25248. c11    FORMAT(//' THE HYPOTHESIS THAT THE TWO SAMPLES ARE FROM THE SAME P
  25249. c     1OPULATION CAN BE REJECTED WITH (ASYMPTOTIC)',/,' PROBABILITY OF BE
  25250. c     2ING INCORRECT OF ',F6.3,'.  THE STATISTIC Z IS ',E12.4,' FOR THESE
  25251. c     3 SAMPLES.')
  25252. c12    FORMAT(//,' THE SIZE OF SAMPLE',I3,' IS',I4,'.')
  25253. c13    FORMAT(//,' NOTE THE REMARKS CONCERNING ASYMPTOTIC RESULTS AND SAM
  25254. c     1PLE SIZE IN SUBROUTINE SMIRN')
  25255. c14    FORMAT(//,' AT LEAST ONE (S) ENTRY PARAMETER FOR THE SUBROUTINE KO
  25256. c     1LMO WAS INCORRECT.'/' THE TEST FOR THE ASSOCIATED CONTINUOUS PDF W
  25257. c     2AS IGNORED.')
  25258. c15    FORMAT(A4)
  25259. c16    FORMAT(//,' THIS JOB CALLS FOR THE USE OF A PREVIOUSLY READ SAMPLE
  25260. c     1, AND THE PREVIOUS JOB WAS IGNORED BECAUSE OF ERRORS.'/ ' JOB IGNO
  25261. c     2RED.')
  25262. c17    FORMAT(//,' FIRST CARD IN JOB DECK (JOB CONTROL CARD) IS INCORRECT
  25263. c     1.')
  25264. c18    FORMAT(1H ,' WITH MEAN',F13.4,' AND VARIANCE',F13.4)
  25265. c19    FORMAT(1H ,' WITH MEDIAN',F13.4,' AND FIRST QUARTILE',F13.4)
  25266. c20    FORMAT(1H ,' IN THE INTERVAL',F13.4,' TO',F13.4,' INCLUSIVE')
  25267. c21    FORMAT(1H ,' CAN BE REJECTED WITH PROBABILITY',F6.3,' OF BEING INC
  25268. c     1ORRECT.  THE STATISTIC Z',/,'  IS',E12.4,' FOR THIS SAMPLE.')
  25269. c22    FORMAT(//,'  THE JOB WITH TITLE ',5A4,' WAS COMPLETED.')
  25270. cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
  25271. cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
  25272. cC
  25273. cC       READ DISTRIBUTION NAMES AND JOB CONTROL CARD
  25274. cC
  25275. c    IFL=0
  25276. c    READ(5,15)DASH
  25277. c    READ(5,6)TIT1
  25278. cC
  25279. cC       SELECT PROGRAM CONTROLS
  25280. cC
  25281. c    LOGICAL EOF
  25282. c    CALL CHKEOF (EOF)
  25283. c100    READ(5,15)DAS2
  25284. c    IF (EOF) GOTO 999
  25285. c    IF(DASH-DAS2)101,102,101
  25286. c101    WRITE(6,17)
  25287. c    GO TO 107
  25288. c102    READ(5,1)TITLE,IS,IR,IO,((DIST(I,J),J=1,3),I=1,5)
  25289. c    IES=0
  25290. c    WRITE(6,4)TITLE
  25291. c    WRITE(6,5)IS
  25292. cC
  25293. cC       NUMBER OF SAMPLES DECISION
  25294. cC
  25295. c    IF(IR)103,105,103
  25296. c103    IF(IFL)104,115,104
  25297. c104    WRITE(6,16)
  25298. c    GO TO 107
  25299. c105    IF(IS-1)106,109,109
  25300. cC
  25301. cC       NOT ONE OR TWO SAMPLES
  25302. cC
  25303. c106    WRITE(6,2)
  25304. c107    READ(5,15)DAS2
  25305. c    IF(DASH-DAS2)107,108,107
  25306. c108    IFL=1
  25307. c    GO TO 102
  25308. cC
  25309. cC       READ FIRST SAMPLE
  25310. cC
  25311. c109    N=0
  25312. c    DO 111 I=1,50
  25313. c    READ(5,3)D
  25314. c    DO 111 J=1,12
  25315. c    IF(D(J)-999999.0)110,112,110
  25316. c110    N=N+1
  25317. c    IF(N-501)111,106,106
  25318. c111    X(N)=D(J)
  25319. c112    N1=1
  25320. c    WRITE(6,12)N1,N
  25321. cC
  25322. cC       CHECK THE SIZE OF N
  25323. cC
  25324. c    IF(N-100)113,113,114
  25325. c113    WRITE(6,13)
  25326. c114    IF(IS-2)121,115,106
  25327. cC
  25328. cC       READ SECOND SAMPLE
  25329. cC
  25330. c115    M=0
  25331. c    DO 117 I=1,50
  25332. c    READ(5,3)D
  25333. c    DO 117 J=1,12
  25334. c    IF(D(J)-999999.0)116,118,116
  25335. c116    M=M+1
  25336. c    IF(M-501)117,106,106
  25337. c117    Y(M)=D(J)
  25338. c118    N1=2
  25339. c    WRITE(6,12)N1,M
  25340. cC
  25341. cC       CHECK THE SIZE OF M
  25342. cC
  25343. c    IF(M-100)119,119,120
  25344. c119    WRITE(6,13)
  25345. c120    IF(IS-1)121,121,133
  25346. cC
  25347. cC       ONE SAMPLE TEST USING ALL DISTRIBUTIONS REQUESTED
  25348. cC
  25349. c121    DO 130 I=1,5
  25350. c    IF(DIST(I,1))130,130,122
  25351. c122    CALL KOLMO(X,N,Z,P,I,DIST(I,2),DIST(I,3),IER)
  25352. c    IES=IER+IES
  25353. c    IF(IER)130,124,130
  25354. c123    WRITE(6,14)
  25355. c    GO TO 136
  25356. cC
  25357. cC       OUTPUT RESULTS
  25358. cC
  25359. c124    K=4*I-3
  25360. c    WRITE(6,9)TIT1(K),TIT1(K+1),TIT1(K+2),TIT1(K+3)
  25361. c    IF(I-3)125,126,127
  25362. c125    S2=DIST(I,3)**2
  25363. c    WRITE(6,18)DIST(I,2),S2
  25364. c    GO TO 129
  25365. c126    S2=DIST(I,2)-DIST(I,3)
  25366. c    WRITE(6,19)DIST(I,2),S2
  25367. c    GO TO 129
  25368. c127    IF(I-4)128,128,130
  25369. c128    WRITE(6,20)DIST(I,2),DIST(I,3)
  25370. c129    WRITE(6,21)P,Z
  25371. c130    CONTINUE
  25372. cC
  25373. cC       OUTPUT SAMPLE ONE DECISION
  25374. cC
  25375. c    IF(IO)131,132,131
  25376. c131    WRITE(6,8)
  25377. c    WRITE(6,7)(X(J),J=1,N)
  25378. c132    IF(IES)123,136,123
  25379. cC
  25380. cC       TWO SAMPLE TEST
  25381. cC
  25382. c133    CALL KOLM2(X,Y,N,M,Z,P)
  25383. cC
  25384. cC       OUTPUT SAMPLES DECISION
  25385. cC
  25386. c    IF(IO)134,135,134
  25387. c134    WRITE(6,8)
  25388. c    WRITE(6,7)(X(J),J=1,N)
  25389. c    WRITE(6,10)
  25390. c    WRITE(6,7)(Y(J),J=1,M)
  25391. c135    WRITE(6,11)P,Z
  25392. c136    IFL=0
  25393. c    WRITE(6,22)TITLE
  25394. c    GO TO 100
  25395. c999    STOP
  25396. c    END
  25397. C
  25398. C    ..................................................................
  25399. C
  25400. C       SUBROUTINE KOLM2
  25401. C
  25402. C       PURPOSE
  25403. C
  25404. C          TESTS THE DIFFERENCE BETWEEN TWO SAMPLE DISTRIBUTION
  25405. C          FUNCTIONS USING THE KOLMOGOROV-SMIRNOV TEST
  25406. C
  25407. C       USAGE
  25408. C          CALL KOLM2(X,Y,N,M,Z,PROB)
  25409. C
  25410. C       DESCRIPTION OF PARAMETERS
  25411. C          X    - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS.  ON
  25412. C                 RETURN FROM KOLM2, X HAS BEEN SORTED INTO A
  25413. C                 MONOTONIC NON-DECREASING SEQUENCE.
  25414. C          Y    - INPUT VECTOR OF M INDEPENDENT OBSERVATIONS.  ON
  25415. C                 RETURN FROM KOLM2, Y HAS BEEN SORTED INTO A
  25416. C                 MONOTONIC NON-DECREASING SEQUENCE.
  25417. C          N    - NUMBER OF OBSERVATIONS IN X
  25418. C          M    - NUMBER OF OBSERVATIONS IN Y
  25419. C          Z    - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH
  25420. C                 RESPECT TO THE SPECTRUM OF X AND Y OF
  25421. C                 SQRT((M*N)/(M+N))*ABS(FN(X)-GM(Y)) WHERE
  25422. C                 FN(X) IS THE EMPIRICAL DISTRIBUTION FUNCTION OF THE
  25423. C                 SET (X) AND GM(Y) IS THE EMPIRICAL DISTRIBUTION
  25424. C                 FUNCTION OF THE SET (Y).
  25425. C          PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF
  25426. C                 THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF
  25427. C                 THE HYPOTHESIS THAT X AND Y ARE FROM THE SAME PDF IS
  25428. C                 TRUE.  E.G., PROB= 0.05 IMPLIES THAT ONE CAN REJECT
  25429. C                 THE NULL HYPOTHESIS THAT THE SETS X AND Y ARE FROM
  25430. C                 THE SAME DENSITY WITH 5 PER CENT PROBABILITY OF BEING
  25431. C                 INCORRECT.  PROB = 1. - SMIRN(Z).
  25432. C
  25433. C       REMARKS
  25434. C          N AND M SHOULD BE GREATER THAN OR EQUAL TO 100.  (SEE THE
  25435. C          MATHEMATICAL DESCRIPTION FOR THIS SUBROUTINE AND FOR THE
  25436. C          SUBROUTINE SMIRN, CONCERNING ASYMPTOTIC FORMULAE).
  25437. C
  25438. C          DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL
  25439. C          WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY.
  25440. C          IF ONE WISHES TO COMMUNICATE WITH KOLM2 IN A DOUBLE
  25441. C          PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED
  25442. C          PROGRAM SNGL(X) PRIOR TO CALLING KOLM2, AND CALL THE
  25443. C          FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLM2.
  25444. C          (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION
  25445. C          CAPABILITY AS SUPPLIED BY THIS PACKAGE.)
  25446. C
  25447. C
  25448. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  25449. C          SMIRN
  25450. C
  25451. C       METHOD
  25452. C          FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV
  25453. C          LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS--
  25454. C          ANNALS OF MATH. STAT., 19, 1948.  177-189,
  25455. C          (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT
  25456. C          OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19,
  25457. C          1948.  279-281.
  25458. C          (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND
  25459. C          STATISTICS--ACADEMIC PRESS, NEW YORK, 1964.  490-493,
  25460. C          (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA
  25461. C          PUBLISHING COMPANY, NEW YORK, 1962.  384-401.
  25462. C
  25463. C    ..................................................................
  25464. C
  25465.     SUBROUTINE KOLM2(X,Y,N,M,Z,PROB)
  25466.     DIMENSION X(1),Y(1)
  25467. C
  25468. C       SORT X INTO ASCENDING SEQUENCE
  25469. C
  25470.     DO 5 I=2,N
  25471.     IF(X(I)-X(I-1))1,5,5
  25472. 1    TEMP=X(I)
  25473.     IM=I-1
  25474.     DO 3 J=1,IM
  25475.     L=I-J
  25476.     IF(TEMP-X(L))2,4,4
  25477. 2    X(L+1)=X(L)
  25478. 3    CONTINUE
  25479.     X(1)=TEMP
  25480.     GO TO 5
  25481. 4    X(L+1)=TEMP
  25482. 5    CONTINUE
  25483. C
  25484. C       SORT Y INTO ASCENDING SEQUENCE
  25485. C
  25486.     DO 10 I=2,M
  25487.     IF(Y(I)-Y(I-1))6,10,10
  25488. 6    TEMP=Y(I)
  25489.     IM=I-1
  25490.     DO 8  J=1,IM
  25491.     L=I-J
  25492.     IF(TEMP-Y(L))7,9,9
  25493. 7    Y(L+1)=Y(L)
  25494. 8    CONTINUE
  25495.     Y(1)=TEMP
  25496.     GO TO 10
  25497. 9    Y(L+1)=TEMP
  25498. 10    CONTINUE
  25499. C
  25500. C       CALCULATE D = ABS(FN-GM) OVER THE SPECTRUM OF X AND Y
  25501. C
  25502.     XN=FLOAT(N)
  25503.     XN1=1./XN
  25504.     XM=FLOAT(M)
  25505.     XM1=1./XM
  25506.     D=0.0
  25507.     I=0
  25508.     J=0
  25509.     K=0
  25510.     L=0
  25511. 11    IF(X(I+1)-Y(J+1))12,13,18
  25512. 12    K=1
  25513.     GO TO 14
  25514. 13    K=0
  25515. 14    I=I+1
  25516.     IF(I-N)15,21,21
  25517. 15    IF(X(I+1)-X(I))14,14,16
  25518. 16    IF(K)17,18,17
  25519. C
  25520. C       CHOOSE THE MAXIMUM DIFFERENCE, D
  25521. C
  25522. 17    D=AMAX1(D,ABS(FLOAT(I)*XN1-FLOAT(J)*XM1))
  25523.     IF(L)22,11,22
  25524. 18    J=J+1
  25525.     IF(J-M)19,20,20
  25526. 19    IF(Y(J+1)-Y(J))18,18,17
  25527. 20    L=1
  25528.     GO TO 17
  25529. 21    L=1
  25530.     GO TO 16
  25531. C
  25532. C       CALCULATE THE STATISTIC Z
  25533. C
  25534. 22    Z=D*SQRT((XN*XM)/(XN+XM))
  25535. C
  25536. C       CALCULATE THE PROBABILITY ASSOCIATED WITH Z
  25537. C
  25538.     CALL SMIRN(Z,PROB)
  25539.     PROB=1.0-PROB
  25540.     RETURN
  25541.     END
  25542. C
  25543. C    ..................................................................
  25544. C
  25545. C       SUBROUTINE KOLMO
  25546. C
  25547. C       PURPOSE
  25548. C          TESTS THE DIFFERENCE BETWEEN EMPIRICAL AND THEORETICAL
  25549. C          DISTRIBUTIONS  USING THE KOLMOGOROV-SMIRNOV TEST
  25550. C
  25551. C       USAGE
  25552. C          CALL KOLMO(X,N,Z,PROB,IFCOD,U,S,IER)
  25553. C
  25554. C       DESCRIPTION OF PARAMETERS
  25555. C          X    - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS.  ON
  25556. C                 RETURN FROM KOLMO, X HAS BEEN SORTED INTO A
  25557. C                 MONOTONIC NON-DECREASING SEQUENCE.
  25558. C          N    - NUMBER OF OBSERVATIONS IN X
  25559. C          Z    - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH
  25560. C                 RESPECT TO X OF  SQRT(N)*ABS(FN(X)-F(X)) WHERE
  25561. C                 F(X) IS A  THEORETICAL DISTRIBUTION FUNCTION AND
  25562. C                 FN(X) AN EMPIRICAL DISTRIBUTION FUNCTION.
  25563. C          PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF
  25564. C                 THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF
  25565. C                 THE HYPOTHESIS THAT X IS FROM THE DENSITY UNDER
  25566. C                 CONSIDERATION IS TRUE.  E.G., PROB = 0.05 IMPLIES
  25567. C                 THAT ONE CAN REJECT THE NULL HYPOTHESIS THAT THE SET
  25568. C                 X IS FROM THE DENSITY UNDER CONSIDERATION WITH 5 PER
  25569. C                 CENT PROBABILITY OF BEING INCORRECT.  PROB = 1. -
  25570. C                 SMIRN(Z).
  25571. C          IFCOD- A CODE DENOTING THE PARTICULAR THEORETICAL
  25572. C                 PROBABILITY DISTRIBUTION FUNCTION BEING CONSIDERED.
  25573. C                 = 1---F(X) IS THE NORMAL PDF.
  25574. C                 = 2---F(X) IS THE EXPONENTIAL PDF.
  25575. C                 = 3---F(X) IS THE CAUCHY PDF.
  25576. C                 = 4---F(X) IS THE UNIFORM PDF.
  25577. C                 = 5---F(X) IS USER SUPPLIED.
  25578. C          U    - WHEN IFCOD IS 1 OR 2, U IS THE MEAN OF THE DENSITY
  25579. C                 GIVEN ABOVE.
  25580. C                 WHEN IFCOD IS 3, U IS THE MEDIAN OF THE CAUCHY
  25581. C                 DENSITY.
  25582. C                 WHEN IFCOD IS 4, U IS THE LEFT ENDPOINT OF THE
  25583. C                 UNIFORM DENSITY.
  25584. C                 WHEN IFCOD IS 5, U IS USER SPECIFIED.
  25585. C          S    - WHEN IFCOD IS 1 OR 2, S IS THE STANDARD DEVIATION OF
  25586. C                 DENSITY GIVEN ABOVE, AND SHOULD BE POSITIVE.
  25587. C                 WHEN IFCOD IS 3, U - S SPECIFIES THE FIRST QUARTILE
  25588. C                 OF THE CAUCHY DENSITY.  S SHOULD BE NON-ZERO.
  25589. C                 IF IFCOD IS 4, S IS THE RIGHT ENDPOINT OF THE UNIFORM
  25590. C                 DENSITY.  S SHOULD BE GREATER THAN U.
  25591. C                 IF IFCOD IS 5, S IS USER SPECIFIED.
  25592. C          IER  - ERROR INDICATOR WHICH IS NON-ZERO IF S VIOLATES ABOVE
  25593. C                 CONVENTIONS.  ON RETURN NO TEST HAS BEEN MADE, AND X
  25594. C                 AND Y HAVE BEEN SORTED INTO MONOTONIC NON-DECREASING
  25595. C                 SEQUENCES.  IER IS SET TO ZERO ON ENTRY TO KOLMO.
  25596. C                 IER IS CURRENTLY SET TO ONE IF THE USER-SUPPLIED PDF
  25597. C                 IS REQUESTED FOR TESTING.  THIS SHOULD BE CHANGED
  25598. C                 (SEE REMARKS) WHEN SOME PDF IS SUPPLIED BY THE USER.
  25599. C
  25600. C       REMARKS
  25601. C          N SHOULD BE GREATER THAN OR EQUAL TO 100.  (SEE THE
  25602. C          MATHEMATICAL DESCRIPTION GIVEN FOR THE PROGRAM SMIRN,
  25603. C          CONCERNING ASYMPTOTIC FORMULAE)  ALSO, PROBABILITY LEVELS
  25604. C          DETERMINED BY THIS PROGRAM WILL NOT BE CORRECT IF THE
  25605. C          SAME SAMPLES ARE USED TO ESTIMATE PARAMETERS FOR THE
  25606. C          CONTINUOUS DISTRIBUTIONS WHICH ARE USED IN THIS TEST.
  25607. C          (SEE THE MATHEMATICAL DESCRIPTION FOR THIS PROGRAM)
  25608. C          F(X) SHOULD BE A CONTINUOUS FUNCTION.
  25609. C          ANY USER SUPPLIED CUMULATIVE PROBABILITY DISTRIBUTION
  25610. C          FUNCTION SHOULD BE CODED BEGINNING WITH STATEMENT 26 BELOW,
  25611. C          AND SHOULD RETURN TO STATEMENT 27.
  25612. C
  25613. C          DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL
  25614. C          WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY.
  25615. C          IF ONE WISHES TO COMMUNICATE WITH KOLMO IN A DOUBLE
  25616. C          PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED
  25617. C          PROGRAM SNGL(X) PRIOR TO CALLING KOLMO, AND CALL THE
  25618. C          FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLMO.
  25619. C          (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION
  25620. C          CAPABILITY AS SUPPLIED BY THIS PACKAGE.)
  25621. C
  25622. C
  25623. C       SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
  25624. C          SMIRN, NDTR, AND ANY USER SUPPLIED SUBROUTINES REQUIRED.
  25625. C
  25626. C       METHOD
  25627. C          FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV
  25628. C          LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS--
  25629. C          ANNALS OF MATH. STAT., 19, 1948.  177-189,
  25630. C          (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT
  25631. C          OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19,
  25632. C          1948.  279-281.
  25633. C          (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND
  25634. C          STATISTICS--ACADEMIC PRESS, NEW YORK, 1964.  490-493,
  25635. C          (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA
  25636. C          PUBLISHING COMPANY, NEW YORK, 1962.  384-401.
  25637. C
  25638. C    ..................................................................
  25639. C
  25640.     SUBROUTINE KOLMO(X,N,Z,PROB,IFCOD,U,S,IER)
  25641.     DIMENSION X(1)
  25642. C
  25643. C         NON DECREASING ORDERING OF X(I)'S  (DUBY METHOD)
  25644. C
  25645.     IER=0
  25646.     DO 5 I=2,N
  25647.     IF(X(I)-X(I-1))1,5,5
  25648. 1    TEMP=X(I)
  25649.     IM=I-1
  25650.     DO 3 J=1,IM
  25651.     L=I-J
  25652.     IF(TEMP-X(L))2,4,4
  25653. 2    X(L+1)=X(L)
  25654. 3    CONTINUE
  25655.     X(1)=TEMP
  25656.     GO TO 5
  25657. 4    X(L+1)=TEMP
  25658. 5    CONTINUE
  25659. C
  25660. C          COMPUTES MAXIMUM DEVIATION DN IN ABSOLUTE VALUE BETWEEN
  25661. C          EMPIRICAL AND THEORETICAL DISTRIBUTIONS
  25662. C
  25663.     NM1=N-1
  25664.     XN=N
  25665.     DN=0.0
  25666.     FS=0.0
  25667.     IL=1
  25668. 6    DO 7  I=IL,NM1
  25669.     J=I
  25670.     IF(X(J)-X(J+1))9,7,9
  25671. 7    CONTINUE
  25672. 8    J=N
  25673. 9    IL=J+1
  25674.     FI=FS
  25675.     FS=FLOAT(J)/XN
  25676.     IF(IFCOD-2)10,13,17
  25677. 10    IF(S)11,11,12
  25678. 11    IER=1
  25679.     GO TO 29
  25680. 12    Z =(X(J)-U)/S
  25681.     CALL NDTR(Z,Y,D)
  25682.     GO TO 27
  25683. 13    IF(S)11,11,14
  25684. 14    Z=(X(J)-U)/S+1.0
  25685.     IF(Z)15,15,16
  25686. 15    Y=0.0
  25687.     GO TO 27
  25688. 16    Y=1.-EXP(-Z)
  25689.     GO TO 27
  25690. 17    IF(IFCOD-4)18,20,26
  25691. 18    IF(S)19,11,19
  25692. 19    Y=ATAN((X(J)-U)/S)*0.3183099+0.5
  25693.     GO TO 27
  25694. 20    IF(S-U)11,11,21
  25695. 21    IF(X(J)-U)22,22,23
  25696. 22    Y=0.0
  25697.     GO TO 27
  25698. 23    IF(X(J)-S)25,25,24
  25699. 24    Y=1.0
  25700.     GO TO 27
  25701. 25    Y=(X(J)-U)/(S-U)
  25702.     GO TO 27
  25703. 26    IER=1
  25704.     GO TO 29
  25705. 27    EI=ABS(Y-FI)
  25706.     ES=ABS(Y-FS)
  25707.     DN=AMAX1(DN,EI,ES)
  25708.     IF(IL-N)6,8,28
  25709. C
  25710. C          COMPUTES Z=DN*SQRT(N)  AND  PROBABILITY
  25711. C
  25712. 28    Z=DN*SQRT(XN)
  25713.     CALL SMIRN(Z,PROB)
  25714.     PROB=1.0-PROB
  25715. 29    RETURN
  25716.     END
  25717.