C
C	..................................................................
C
C	   SUBROUTINE ABSNT
C
C	   PURPOSE
C	      TEST MISSING OR ZERO VALUES FOR EACH OBSERVATION IN
C	      MATRIX A.
C
C	   USAGE
C	      CALL ABSNT (A,S,NO,NV)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - OBSERVATION MATRIX, NO BY NV
C	      S  - OUTPUT VECTOR OF LENGTH NO INDICATING THE FOLLOWING
C	           CODES FOR EACH OBSERVATION.
C	           1  THERE IS NOT A MISSING OR ZERO VALUE.
C	           0  AT LEAST ONE VALUE IS MISSING OR ZERO.
C	      NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1.
C	      NV - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV MUST BE
C	           GREATER THAN OR EQUAL TO 1.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      A TEST IS MADE FOR EACH ROW (OBSERVATION) OF THE MATRIX A.
C	      IF THERE IS NOT A MISSING OR ZERO VALUE, 1 IS PLACED IN
C	      S(J). IF AT LEAST ONE VALUE IS MISSING OR ZERO, 0 IS PLACED
C	      IN S(J).
C
C	..................................................................
C
	SUBROUTINE ABSNT(A,S,NO,NV)
	DIMENSION A(1),S(1)
C
	DO 20 J=1,NO
	IJ=J-NO
	S(J)=1.0
	DO 10 I=1,NV
	IJ=IJ+NO
	IF(A(IJ)) 10,5,10
5	S(J)=0
	GO TO 20
10	CONTINUE
20	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ACFI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL ACFI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
C	               VALUES OF THE TABLE (POSSIBLY DESTROYED).
C	      VAL    - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION
C	               VALUES OF THE TABLE (DESTROYED).
C	      Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
C	               FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS
C	          DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN
C	          THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME
C	          AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY
C	          ELEMENT BY INTERCHANGING OF TABLE POINTS).
C	          FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO
C	          ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL.
C	          DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS
C	          CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED-
C	      DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406.
C
C	..................................................................
C
	SUBROUTINE ACFI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	IER=2
	IF(NDIM)20,20,1
1	Y=VAL(1)
	DELT2=0.
	IF(NDIM-1)20,20,2
C
C	PREPARATIONS FOR INTERPOLATION LOOP
2	P2=1.
	P3=Y
	Q2=0.
	Q3=1.
C
C
C	START INTERPOLATION LOOP
	DO 16 I=2,NDIM
	II=0
	P1=P2
	P2=P3
	Q1=Q2
	Q2=Q3
	Z=Y
	DELT1=DELT2
	JEND=I-1
C
C	COMPUTATION OF INVERTED DIFFERENCES
3	AUX=VAL(I)
	DO 10 J=1,JEND
	H=VAL(I)-VAL(J)
	IF(ABS(H)-1.E-6*ABS(VAL(I)))4,4,9
4	IF(ARG(I)-ARG(J))5,17,5
5	IF(J-JEND)8,6,6
C
C	INTERCHANGE ROW I WITH ROW I+II
6	II=II+1
	III=I+II
	IF(III-NDIM)7,7,19
7	VAL(I)=VAL(III)
	VAL(III)=AUX
	AUX=ARG(I)
	ARG(I)=ARG(III)
	ARG(III)=AUX
	GOTO 3
C
C	COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1
8	VAL(I)=1.7E38                                                             0
	GOTO 10
C
C	COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J)
9	VAL(I)=(ARG(I)-ARG(J))/H
10	CONTINUE
C	INVERTED DIFFERENCES ARE COMPUTED
C
C	COMPUTATION OF NEW Y
	P3=VAL(I)*P2+(X-ARG(I-1))*P1
	Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1
	IF(Q3)11,12,11
11	Y=P3/Q3
	GOTO 13
12	Y=1.7E38                                                                  0
13	DELT2=ABS(Z-Y)
	IF(DELT2-EPS)19,19,14
14	IF(I-8)16,15,15
15	IF(DELT2-DELT1)16,18,18
16	CONTINUE
C	END OF INTERPOLATION LOOP
C
C
	RETURN
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
17	IER=3
	RETURN
C
C	TEST VALUE DELT2 STARTS OSCILLATING
18	Y=Z
	IER=1
	RETURN
C
C	THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS
19	IER=0
20	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR MATRIX ADDITION - ADSAM
C
C	   PURPOSE
C	      MATRIX ADDITION SAMPLE PROGRAM
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      MADD
C	      MATIN
C	      MXOUT
C	      LOC
C
C	   METHOD
C	      TWO INPUT MATRICES ARE READ FROM THE STANDARD INPUT DEVICE.
C	      THEY ARE ADDED AND THE RESULTANT MATRIX IS LISTED ON
C	      THE STANDARD OUTPUT DEVICE. THIS CAN BE REPEATED FOR ANY
C	      NUMBER OF PAIRS OF MATRICES UNTIL A BLANK CARD IS
C	      ENCOUNTERED
C
C	..................................................................
C
C	   MATRICES ARE DIMENSIONED FOR 1000 ELEMENTS. THEREFORE, PRODUCT
C	   OF NUMBER OF ROWS BY NUMBER OF COLUMNS CANNOT EXCEED 1000.
C
c	DIMENSION A(1000),B(1000),R(1000)
cC
c10	FORMAT(1H1,15HMATRIX ADDITION)
c11	FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4)
c12	FORMAT(1H0,20HEXECUTION TERMINATED)
c13	FORMAT(1H0,32HMATRIX DIMENSIONS NOT CONSISTENT)
c14	FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4)
c15	FORMAT(1H0,18HGO ON TO NEXT CASE)
c16	FORMAT(1H0,11HEND OF CASE)
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	..................................................................
cC
c	WRITE(6,10)
c20	CALL MATIN(ICODA,A,1000,NA,MA,MSA,IER)
c	IF( NA ) 25,95,25
c25	IF(IER-1) 40,30,35
c30	WRITE(6,11) ICODA
c	GO TO 45
c35	WRITE(6,14) ICODA
c37	WRITE(6,12)
c	GO TO 95
c40	CALL MXOUT(ICODA,A,NA,MA,MSA,60,120,2)
c45	CALL MATIN(ICODB,B,1000,NB,MB,MSB,IER)
c	IF(IER-1) 60,50,55
c50	WRITE(6,11) ICODB
c	WRITE(6,15)
c	GO TO 20
c55	WRITE(6,14) ICODB
c	GO TO 37
c60	IF(NA-NB) 75,70,75
c70	IF(MA-MB) 75,80,75
c75	WRITE(6,13)
c	WRITE(6,15)
c	GO TO 20
c80	CALL MXOUT(ICODB,B,NB,MB,MSB,60,120,2)
c	ICODR=ICODA+ICODB
c	CALL MADD(A,B,R,NA,MA,MSA,MSB)
c	MSR=MSA
c	IF(MSA-MSB) 90,90,85
c85	MSR=MSB
c90	CALL MXOUT(ICODR,R,NA,MA,MSR,60,120,2)
c	WRITE(6,16)
c	GO TO 20
c   95	CONTINUE
c	END
C
C	..................................................................
C
C	   SUBROUTINE AHI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND
C	      DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL AHI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
C	               VALUES OF THE TABLE (NOT DESTROYED).
C	      VAL    - THE INPUT VECTOR (DIMENSION 2*NDIM) OF FUNCTION
C	               AND DERIVATIVE VALUES OF THE TABLE (DESTROYED).
C	               FUNCTION AND DERIVATIVE VALUES MUST BE STORED IN
C	               PAIRS, THAT MEANS BEGINNING WITH FUNCTION VALUE AT
C	               POINT ARG(1) EVERY FUNCTION VALUE MUST BE FOLLOWED
C	               BY THE VALUE OF DERIVATIVE AT THE SAME POINT.
C	      Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
C	               FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE
C	          PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
C	          WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
C	          ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
C	      HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND
C	      GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION,
C	      JACM, VOL.11, ISS.3 (1964), PP.352-356.
C
C	..................................................................
C
	SUBROUTINE AHI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	IER=2
	H2=X-ARG(1)
	IF(NDIM-1)2,1,3
1	Y=VAL(1)+VAL(2)*H2
2	RETURN
C
C	VECTOR ARG HAS MORE THAN 1 ELEMENT.
C	THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE
C	USED.
3	I=1
	DO 5 J=2,NDIM
	H1=H2
	H2=X-ARG(J)
	Y=VAL(I)
	VAL(I)=Y+VAL(I+1)*H1
	H=H1-H2
	IF(H)4,13,4
4	VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H
5	I=I+2
	VAL(I)=VAL(I)+VAL(I+1)*H2
C	END OF FIRST STEP
C
C	PREPARE AITKEN SCHEME
	DELT2=0.
	IEND=I-1
C
C	START AITKEN-LOOP
	DO 9 I=1,IEND
	DELT1=DELT2
	Y=VAL(1)
	M=(I+3)/2
	H1=ARG(M)
	DO 6 J=1,I
	K=I+1-J
	L=(K+1)/2
	H=ARG(L)-H1
	IF(H)6,14,6
6	VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H
	DELT2=ABS(Y-VAL(1))
	IF(DELT2-EPS)11,11,7
7	IF(I-5)9,8,8
8	IF(DELT2-DELT1)9,12,12
9	CONTINUE
C	END OF AITKEN-LOOP
C
10	Y=VAL(1)
	RETURN
C
C	THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS
11	IER=0
	GOTO 10
C
C	TEST VALUE DELT2 STARTS OSCILLATING
12	IER=1
	RETURN
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
13	Y=VAL(1)
14	IER=3
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ALI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL ALI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT
C	               VALUES OF THE TABLE (NOT DESTROYED).
C	      VAL    - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION
C	               VALUES OF THE TABLE (DESTROYED).
C	      Y      - THE RESULTING INTERPOLATED FUNCTION VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND
C	               FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE
C	          PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
C	          WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
C	          ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
C	      LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50.
C
C	..................................................................
C
	SUBROUTINE ALI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	IER=2
	DELT2=0.
	IF(NDIM-1)9,7,1
C
C	START OF AITKEN-LOOP
1	DO 6 J=2,NDIM
	DELT1=DELT2
	IEND=J-1
	DO 2 I=1,IEND
	H=ARG(I)-ARG(J)
	IF(H)2,13,2
2	VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H
	DELT2=ABS(VAL(J)-VAL(IEND))
	IF(J-2)6,6,3
3	IF(DELT2-EPS)10,10,4
4	IF(J-5)6,5,5
5	IF(DELT2-DELT1)6,11,11
6	CONTINUE
C	END OF AITKEN-LOOP
C
7	J=NDIM
8	Y=VAL(J)
9	RETURN
C
C	THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS
10	IER=0
	GOTO 8
C
C	TEST VALUE DELT2 STARTS OSCILLATING
11	IER=1
12	J=IEND
	GOTO 8
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
13	IER=3
	GOTO 12
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR ANALYSIS OF VARIANCE - ANOVA
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD FOR ANALYSIS OF VARI-
C	      ANCE, (2) CALL THE SUBROUTINES FOR THE CALCULATION OF SUMS
C	      OF SQUARES, DEGREES OF FREEDOM AND MEAN SQUARE, AND
C	      (3) PRINT FACTOR LEVELS, GRAND MEAN AND ANALYSIS OF VARI-
C	      ANCE TABLE.
C
C	   REMARKS
C	      THE PROGRAM HANDLES ONLY COMPLETE FACTORIAL DESIGNS.  THERE-
C	      FORE, OTHER EXPERIMENTAL DESIGN MUST BE REDUCED TO THIS FORM
C	      PRIOR TO THE USE OF THE PROGRAM.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      AVDAT
C	      AVCAL
C	      MEANQ
C
C	   METHOD
C	      THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
C	      HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
C	      EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
C	      1962, CHAPTER 20.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C	CUMULATIVE PRODUCT OF EACH FACTOR LEVEL PLUS ONE (LEVEL(I)+1)
C	FOR I=1 TO K, WHERE K IS THE NUMBER OF FACTORS..
C
c	   DIMENSION X(3000)
cC
cC	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
cC	NUMBER OF FACTORS..
cC
c	   DIMENSION HEAD(6),LEVEL(6),ISTEP(6),KOUNT(6),LASTS(6)
cC
cC	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO 2 TO
cC	THE K-TH POWER MINUS 1, ((2**K)-1)..
cC
c	   DIMENSION SUMSQ(63),NDF(63),SMEAN(63)
cC
cC	THE FOLLOWING DIMENSION IS USED TO PRINT FACTOR LABELS IN ANALYSIS
cC	OF VARIANCE TABLE AND IS FIXED..
cC
c	   DIMENSION FMT(15)
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION X,GMEAN,SUMSQ,SMEAN,SUM
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	   ...............................................................
cC
c1	FORMAT(A4,A2,I2,A4,3X,11(A1,I4)/(A1,I4,A1,I4,A1,I4,A1,I4,A1,I4))
c2	FORMAT(26H1ANALYSIS OF VARIANCE.....A4,A2//)
c3	FORMAT(18H0LEVELS OF FACTORS/(3X,A1,7X,I4))
c4	FORMAT(1H0//11H GRAND MEANF20.5////)
c5	FORMAT(10H0SOURCE OF18X,7HSUMS OF10X,10HDEGREES OF9X,4HMEAN/10H VA
c     1RIATION18X,7HSQUARES11X,7HFREEDOM10X,7HSQUARES/)
c6	FORMAT(1H 15A1,F20.5,10X,I6,F20.5)
c7	FORMAT(6H TOTAL10X,F20.5,10X,I6)
c8	FORMAT(12F6.0)
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR,PR1,K,BLANK,(HEAD(I),LEVEL(I),I=1,K)
c	IF (EOF) GOTO 999
cC	  PR.....PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	  PR1....PROBLEM NUMBER (CONTINUED)
cC	  K......NUMBER OF FACTORS
cC	  BLANK..BLANK FIELD
cC	  HEAD...FACTOR LABELS
cC	  LEVEL..LEVELS OF FACTORS
cC
cC	PRINT PROBLEM NUMBER AND LEVELS OF FACTORS
cC
c	WRITE (6,2) PR,PR1
c	WRITE (6,3) (HEAD(I),LEVEL(I),I=1,K)
cC
cC	CALCULATE TOTAL NUMBER OF DATA
cC
c	N=LEVEL(1)
c	DO 102 I=2,K
c102	N=N*LEVEL(I)
cC
cC	READ ALL INPUT DATA
cC
c	READ (5,8) (X(I),I=1,N)
cC
c	CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
c	CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
c	CALL MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,ISTEP,KOUNT,LASTS)
cC
cC	PRINT GRAND MEAN
cC
c	WRITE (6,4) GMEAN
cC
cC	PRINT ANALYSIS OF VARIANCE TABLE
cC
c	WRITE (6,5)
c	LL=(2**K)-1
c	ISTEP(1)=1
c	DO 105 I=2,K
c105	ISTEP(I)=0
c	DO 110 I=1,15
c110	FMT(I)=BLANK
c	NN=0
c	SUM=0.0
c120	NN=NN+1
c	L=0
c	DO 140 I=1,K
c	FMT(I)=BLANK
c	IF(ISTEP(I)) 130, 140, 130
c130	L=L+1
c	FMT(L)=HEAD(I)
c140	CONTINUE
c	WRITE (6,6) (FMT(I),I=1,15),SUMSQ(NN),NDF(NN),SMEAN(NN)
c	SUM=SUM+SUMSQ(NN)
c	IF(NN-LL) 145, 170, 170
c145	DO 160 I=1,K
c	IF(ISTEP(I)) 147, 150, 147
c147	ISTEP(I)=0
c	GO TO 160
c150	ISTEP(I)=1
c	GO TO 120
c160	CONTINUE
c170	N=N-1
c	WRITE (6,7) SUM,N
c	GO TO 100
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE APCH
C
C	   PURPOSE
C	      SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF
C	      CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION
C
C	   USAGE
C	      CALL APCH(DATI,N,IP,XD,X0,WORK,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      DATI  - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1)
C	              CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE
C	              FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT
C	              VALUES. THE CONTENT OF VECTOR DATI REMAINS
C	              UNCHANGED.
C	      N     - NUMBER OF GIVEN POINTS
C	      IP    - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF
C	              CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS
C	              IP SHOULD NOT EXCEED N
C	      XD    - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR
C	              TRANSFORMATION OF ARGUMENT RANGE
C	      X0    - RESULTANT ADDITIVE CONSTANT FOR LINEAR
C	              TRANSFORMATION OF ARGUMENT RANGE
C	      WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2
C	              ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
C	              MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM
C	              FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE
C	              AND SQUARE SUM OF FUNCTION VALUES
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS IN DIMENSION
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1 MEANS COINCIDING ARGUMENTS
C
C	   REMARKS
C	      NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS
C	      NOT POSITIVE.
C	      EXECUTION OF SUBROUTINE APCH IS A PREPARATORY STEP FOR
C	      CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS
C	      IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE APFS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV
C	      POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM.
C	      THE METHOD IS DISCUSSED IN THE ARTICLE
C	      A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED
C	      DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227.
C
C	..................................................................
C
	SUBROUTINE APCH(DATI,N,IP,XD,X0,WORK,IER)
C
C
C	  DIMENSIONED DUMMY VARIABLES
	DIMENSION DATI(1),WORK(1)
C
C	   CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
	IF(N-1)19,20,1
1	IF(IP)19,19,2
C
C	   SEARCH SMALLEST AND LARGEST ARGUMENT
2	IF(IP-N)3,3,19
3	XA=DATI(1)
	X0=XA
	XE=0.
	DO 7 I=1,N
	XM=DATI(I)
	IF(XA-XM)5,5,4
4	XA=XM
5	IF(X0-XM)6,7,7
6	X0=XM
7	CONTINUE
C
C	   INITIALIZE CALCULATION OF NORMAL EQUATIONS
	XD=X0-XA
	M=(IP*(IP+1))/2
	IEND=M+IP+1
	MT2=IP+IP
	MT2M=MT2-1
C
C	   SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
	DO 8 I=1,IP
	J=MT2-I
	WORK(J)=0.
	WORK(I)=0.
	K=M+I
8	WORK(K)=0.
C
C	   CHECK FOR DEGENERATE ARGUMENT RANGE
	IF(XD)20,20,9
C
C	   CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS
9	X0=-(X0+XA)/XD
	XD=2./XD
	SUM=0.
C
C	   START GREAT LOOP OVER ALL GIVEN POINTS
	DO 15 I=1,N
	T=DATI(I)*XD+X0
	J=I+N
	DF=DATI(J)
C
C	   CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS
C	   FOR ARGUMENT T
	XA=1.
	XM=T
	IF(DATI(2*N+1))11,11,10
10	J=J+N
	XA=DATI(J)
	XM=T*XA
11	T=T+T
	SUM=SUM+DF*DF*XA
	DF=DF+DF
	J=1
12	K=M+J
	WORK(K)=WORK(K)+DF*XA
13	WORK(J)=WORK(J)+XA
	IF(J-MT2M)14,15,15
14	J=J+1
	XE=T*XM-XA
	XA=XM
	XM=XE
	IF(J-IP)12,12,13
15	CONTINUE
	WORK(IEND)=SUM+SUM
C
C	   CALCULATE MATRIX OF NORMAL EQUATIONS
	LL=M
	KK=MT2M
	JJ=1
	K=KK
	DO 18 J=1,M
	WORK(LL)=WORK(K)+WORK(JJ)
	LL=LL-1
	IF(K-JJ)16,16,17
16	KK=KK-2
	K=KK
	JJ=1
	GOTO 18
17	JJ=JJ+1
	K=K-1
18	CONTINUE
	IER=0
	RETURN
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
19	IER=-1
	RETURN
C
C	   ERROR RETURN IN CASE OF COINCIDING ARGUMENTS
20	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE APFS
C
C	   PURPOSE
C	      PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL
C	      EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT
C	      OPTIONALLY
C
C	   USAGE
C	      CALL APFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      WORK  - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED
C	              COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE.
C	              THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP
C	              LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK
C	              CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0
C	              THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G.
C	              BY SUBROUTINE APLL.
C	              THE GIVEN MATRIX IS FACTORED IN THE FORM
C	              TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS
C	              DIVIDED BY TRANSPOSE(T).
C	              THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF
C	              IOP EQUALS ZERO.
C	              IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE
C	              STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF
C	              CORRESPONDING DIMENSION AND E0  IS REPLACED BY THE
C	              SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES.
C	              THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2
C	      IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
C	              SQUARES FIT
C	      IRES  - DIMENSION OF CALCULATED LEAST SQUARES FIT.
C	              LET N1, N2, DENOTE THE FOLLOWING NUMBERS
C	              N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF
C	                   SIGNIFICANCE WAS INDICATED DURING FACTORIZATION
C	              N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF
C	                   THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ)
C	              THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE
C	              AND  IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE
C	      IOP   - INPUT PARAMETER FOR SELECTION OF OPERATION
C	              IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF
C	                      THE RIGHT HAND SIDE BY TRANSPOSE(T) AND
C	                      CALCULATION OF THE SQUARE SUM OF ERRORS IS
C	                      PERFORMED ONLY
C	              IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES
C	                      IS CALCULATED ADDITIONALLY
C	              IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE
C	                      UP TO IRES ARE CALCULATED ADDITIONALLY
C	      EPS   - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	              A SENSIBLE VALUE IS BETWEEN 1.E-3 AND 1.E-6
C	      ETA   - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF
C	              ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-6
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER =-1 MEANS NONPOSITIVE IP
C	              IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED
C	                      AND SPECIFIED TOLERANCE OF ERRORS REACHED
C	              IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR
C	                      SPECIFIED TOLERANCE OF ERRORS NOT REACHED
C
C	   REMARKS
C	      THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF
C	      SIGNIFICANCE IS TOL=ABS(EPS*WORK(1)).
C	      THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF
C	      ERRORS IS ABS(ETA*FSQ).
C	      IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2.
C	      IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2.
C	      IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN
C	      ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      CALCULATION OF THE LEAST SQUARES FITS IS DONE USING
C	      CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION.
C	      THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH
C	      RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE
C	      TOLERANCE TOL=ABS(EPS*WORK(1)).
C	      IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A
C	      SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED.
C	      IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS
C	      TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE
C	      ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION
C	      FOR LOSS OF SIGNIFICANCE
C
C	..................................................................
C
	SUBROUTINE APFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION WORK(1)
	IRES=0
C
C	   TEST OF SPECIFIED DIMENSION
	IF(IP)1,1,2
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSION
1	IER=-1
	RETURN
C
C	   INITIALIZE FACTORIZATION PROCESS
2	IPIV=0
	IPP1=IP+1
	IER=1
	ITE=IP*IPP1/2
	IEND=ITE+IPP1
	TOL=ABS(EPS*WORK(1))
	TEST=ABS(ETA*WORK(IEND))
C
C	   START LOOP OVER ALL ROWS OF WORK
	DO 11 I=1,IP
	IPIV=IPIV+I
	JA=IPIV-IRES
	JE=IPIV-1
C
C	   FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS
	JK=IPIV
	DO 9 K=I,IPP1
	SUM=0.
	IF(IRES)5,5,3
3	JK=JK-IRES
	DO 4 J=JA,JE
	SUM=SUM+WORK(J)*WORK(JK)
4	JK=JK+1
5	IF(JK-IPIV)6,6,8
C
C	   TEST FOR LOSS OF SIGNIFICANCE
6	SUM=WORK(IPIV)-SUM
	IF(SUM-TOL)12,12,7
7	SUM=SQRT(SUM)
	WORK(IPIV)=SUM
	PIV=1./SUM
	GOTO 9
C
C	   UPDATE OFF-DIAGONAL TERMS
8	SUM=(WORK(JK)-SUM)*PIV
	WORK(JK)=SUM
9	JK=JK+K
C
C	   UPDATE SQUARE SUM OF ERRORS
	WORK(IEND)=WORK(IEND)-SUM*SUM
C
C	   RECORD ADDRESS OF LAST PIVOT ELEMENT
	IRES=IRES+1
	IADR=IPIV
C
C	   TEST FOR TOLERABLE ERROR IF SPECIFIED
	IF(IOP)10,11,11
10	IF(WORK(IEND)-TEST)13,13,11
11	CONTINUE
	IF(IOP)12,22,12
C
C	   PERFORM BACK SUBSTITUTION IF SPECIFIED
12	IF(IOP)14,23,14
13	IER=0
14	IPIV=IRES
15	IF(IPIV)23,23,16
16	SUM=0.
	JA=ITE+IPIV
	JJ=IADR
	JK=IADR
	K=IPIV
	DO 19 I=1,IPIV
	WORK(JK)=(WORK(JA)-SUM)/WORK(JJ)
	IF(K-1)20,20,17
17	JE=JJ-1
	SUM=0.
	DO 18 J=K,IPIV
	SUM=SUM+WORK(JK)*WORK(JE)
	JK=JK+1
18	JE=JE+J
	JK=JE-IPIV
	JA=JA-1
	JJ=JJ-K
19	K=K-1
20	IF(IOP/2)21,23,21
21	IADR=IADR-IPIV
	IPIV=IPIV-1
	GOTO 15
C
C	   NORMAL RETURN
22	IER=0
23	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE APLL
C
C	   PURPOSE
C	      SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT
C	      TO A GIVEN DISCRETE FUNCTION
C
C	   USAGE
C	      CALL APLL(FFCT,N,IP,P,WORK,DATI,IER)
C	      SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FFCT  - USER CODED SUBROUTINE WHICH MUST BE DECLARED
C	              EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED
C	              CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS
C	              THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR
C	              THE I-TH ARGUMENT IN P(1) UP TO P(IP)
C	              FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1)
C	              N IS THE NUMBER OF ALL POINTS
C	              DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY
C	              NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI
C	              WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT
C	              IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT
C	      N     - NUMBER OF GIVEN POINTS
C	      IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
C	              SQUARES FIT
C	              IP SHOULD NOT EXCEED N
C	      P     - WORKING STORAGE OF DIMENSION IP+1, WHICH
C	              IS USED AS INTERFACE BETWEEN APLL AND THE USER
C	              CODED SUBROUTINE FFCT
C	      WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2.
C	              ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
C	              MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM,
C	              I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE.
C	              THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT
C	              HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS
C	              THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES
C	      DATI  - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN
C	              MAIN LINE AND SUBROUTINE FFCT.
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT
C
C	   REMARKS
C	      TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES
C	      BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR
C	      PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN
C	      SUBROUTINE APLL. ADDITIONAL COMPONENTS OF IER MAY BE
C	      INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH.
C	      IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A
C	      VECTOR IN HIS MAINLINE.
C	      EXECUTION OF SUBROUTINE APLL IS A PREPARATORY STEP FOR
C	      CALCULATION OF THE LINEAR LEAST SQUARES FIT.
C	      NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE APFS
C
C	  SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER
C
C	   METHOD
C	      HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES
C	      AND WEIGHTS) IS COMPLETELY LEFT TO THE USER
C	      ESSENTIALLY HE HAS THREE CHOICES
C	      (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I.
C	      (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS
C	          REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI
C	          (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1
C	          LOCATIONS).
C	          ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE
C	          BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE
C	          STORAGE FOR THE DATA SET IN COMMON.
C	      (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY
C	          ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM
C	          ONE UP TO N WITHIN APLL
C
C	..................................................................
C
	SUBROUTINE APLL(FFCT,N,IP,P,WORK,DATI,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION P(1),WORK(1),DATI(1),IER(1)
C
C	   CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
	IF(N)10,10,1
1	IF(IP)10,10,2
2	IF(N-IP)10,3,3
C
C	   SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
3	IPP1=IP+1
	M=IPP1*(IP+2)/2
	IER(1)=0
	DO 4 I=1,M
4	WORK(I)=0.
C
C	   START GREAT LOOP OVER ALL GIVEN POINTS
	DO 8 I=1,N
	CALL FFCT(I,N,IP,P,DATI,WGT,IER)
	IF(IER(1))9,5,9
5	J=0
	DO 7 K=1,IPP1
	AUX=P(K)*WGT
	DO 6 L=1,K
	J=J+1
6	WORK(J)=WORK(J)+P(L)*AUX
7	CONTINUE
8	CONTINUE
C
C	   NORMAL RETURN
9	RETURN
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
10	IER(1)=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE APMM
C
C	   PURPOSE
C	      APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR
C	      COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE
C	      OF CHEBYSHEV.
C
C	   USAGE
C	      CALL APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE
C	      CALLING PROGRAM.
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER.
C	               IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR
C	               ARGUMENT VALUE X.
C	               USAGE
C	                  CALL FCT(Y,X,K)
C	               DESCRIPTION OF PARAMETERS
C	                  Y   - RESULT VECTOR OF DIMENSION M CONTAINING
C	                        THE VALUES OF GIVEN CONTINUOUS FUNCTIONS
C	                        FOR GIVEN ARGUMENT X
C	                  X   - ARGUMENT VALUE
C	                  K   - AN INTEGER VALUE WHICH IS EQUAL TO M-1
C	               REMARKS
C	                  IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED
C	                  CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO-
C	                  MIALS IS DESIRED SUBROUTINES CNP, CSP, LEP,
C	                  LAP, HEP, RESPECTIVELY FROM SSP COULD BE USED.
C	      N      - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH
C	               IS TO BE APPROXIMATED
C	      M      - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH
C	               THE APPROXIMATING FUNCTION IS CONSTRUCTED.
C	      TOP    - VECTOR OF DIMENSION 3*N.
C	               ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N)
C	               THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP
C	               TO TOP(2*N) THE CORRESPONDING NODES
C	               ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N)
C	               THE ERRORS AT THOSE N NODES.
C	               OTHER VALUES OF TOP ARE SCRATCH.
C	      IHE    - INTEGER VECTOR OF DIMENSION 3*M+4*N+6
C	      PIV    - VECTOR OF DIMENSION 3*M+6.
C	               ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE
C	               RESULTING COEFFICIENTS OF LINEAR APPROXIMATION.
C	      T      - AUXILIARY VECTOR OF DIMENSION (M+2)*(M+2)
C	      ITER   - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF
C	               ITERATIONS NEEDED
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - THE NUMBER OF ITERATIONS HAS REACHED
C	                         THE INTERNAL MAXIMUM N+M
C	                IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA-
C	                         METER M OR N OR SINCE AT SOME ITERATION
C	                         NO SUITABLE PIVOT COULD BE FOUND
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR
C	      N LESS THAN 2.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY
C	      LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF
C	      CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS-
C	      FORMED INTO A LINEAR PROGRAMMING PROBLEM. APMM USES A
C	      REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL
C	      PROBLEM. FOR REFERENCE, SEE
C	      I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND
C	      L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET,
C	      NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306.
C
C	..................................................................
C
	SUBROUTINE APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
C
C
	DIMENSION TOP(1),IHE(1),PIV(1),T(1)
	DOUBLE PRECISION DSUM
C
C	   TEST ON WRONG INPUT PARAMETERS N AND M
	IER=-1
	IF (N-1) 81,81,1
1	IF(M) 81,81,2
C
C	   INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU
2	IER=0
C
C	   PREPARE TOP-ROW TOP
	DO 3 I=1,N
	K=I+N
	J=K+N
	TOP(J)=TOP(K)
3	TOP(K)=-TOP(I)
C
C	   PREPARE INVERSE TRANSFORMATION MATRIX T
	L=M+2
	LL=L*L
	DO 4 I=1,LL
4	T(I)=0.
	K=1
	J=L+1
	DO 5 I=1,L
	T(K)=1.
5	K=K+J
C
C	   PREPARE INDEX-VECTOR IHE
	DO 6 I=1,L
	K=I+L
	J=K+L
	IHE(I)=0
	IHE(K)=I
6	IHE(J)=1-I
	NAN=N+N
	K=L+L+L
	J=K+NAN
	DO 7 I=1,NAN
	K=K+1
	IHE(K)=I
	J=J+1
7	IHE(J)=I
C
C	   SET COUNTER ITER FOR ITERATION-STEPS
	ITER=-1
8	ITER=ITER+1
C
C	   TEST FOR MAXIMUM ITERATION-STEPS
	IF(N+M-ITER) 9,9,10
9	IER=1
	GO TO 69
C
C	   DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP
10	ISE=0
	IPIV=0
	K=L+L+L
	SAVE=0.
C
C	   START TOP-LOOP
	DO 14 I=1,NAN
	IDO=K+I
	HELP=TOP(I)
	IF(HELP-SAVE) 12,12,11
11	SAVE=HELP
	IPIV=I
12	IF(IHE(IDO)) 14,13,14
13	ISE=I
14	CONTINUE
C	   END OF TOP-LOOP
C
C	   IS OPTIMAL TABLEAU REACHED
	IF(IPIV) 69,69,15
C
C	   DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE
15	ILAB=1
	IND=0
	J=ISE
	IF(J) 21,21,34
C
C	   TRANSFER K-TH COLUMN FROM T TO PIV
16	K=(K-1)*L
	DO 17 I=1,L
	J=L+I
	K=K+1
17	PIV(J)=T(K)
C
C	   IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT
18	IF(ISE) 22,22,19
19	ISE=-ISE
C
C	   TRANSFER COLUMNS IN PIV
	J=L+1
	IDO=L+L
	DO 20 I=J,IDO
	K=I+L
20	PIV(K)=PIV(I)
21	J=IPIV
	GO TO 34
C
C	   SEARCH PIVOT-ELEMENT PIV(IND)
22	SAVE=1.E38
	IDO=0
	K=L+1
	LL=L+L
	IND=0
C
C	   START PIVOT-LOOP
	DO 29 I=K,LL
	J=I+L
	HELP=PIV(I)
	IF(HELP) 29,29,23
23	HELP=-HELP
	IF(ISE) 26,24,26
24	IF(IHE(J)) 27,25,27
25	IDO=I
	GO TO 29
26	HELP=-PIV(J)/HELP
27	IF(HELP-SAVE) 28,29,29
28	SAVE=HELP
	IND=I
29	CONTINUE
C	   END OF PIVOT-LOOP
C
C	   TEST FOR SUITABLE PIVOT-ELEMENT
	IF(IND) 30,30,32
30	IF(IDO) 68,68,31
31	IND=IDO
C	   PIVOT-ELEMENT IS STORED IN PIV(IND)
C
C	   COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI
32	REPI=1./PIV(IND)
	IND=IND-L
C
C	   UPDATE THE TOP-ROW TOP OF THE TABLEAU
	ILAB=0
	SAVE=-TOP(IPIV)*REPI
	TOP(IPIV)=SAVE
C
C	   INITIALIZE J AS COUNTER FOR TOP-LOOP
	J=NAN
33	IF(J-IPIV) 34,53,34
34	K=0
C
C	   SEARCH COLUMN IN TRANSFORMATION-MATRIX T
	DO 36 I=1,L
	IF(IHE(I)-J) 36,35,36
35	K=I
	IF(ILAB) 50,50,16
36	CONTINUE
C
C	   GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX
	I=L+L+L+NAN+J
	I=IHE(I)-N
	IF(I) 37,37,38
37	I=I+N
	K=1
38	I=I+NAN
C
C	   CALL SUBROUTINE FCT
	CALL FCT(PIV,TOP(I),M-1)
C
C	   PREPARE THE CALLED VECTOR PIV
	DSUM=0.D0
	IDO=M
	DO 41 I=1,M
	HELP=PIV(IDO)
	IF(K) 39,39,40
39	HELP=-HELP
40	DSUM=DSUM+DBLE(HELP)
	PIV(IDO+1)=HELP
41	IDO=IDO-1
	PIV(L)=-DSUM
	PIV(1)=1.
C
C	   TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T
	IDO=IND
	IF(ILAB) 44,44,42
42	K=1
43	IDO=K
44	DSUM=0.D0
	HELP=0.
C
C	   START MULTIPLICATION-LOOP
	DO 46 I=1,L
	DSUM=DSUM+DBLE(PIV(I)*T(IDO))
	TOL=ABS(SNGL(DSUM))
	IF(TOL-HELP) 46,46,45
45	HELP=TOL
46	IDO=IDO+L
C	   END OF MULTIPLICATION-LOOP
C
	TOL=1.E-5*HELP
	IF(ABS(SNGL(DSUM))-TOL) 47,47,48
47	DSUM=0.D0
48	IF(ILAB) 51,51,49
49	I=K+L
	PIV(I)=DSUM
C
C	   TEST FOR LAST COLUMN-TERM
	K=K+1
	IF(K-L) 43,43,18
50	I=(K-1)*L+IND
	DSUM=T(I)
C
C	   COMPUTE NEW TOP-ELEMENT
51	DSUM=DSUM*DBLE(SAVE)
	TOL=1.E-5*ABS(SNGL(DSUM))
	TOP(J)=TOP(J)+SNGL(DSUM)
	IF(ABS(TOP(J))-TOL) 52,52,53
52	TOP(J)=0.
C
C	   TEST FOR LAST TOP-TERM
53	J=J-1
	IF(J) 54,54,33
C	   END OF TOP-LOOP
C
C	   TRANSFORM PIVOT-COLUMN
54	I=IND+L
	PIV(I)=-1.
	DO 55 I=1,L
	J=I+L
55	PIV(I)=-PIV(J)*REPI
C
C	   UPDATE TRANSFORMATION-MATRIX T
	J=0
	DO 57 I=1,L
	IDO=J+IND
	SAVE=T(IDO)
	T(IDO)=0.
	DO 56 K=1,L
	ISE=K+J
56	T(ISE)=T(ISE)+SAVE*PIV(K)
57	J=J+L
C
C	   UPDATE INDEX-VECTOR IHE
C	   INITIALIZE CHARACTERISTICS
	J=0
	K=0
	ISE=0
	IDO=0
C
C	   START QUESTION-LOOP
	DO 61 I=1,L
	LL=I+L
	ILAB=IHE(LL)
	IF(IHE(I)-IPIV) 59,58,59
58	ISE=I
	J=ILAB
59	IF(ILAB-IND) 61,60,61
60	IDO=I
	K=IHE(I)
61	CONTINUE
C	   END OF QUESTION-LOOP
C
C	   START MODIFICATION
	IF(K) 62,62,63
62	IHE(IDO)=IPIV
	IF(ISE) 67,67,65
63	IF(IND-J) 64,66,64
64	LL=L+L+L+NAN
	K=K+LL
	I=IPIV+LL
	ILAB=IHE(K)
	IHE(K)=IHE(I)
	IHE(I)=ILAB
	IF(ISE) 67,67,65
65	IDO=IDO+L
	I=ISE+L
	IHE(IDO)=J
	IHE(I)=IND
66	IHE(ISE)=0
67	LL=L+L
	J=LL+IND
	I=LL+L+IPIV
	ILAB=IHE(I)
	IHE(I)=IHE(J)
	IHE(J)=ILAB
C	   END OF MODIFICATION
C
	GO TO 8
C
C	   SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND
68	IER=-1
C
C	   EVALUATE FINAL TABLEAU
C	   COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND
C	   HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS
69	SAVE=0.
	HELP=0.
	K=L+L+L
	DO 73 I=1,NAN
	IDO=K+I
	J=IHE(IDO)
	IF(J) 71,70,73
70	SAVE=-TOP(I)
71	IF(M+J+1) 73,72,73
72	HELP=TOP(I)
73	CONTINUE
C
C	   PREPARE T,TOP,PIV
	T(1)=SAVE
	IDO=NAN+1
	J=NAN+N
	DO 74 I=IDO,J
74	TOP(I)=SAVE
	DO 75 I=1,M
75	PIV(I)=HELP
C
C	   COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI
C	   AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N)
	DO 79 I=1,NAN
	IDO=K+I
	J=IHE(IDO)
	IF(J) 76,79,77
76	J=-J
	PIV(J)=HELP-TOP(I)
	GO TO 79
77	IF(J-N) 78,78,79
78	J=J+NAN
	TOP(J)=SAVE+TOP(I)
79	CONTINUE
	DO 80 I=1,N
	IDO=NAN+I
80	TOP(I)=TOP(IDO)
81	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ARAT
C
C	   PURPOSE
C	      CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE
C	      FUNCTION IN THE LEAST SQUARES SENSE
C
C	   USAGE
C	      CALL ARAT(DATI,N,WORK,P,IP,IQ,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      DATI  - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS
C	              THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS,
C	              THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND
C	              THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY.
C	              IF NO WEIGHTS ARE TO BE USED THEN THE THIRD
C	              COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT
C	              WHICH MUST CONTAIN A NONPOSITIVE VALUE
C	      N     - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION
C	      WORK  - WORKING STORAGE WHICH IS OF DIMENSION
C	              (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST.
C	              ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED
C	              IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF
C	              THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO
C	              WORK(3*N)
C	      P     - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND
C	              NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ
C	              LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP
C	              LOCATIONS.
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH.
C	      IP    - DIMENSION OF THE NUMERATOR   (INPUT VALUE)
C	      IQ    - DIMENSION OF THE DENOMINATOR (INPUT VALUE)
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION
C	              IER IS ALSO USED AS INPUT VALUE
C	              A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN
C	              INITIAL APPROXIMATION STORED IN P
C
C	   REMARKS
C	      THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR
C	      OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P
C	      STARTING WITH LOW POWERS (DENOMINATOR FIRST).
C	      IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE.
C	      SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL
C	      FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL
C	      (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR
C	      TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS.
C	      IF A FIT IN OTHER FUNCTIONS IS REQUIRED, CNP AND CNPS MUST
C	      BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      APLL, APFS, FRAT, CNPS, CNP
C	      CNP IS REQUIRED WITHIN FRAT
C
C	   METHOD
C	      THE ITERATIVE SCHEME USED FOR CALCULATION OF THE
C	      APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS
C	      WHICH ARE OBTAINED BY LINEARIZATION.
C	      A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH
C	      IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF
C	      ZEROES WITHIN THE APPROXIMATION INTERVAL.
C	      FOR REFERENCE SEE
C	      D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN,
C	      COMPUTING(1966), VOL.1, ED.3, PP.264-272.
C	      D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION
C	      OF NONLINEAR PARAMETERS,
C	      JSIAM(1963), VOL.11, ED.2, PP.431-441.
C
C	..................................................................
C
	SUBROUTINE ARAT(DATI,N,WORK,P,IP,IQ,IER)
C
C
	EXTERNAL FRAT
C
C	   DIMENSIONED LOCAL VARIABLE
	DIMENSION IERV(3)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION DATI(1),WORK(1),P(1)
C
C	   INITIALIZE TESTVALUES
	LIMIT=20
	ETA =1.E-11
	EPS=1.E-5
C
C	   CHECK FOR FORMAL ERRORS
	IF(N)4,4,1
1	IF(IP)4,4,2
2	IF(IQ)4,4,3
3	IPQ=IP+IQ
	IF(N-IPQ)4,5,5
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
4	IER=-1
	RETURN
C
C	   INITIALIZE ITERATION PROCESS
5	KOUNT=0
	IERV(2)=IP
	IERV(3)=IQ
	NDP=N+N+1
	NNE=NDP+NDP
	IX=IPQ-1
	IQP1=IQ+1
	IRHS=NNE+IPQ*IX/2
	IEND=IRHS+IX
C
C	   TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION
	IF(IER)8,6,8
C
C	   INITIALIZE NUMERATOR AND DENOMINATOR
6	DO 7 I=2,IPQ
7	P(I)=0.
	P(1)=1.
C
C	   CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL
C	   APPROXIMATION
8	DO 9 J=1,N
	T=DATI(J)
	I=J+N
	CALL CNPS(WORK(I),T,P(IQP1),IP)
	K=I+N
9	CALL CNPS(WORK(K),T,P,IQ)
C
C	   SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION)
10	CALL APLL(FRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV)
C
C	   CHECK FOR ZERO DENOMINATOR
	IF(IERV(1))4,11,4
11	INCR=0
	RELAX=2.
C
C	   RESTORE MATRIX IN WORKING STORAGE
12	J=IEND
	DO 13 I=NNE,IEND
	J=J+1
13	WORK(I)=WORK(J)
	IF(KOUNT)14,14,15
C
C	   SAVE SQUARE SUM OF ERRORS
14	OSUM=WORK(IEND)
	DIAG=OSUM*EPS
	K=IQ
C
C	   ADD CONSTANT TO DIAGONAL
	IF(WORK(NNE))17,17,19
15	IF(INCR)19,19,16
16	K=IPQ
17	J=NNE-1
	DO 18 I=1,K
	WORK(J)=WORK(J)+DIAG
18	J=J+I
C
C	   SOLVE NORMAL EQUATIONS
19	CALL APFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER)
C
C	   CHECK FOR FAILURE OF EQUATION SOLVER
	IF(IRES)4,4,20
C
C	   TEST FOR DEFECTIVE NORMALEQUATIONS
20	IF(IRES-IX)21,24,24
21	IF(INCR)22,22,23
22	DIAG=DIAG*0.125
23	DIAG=DIAG+DIAG
	INCR=INCR+1
C
C	   START WITH OVER RELAXATION
	RELAX=8.
	IF(INCR-LIMIT)12,45,45
C
C	   CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR
24	L=NDP
	J=NNE+IRES*(IRES-1)/2-1
	K=J+IQ
	WORK(J)=0.
	IRQ=IQ
	IRP=IRES-IQ+1
	IF(IRP)25,26,26
25	IRQ=IRES+1
26	DO 29 I=1,N
	T=DATI(I)
	WORK(I)=0.
	CALL CNPS(WORK(I),T,WORK(K),IRP)
	M=L+N
	CALL CNPS(WORK(M),T,WORK(J),IRQ)
	IF(WORK(M)*WORK(L))27,29,29
27	SUM=WORK(L)/WORK(M)
	IF(RELAX+SUM)29,29,28
28	RELAX=-SUM
29	L=L+1
C
C	   MODIFY RELAXATION FACTOR IF NECESSARY
	SSOE=OSUM
	ITER=LIMIT
30	SUM=0.
	RELAX=RELAX*0.5
	DO 32 I=1,N
	M=I+N
	K=M+N
	L=K+N
	SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L))
	SAVE=SAVE*SAVE
	IF(DATI(NDP))32,32,31
31	SAVE=SAVE*DATI(K)
32	SUM=SUM+SAVE
	IF(ITER)45,33,33
33	ITER=ITER-1
	IF(SUM-OSUM)34,37,35
34	OSUM=SUM
	GOTO 30
C
C	   TEST FOR IMPROVEMENT
35	IF(OSUM-SSOE)36,30,30
36	RELAX=RELAX+RELAX
37	T=0.
	SAVE=0.
	K=IRES+1
	DO 38 I=2,K
	J=J+1
	T=T+ABS(P(I))
	P(I)=P(I)+RELAX*WORK(J)
38	SAVE=SAVE+ABS(P(I))
C
C	   UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR
	DO 39 I=1,N
	J=I+N
	K=J+N
	L=K+N
	WORK(J)=WORK(J)+RELAX*WORK(I)
39	WORK(K)=WORK(K)+RELAX*WORK(L)
C
C	   TEST FOR CONVERGENCE
	IF(INCR)40,40,42
40	IF(SSOE-OSUM-RELAX*EPS*OSUM)46,46,41
41	IF(ABS(T-SAVE)-RELAX*EPS*SAVE)46,46,42
42	IF(OSUM-ETA*SAVE)46,46,43
43	KOUNT=KOUNT+1
	IF(KOUNT-LIMIT)10,44,44
C
C	   ERROR RETURN IN CASE OF POOR CONVERGENCE
44	IER=2
	RETURN
45	IER=1
	RETURN
C
C	   NORMAL RETURN
46	IER=0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ARRAY
C
C	   PURPOSE
C	      CONVERT DATA ARRAY FROM SINGLE TO DOUBLE DIMENSION OR VICE
C	      VERSA.  THIS SUBROUTINE IS USED TO LINK THE USER PROGRAM
C	      WHICH HAS DOUBLE DIMENSION ARRAYS AND THE SSP SUBROUTINES
C	      WHICH OPERATE ON ARRAYS OF DATA IN A VECTOR FASHION.
C
C	   USAGE
C	      CALL ARRAY (MODE,I,J,N,M,S,D)
C
C	   DESCRIPTION OF PARAMETERS
C	      MODE - CODE INDICATING TYPE OF CONVERSION
C	               1 - FROM SINGLE TO DOUBLE DIMENSION
C	               2 - FROM DOUBLE TO SINGLE DIMENSION
C	      I    - NUMBER OF ROWS IN ACTUAL DATA MATRIX
C	      J    - NUMBER OF COLUMNS IN ACTUAL DATA MATRIX
C	      N    - NUMBER OF ROWS SPECIFIED FOR THE MATRIX D IN
C	             DIMENSION STATEMENT
C	      M    - NUMBER OF COLUMNS SPECIFIED FOR THE MATRIX D IN
C	             DIMENSION STATEMENT
C	      S    - IF MODE=1, THIS VECTOR IS INPUT WHICH CONTAINS THE
C	             ELEMENTS OF A DATA MATRIX OF SIZE I BY J. COLUMN I+1
C	             OF DATA MATRIX FOLLOWS COLUMN I, ETC. IF MODE=2,
C	             THIS VECTOR IS OUTPUT REPRESENTING A DATA MATRIX OF
C	             SIZE I BY J CONTAINING ITS COLUMNS CONSECUTIVELY.
C	             THE LENGTH OF S IS IJ, WHERE IJ=I*J.
C	      D    - IF MODE=1, THIS MATRIX OF SIZE N BY M IS OUTPUT,
C	             CONTAINING A DATA MATRIX OF SIZE I BY J IN THE FIRST
C	             I ROWS AND J COLUMNS. IF MODE=2, THIS N BY M MATRIX
C	             IS INPUT CONTAINING A DATA MATRIX OF SIZE I BY J IN
C	             THE FIRST I ROWS AND J COLUMNS.
C
C	   REMARKS
C	      VECTOR S CAN BE IN THE SAME LOCATION AS MATRIX D.  VECTOR S
C	      IS REFERRED AS A MATRIX IN OTHER SSP ROUTINES, SINCE IT
C	      CONTAINS A DATA MATRIX.
C	      THIS SUBROUTINE CONVERTS ONLY GENERAL DATA MATRICES (STORAGE
C	      MODE OF 0).
C
C	   SUBROUTINES AND FUNCTION SUBROUTINES REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO THE DISCUSSION ON VARIABLE DATA SIZE IN THE SECTION
C	      DESCRIBING OVERALL RULES FOR USAGE IN THIS MANUAL.
C
C	..................................................................
C
	SUBROUTINE ARRAY (MODE,I,J,N,M,S,D)
	DIMENSION S(1),D(1)
C
	NI=N-I
C
C	   TEST TYPE OF CONVERSION
C
	IF(MODE-1) 100, 100, 120
C
C	   CONVERT FROM SINGLE TO DOUBLE DIMENSION
C
100	IJ=I*J+1
	NM=N*J+1
	DO 110 K=1,J
	NM=NM-NI
	DO 110 L=1,I
	IJ=IJ-1
	NM=NM-1
110	D(NM)=S(IJ)
	GO TO 140
C
C	   CONVERT FROM DOUBLE TO SINGLE DIMENSION
C
120	IJ=0
	NM=0
	DO 130 K=1,J
	DO 125 L=1,I
	IJ=IJ+1
	NM=NM+1
125	S(IJ)=D(NM)
130	NM=NM+NI
C
140	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ATEIG
C
C	   PURPOSE
C	      COMPUTE THE EIGENVALUES OF A REAL ALMOST TRIANGULAR MATRIX
C
C	   USAGE
C	      CALL ATEIG(M,A,RR,RI,IANA,IA)
C
C	   DESCRIPTION OF THE PARAMETERS
C	      M      ORDER OF THE MATRIX
C	      A      THE INPUT MATRIX, M BY M
C	      RR     VECTOR CONTAINING THE REAL PARTS OF THE EIGENVALUES
C	             ON RETURN
C	      RI     VECTOR CONTAINING THE IMAGINARY PARTS OF THE EIGEN-
C	             VALUES ON RETURN
C	      IANA   VECTOR WHOSE DIMENSION MUST BE GREATER THAN OR EQUAL
C	             TO M, CONTAINING ON RETURN INDICATIONS ABOUT THE WAY
C	             THE EIGENVALUES APPEARED (SEE MATH. DESCRIPTION)
C	      IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A
C	             IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE
C	             SUBSCRIPTED DATA STORAGE MODE.
C	             IA=M WHEN THE MATRIX IS IN SSP VECTOR STORAGE MODE.
C
C	   REMARKS
C	      THE ORIGINAL MATRIX IS DESTROYED
C	      THE DIMENSION OF RR AND RI MUST BE GREATER OR EQUAL TO M
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      QR DOUBLE ITERATION
C
C	   REFERENCES
C	      J.G.F. FRANCIS - THE QR TRANSFORMATION---THE COMPUTER
C	      JOURNAL, VOL. 4, NO. 3, OCTOBER 1961, VOL. 4, NO. 4, JANUARY
C	      1962.  J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
C	      CLARENDON PRESS, OXFORD, 1965.
C
C	..................................................................
C
	SUBROUTINE ATEIG(M,A,RR,RI,IANA,IA)
	DIMENSION A(1),RR(1),RI(1),PRR(2),PRI(2),IANA(1)
	INTEGER P,P1,Q
C
	E7=1.0E-8
	E6=1.0E-6
	E10=1.0E-10
	DELTA=0.5
	MAXIT=30
C
C	   INITIALIZATION
C
	N=M
20	N1=N-1
	IN=N1*IA
	NN=IN+N
	IF(N1) 30,1300,30
30	NP=N+1
C
C	   ITERATION COUNTER
C
	IT=0
C
C	   ROOTS OF THE 2ND ORDER MAIN SUBMATRIX AT THE PREVIOUS
C	   ITERATION
C
	DO 40 I=1,2
	PRR(I)=0.0
40	PRI(I)=0.0
C
C	   LAST TWO SUBDIAGONAL ELEMENTS AT THE PREVIOUS ITERATION
C
	PAN=0.0
	PAN1=0.0
C
C	   ORIGIN SHIFT
C
	R=0.0
	S=0.0
C
C	   ROOTS OF THE LOWER MAIN 2 BY 2 SUBMATRIX
C
	N2=N1-1
	IN1=IN-IA
	NN1=IN1+N
	N1N=IN+N1
	N1N1=IN1+N1
60	T=A(N1N1)-A(NN)
	U=T*T
	V=4.0*A(N1N)*A(NN1)
	IF(ABS(V)-U*E7) 100,100,65
65	T=U+V
	IF(ABS(T)-AMAX1(U,ABS(V))*E6) 67,67,68
67	T=0.0
68	U=(A(N1N1)+A(NN))/2.0
	V=SQRT(ABS(T))/2.0
	IF(T)140,70,70
70	IF(U) 80,75,75
75	RR(N1)=U+V
	RR(N)=U-V
	GO TO 130
80	RR(N1)=U-V
	RR(N)=U+V
	GO TO 130
100	IF(T)120,110,110
110	RR(N1)=A(N1N1)
	RR(N)=A(NN)
	GO TO 130
120	RR(N1)=A(NN)
	RR(N)=A(N1N1)
130	RI(N)=0.0
	RI(N1)=0.0
	GO TO 160
140	RR(N1)=U
	RR(N)=U
	RI(N1)=V
	RI(N)=-V
160	IF(N2)1280,1280,180
C
C	   TESTS OF CONVERGENCE
C
180	N1N2=N1N1-IA
	RMOD=RR(N1)*RR(N1)+RI(N1)*RI(N1)
	EPS=E10*SQRT(RMOD)
	IF(ABS(A(N1N2))-EPS)1280,1280,240
240	IF(ABS(A(NN1))-E10*ABS(A(NN))) 1300,1300,250
250	IF(ABS(PAN1-A(N1N2))-ABS(A(N1N2))*E6) 1240,1240,260
260	IF(ABS(PAN-A(NN1))-ABS(A(NN1))*E6)1240,1240,300
300	IF(IT-MAXIT) 320,1240,1240
C
C	   COMPUTE THE SHIFT
C
320	J=1
	DO 360 I=1,2
	K=NP-I
	IF(ABS(RR(K)-PRR(I))+ABS(RI(K)-PRI(I))-DELTA*(ABS(RR(K))
     1    +ABS(RI(K)))) 340,360,360
340	J=J+I
360	CONTINUE
	GO TO (440,460,460,480),J
440	R=0.0
	S=0.0
	GO TO 500
460	J=N+2-J
	R=RR(J)*RR(J)
	S=RR(J)+RR(J)
	GO TO 500
480	R=RR(N)*RR(N1)-RI(N)*RI(N1)
	S=RR(N)+RR(N1)
C
C	   SAVE THE LAST TWO SUBDIAGONAL TERMS AND THE ROOTS OF THE
C	   SUBMATRIX BEFORE ITERATION
C
500	PAN=A(NN1)
	PAN1=A(N1N2)
	DO 520 I=1,2
	K=NP-I
	PRR(I)=RR(K)
520	PRI(I)=RI(K)
C
C	   SEARCH FOR A PARTITION OF THE MATRIX, DEFINED BY P AND Q
C
	P=N2
	IF (N-3)600,600,525
525	IPI=N1N2
	DO 580 J=2,N2
	IPI=IPI-IA-1
	IF(ABS(A(IPI))-EPS) 600,600,530
530	IPIP=IPI+IA
	IPIP2=IPIP+IA
	D=A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R
	IF(D)540,560,540
540	IF(ABS(A(IPI)*A(IPIP+1))*(ABS(A(IPIP)+A(IPIP2+1)-S)+ABS(A(IPIP2+2)
     1 )) -ABS(D)*EPS) 620,620,560
560	P=N1-J
580	CONTINUE
600	Q=P
	GO TO 680
620	P1=P-1
	Q=P1
	IF (P1-1) 680,680,650
650	DO 660 I=2, P1
	IPI=IPI-IA-1
	IF(ABS(A(IPI))-EPS)680,680,660
660	Q=Q-1
C
C	   QR DOUBLE ITERATION
C
680	II=(P-1)*IA+P
	DO 1220 I=P,N1
	II1=II-IA
	IIP=II+IA
	IF(I-P)720,700,720
700	IPI=II+1
	IPIP=IIP+1
C
C	   INITIALIZATION OF THE TRANSFORMATION
C
	G1=A(II)*(A(II)-S)+A(IIP)*A(IPI)+R
	G2=A(IPI)*(A(IPIP)+A(II)-S)
	G3=A(IPI)*A(IPIP+1)
	A(IPI+1)=0.0
	GO TO 780
720	G1=A(II1)
	G2=A(II1+1)
	IF(I-N2)740,740,760
740	G3=A(II1+2)
	GO TO 780
760	G3=0.0
780	CAP=SQRT(G1*G1+G2*G2+G3*G3)
	IF(CAP)800,860,800
800	IF(G1)820,840,840
820	CAP=-CAP
840	T=G1+CAP
	PSI1=G2/T
	PSI2=G3/T
	ALPHA=2.0/(1.0+PSI1*PSI1+PSI2*PSI2)
	GO TO 880
860	ALPHA=2.0
	PSI1=0.0
	PSI2=0.0
880	IF(I-Q)900,960,900
900	IF(I-P)920,940,920
920	A(II1)=-CAP
	GO TO 960
940	A(II1)=-A(II1)
C
C	   ROW OPERATION
C
960	IJ=II
	DO 1040 J=I,N
	T=PSI1*A(IJ+1)
	IF(I-N1)980,1000,1000
980	IP2J=IJ+2
	T=T+PSI2*A(IP2J)
1000	ETA=ALPHA*(T+A(IJ))
	A(IJ)=A(IJ)-ETA
	A(IJ+1)=A(IJ+1)-PSI1*ETA
	IF(I-N1)1020,1040,1040
1020	A(IP2J)=A(IP2J)-PSI2*ETA
1040	IJ=IJ+IA
C
C	   COLUMN OPERATION
C
	IF(I-N1)1080,1060,1060
1060	K=N
	GO TO 1100
1080	K=I+2
1100	IP=IIP-I
	DO 1180 J=Q,K
	JIP=IP+J
	JI=JIP-IA
	T=PSI1*A(JIP)
	IF(I-N1)1120,1140,1140
1120	JIP2=JIP+IA
	T=T+PSI2*A(JIP2)
1140	ETA=ALPHA*(T+A(JI))
	A(JI)=A(JI)-ETA
	A(JIP)=A(JIP)-ETA*PSI1
	IF(I-N1)1160,1180,1180
1160	A(JIP2)=A(JIP2)-ETA*PSI2
1180	CONTINUE
	IF(I-N2)1200,1220,1220
1200	JI=II+3
	JIP=JI+IA
	JIP2=JIP+IA
	ETA=ALPHA*PSI2*A(JIP2)
	A(JI)=-ETA
	A(JIP)=-ETA*PSI1
	A(JIP2)=A(JIP2)-ETA*PSI2
1220	II=IIP+1
	IT=IT+1
	GO TO 60
C
C	   END OF ITERATION
C
1240	IF(ABS(A(NN1))-ABS(A(N1N2))) 1300,1280,1280
C
C	   TWO EIGENVALUES HAVE BEEN FOUND
C
1280	IANA(N)=0
	IANA(N1)=2
	N=N2
	IF(N2)1400,1400,20
C
C	   ONE EIGENVALUE HAS BEEN FOUND
C
1300	RR(N)=A(NN)
	RI(N)=0.0
	IANA(N)=1
	IF(N1)1400,1400,1320
1320	N=N1
	GO TO 20
1400	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ATSE
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE
C	      SELECTED AND ORDERED SUCH THAT
C	      ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL ATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE SEARCH ARGUMENT.
C	      ZS     - THE STARTING VALUE OF ARGUMENTS.
C	      DZ     - THE INCREMENT OF ARGUMENT VALUES.
C	      F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
C	               (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
C	               COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
C	               THE SECOND THE VECTOR OF DERIVATIVES.
C	      IROW   - THE DIMENSION OF EACH COLUMN IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
C	               ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
C	               (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
C	               VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
C	               (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
C	               EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
C	               VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE.
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE ATSE.
C	      SUBROUTINE ATSE ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT
C	      ARGUMENT, WHICH IS NEXT TO X.
C	      AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
C	      SELECTED IN THE ABOVE SENSE.
C
C	..................................................................
C
	SUBROUTINE ATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION F(1),ARG(1),VAL(1)
	IF(IROW-1)19,17,1
C
C	CASE DZ=0 IS CHECKED OUT
1	IF(DZ)2,17,2
2	N=NDIM
C
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)4,4,3
3	N=IROW
C
C	COMPUTATION OF STARTING SUBSCRIPT J.
4	J=(X-ZS)/DZ+1.5
	IF(J)5,5,6
5	J=1
6	IF(J-IROW)8,8,7
7	J=IROW
C
C	GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0.
8	II=J
	JL=0
	JR=0
	DO 16 I=1,N
	ARG(I)=ZS+FLOAT(II-1)*DZ
	IF(ICOL-2)9,10,10
9	VAL(I)=F(II)
	GOTO 11
10	VAL(2*I-1)=F(II)
	III=II+IROW
	VAL(2*I)=F(III)
11	IF(J+JR-IROW)12,15,12
12	IF(J-JL-1)13,14,13
13	IF((ARG(I)-X)*DZ)14,15,15
14	JR=JR+1
	II=J+JR
	GOTO 16
15	JL=JL+1
	II=J-JL
16	CONTINUE
	RETURN
C
C	CASE DZ=0
17	ARG(1)=ZS
	VAL(1)=F(1)
	IF(ICOL-2)19,19,18
18	VAL(2)=F(2)
19	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ATSG
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND
C	      ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL ATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE SEARCH ARGUMENT.
C	      Z      - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW).
C	      F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
C	               (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
C	               COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
C	               THE SECOND THE VECTOR OF DERIVATIVES.
C	      WORK   - A WORKING STORAGE (DIMENSION IROW).
C	      IROW   - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH
C	               COLUMN IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
C	               ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
C	               (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
C	               VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
C	               (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
C	               EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
C	               VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE (Z,F).
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE ATSG.
C	      SUBROUTINE ATSG ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH
C	      COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS
C	      (OR IROW STEPS IF NDIM IS GREATER THAN IROW)
C	      SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH
C	      IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN
C	      MAX(WORK(I)).
C
C	..................................................................
C
	SUBROUTINE ATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1)
	IF(IROW)11,11,1
1	N=NDIM
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)3,3,2
2	N=IROW
C
C	GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT.
3	B=0.
	DO 5 I=1,IROW
	DELTA=ABS(Z(I)-X)
	IF(DELTA-B)5,5,4
4	B=DELTA
5	WORK(I)=DELTA
C
C	GENERATION OF TABLE (ARG,VAL)
	B=B+1.
	DO 10 J=1,N
	DELTA=B
	DO 7 I=1,IROW
	IF(WORK(I)-DELTA)6,7,7
6	II=I
	DELTA=WORK(I)
7	CONTINUE
	ARG(J)=Z(II)
	IF(ICOL-1)8,9,8
8	VAL(2*J-1)=F(II)
	III=II+IROW
	VAL(2*J)=F(III)
	GOTO 10
9	VAL(J)=F(II)
10	WORK(II)=B
11	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ATSM
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE
C	      SELECTED AND ORDERED SUCH THAT
C	      ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL ATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE SEARCH ARGUMENT.
C	      Z      - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW).
C	               THE ARGUMENT VALUES MUST BE STORED IN INCREASING
C	               OR DECREASING SEQUENCE.
C	      F      - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES
C	               (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST
C	               COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND
C	               THE SECOND THE VECTOR OF DERIVATIVES.
C	      IROW   - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN
C	               IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - THE RESULTING VECTOR OF SELECTED AND ORDERED
C	               ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES
C	               (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2,
C	               VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES
C	               (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E.
C	               EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE
C	               VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE (Z,F).
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE ATSM.
C	      SUBROUTINE ATSM ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT
C	      ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH).
C	      AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
C	      SELECTED IN THE ABOVE SENSE.
C
C	..................................................................
C
	SUBROUTINE ATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION Z(1),F(1),ARG(1),VAL(1)
C
C	CASE IROW=1 IS CHECKED OUT
	IF(IROW-1)23,21,1
1	N=NDIM
C
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)3,3,2
2	N=IROW
C
C	CASE IROW.GE.2
C	SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X.
3	IF(Z(IROW)-Z(1))5,4,4
4	J=IROW
	I=1
	GOTO 6
5	I=IROW
	J=1
6	K=(J+I)/2
	IF(X-Z(K))7,7,8
7	J=K
	GOTO 9
8	I=K
9	IF(IABS(J-I)-1)10,10,6
10	IF(ABS(Z(J)-X)-ABS(Z(I)-X))12,12,11
11	J=I
C
C	TABLE SELECTION
12	K=J
	JL=0
	JR=0
	DO 20 I=1,N
	ARG(I)=Z(K)
	IF(ICOL-1)14,14,13
13	VAL(2*I-1)=F(K)
	KK=K+IROW
	VAL(2*I)=F(KK)
	GOTO 15
14	VAL(I)=F(K)
15	JJR=J+JR
	IF(JJR-IROW)16,18,18
16	JJL=J-JL
	IF(JJL-1)19,19,17
17	IF(ABS(Z(JJR+1)-X)-ABS(Z(JJL-1)-X))19,19,18
18	JL=JL+1
	K=J-JL
	GOTO 20
19	JR=JR+1
	K=J+JR
20	CONTINUE
	RETURN
C
C	CASE IROW=1
21	ARG(1)=Z(1)
	VAL(1)=F(1)
	IF(ICOL-2)23,22,23
22	VAL(2)=F(2)
23	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE AUTO
C
C	   PURPOSE
C	      TO FIND AUTOCOVARIANCES OF SERIES A FOR LAGS 0 TO L-1.
C
C	   USAGE
C	      CALL AUTO (A,N,L,R)
C
C	   DESCRIPTION OF PARAMETERS
C	      A    - INPUT VECTOR OF LENGTH N CONTAINING THE TIME SERIES
C	             WHOSE AUTOCOVARIANCE IS DESIRED.
C	      N    - LENGTH OF THE VECTOR A.
C	      L    - AUTOCOVARIANCE IS CALCULATED FOR LAGS OF 0, 1, 2,...,
C	             L-1.
C	      R    - OUTPUT VECTOR OF LENGTH L CONTAINING AUTOCOVARIANCES
C	             OF SERIES A.
C
C	   REMARKS
C	      THE LENGTH OF R IS DIFFERENT FROM THE LENGTH OF A.  N MUST
C	      BE GREATER THAN L.  IF NOT, R(1) IS SET TO ZERO AND RETURN
C	      IS MADE TO THE CALLING PROGRAM.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT
C	   OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959.
C
C	..................................................................
C
	SUBROUTINE AUTO (A,N,L,R)
	DIMENSION A(1),R(1)
C
C	CALCULATE AVERAGE OF TIME SERIES A
C
	AVER=0.0
	IF(N-L) 50,50,100
50	R(1)=0.0
	RETURN
100	DO 110 I=1,N
110	AVER=AVER+A(I)
	FN=N
	AVER=AVER/FN
C
C	CALCULATE AUTOCOVARIANCES
C
	DO 130 J=1,L
	NJ=N-J+1
	SUM=0.0
	DO 120 I=1,NJ
	IJ=I+J-1
120	SUM=SUM+(A(I)-AVER)*(A(IJ)-AVER)
	FNJ=NJ
130	R(J)=SUM/FNJ
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE AVCAL
C
C	   PURPOSE
C	      PERFORM THE CALCULUS OF A FACTORIAL EXPERIMENT USING
C	      OPERATOR SIGMA AND OPERATOR DELTA.  THIS SUBROUTINE IS
C	      PRECEDED BY SUBROUTINE ADVAT AND FOLLOWED BY SUBROUTINE
C	      MEANQ IN THE PERFORMANCE OF ANALYSIS OF VARIANCE FOR A
C	      COMPLETE FACTORIAL DESIGN.
C
C	   USAGE
C	      CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
C
C	   DESCRIPTION OF PARAMETERS
C	      K     - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE.
C	      LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE-
C	              GORIES) WITHIN EACH VARIABLE.
C	      X     - INPUT VECTOR CONTAINING DATA.  DATA HAVE BEEN PLACED
C	              IN VECTOR X BY SUBROUTINE AVDAT.  THE LENGTH OF X
C	              IS (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).
C	      L     - THE POSITION IN VECTOR X WHERE THE LAST INPUT DATA
C	              IS LOCATED.  L HAS BEEN CALCULATED BY SUBROUTINE
C	              AVDAT.
C	      ISTEP - INPUT VECTOR OF LENGTH K CONTAINING STORAGE CONTROL
C	              STEPS WHICH HAVE BEEN CALCULATED BY SUBROUTINE
C	              AVDAT.
C	      LASTS - WORKING VECTOR OF LENGTH K.
C
C	   REMARKS
C	      THIS SUBROUTINE MUST FOLLOW SUBROUTINE AVDAT.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
C	      HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
C	      EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
C	      1962, CHAPTER 20.
C
C	..................................................................
C
	SUBROUTINE AVCAL (K,LEVEL,X,L,ISTEP,LASTS)
	DIMENSION LEVEL(1),X(1),ISTEP(1),LASTS(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION X,SUM
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	CALCULATE THE LAST DATA POSITION OF EACH FACTOR
C
	LASTS(1)=L+1
	DO 145 I=2,K
145	LASTS(I)=LASTS(I-1)+ISTEP(I)
C
C	PERFORM CALCULUS OF OPERATION
C
150	DO 175 I=1,K
	L=1
	LL=1
	SUM=0.0
	NN=LEVEL(I)
	FN=NN
	INCRE=ISTEP(I)
	LAST=LASTS(I)
C
C	SIGMA OPERATION
C
155	DO 160 J=1,NN
	SUM=SUM+X(L)
160	L=L+INCRE
	X(L)=SUM
C
C	DELTA OPERATION
C
	DO 165 J=1,NN
	X(LL)=FN*X(LL)-SUM
165	LL=LL+INCRE
	SUM=0.0
	IF(L-LAST) 167, 175, 175
167	IF(L-LAST+INCRE) 168, 168, 170
168	L=L+INCRE
	LL=LL+INCRE
	GO TO 155
170	L=L+INCRE+1-LAST
	LL=LL+INCRE+1-LAST
	GO TO 155
175	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE AVDAT
C
C	   PURPOSE
C	      PLACE DATA FOR ANALYSIS OF VARIANCE IN PROPERLY DISTRIBUTED
C	      POSITIONS OF STORAGE.  THIS SUBROUTINE IS NORMALLY FOLLOWED
C	      BY CALLS TO AVCAL AND MEANQ SUBROUTINES IN THE PERFORMANCE
C	      OF ANALYSIS OF VARIANCE FOR A COMPLETE FACTORIAL DESIGN.
C
C	   USAGE
C	      CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
C
C	   DESCRIPTION OF PARAMETERS
C	      K     - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE.
C	      LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE-
C	              GORIES) WITHIN EACH VARIABLE.
C	      N     - TOTAL NUMBER OF DATA POINTS READ IN.
C	      X     - WHEN THE SUBROUTINE IS CALLED, THIS VECTOR CONTAINS
C	              DATA IN LOCATIONS X(1) THROUGH X(N).  UPON RETURNING
C	              TO THE CALLING ROUTINE, THE VECTOR CONTAINS THE DATA
C	              IN PROPERLY REDISTRIBUTED LOCATIONS OF VECTOR X.
C	              THE LENGTH OF VECTOR X IS CALCULATED BY (1) ADDING
C	              ONE TO EACH LEVEL OF VARIABLE AND (2) OBTAINING THE
C	              CUMULATIVE PRODUCT OF ALL LEVELS.  (THE LENGTH OF
C	              X = (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).)
C	      L     - OUTPUT VARIABLE CONTAINING THE POSITION IN VECTOR X
C	              WHERE THE LAST INPUT DATA IS STORED.
C	      ISTEP - OUTPUT VECTOR OF LENGTH K CONTAINING CONTROL STEPS
C	              WHICH ARE USED TO LOCATE DATA IN PROPER POSITIONS
C	              OF VECTOR X.
C	      KOUNT - WORKING VECTOR OF LENGTH K.
C
C	   REMARKS
C	      INPUT DATA MUST BE ARRANGED IN THE FOLLOWING MANNER.
C	      CONSIDER THE 3-VARIABLE ANALYSIS OF VARIANCE DESIGN, WHERE
C	      ONE VARIABLE HAS 3 LEVELS AND THE OTHER TWO VARIABLES HAVE
C	      2 LEVELS.  THE DATA MAY BE REPRESENTED IN THE FORM X(I,J,K),
C	      I=1,2,3  J=1,2  K=1,2.  IN ARRANGING DATA, THE INNER
C	      SUBSCRIPT, NAMELY I, CHANGES FIRST.  WHEN I=3, THE NEXT
C	      INNER SUBSCRIPT, J, CHANGES AND SO ON UNTIL I=3, J=2, AND
C	      K=2.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
C	      HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
C	      EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
C	      1962, CHAPTER 20.
C
C	..................................................................
C
	SUBROUTINE AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT)
	DIMENSION LEVEL(1),X(1),ISTEP(1),KOUNT(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION X
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	CALCULATE TOTAL DATA AREA REQUIRED
C
	M=LEVEL(1)+1
	DO 105 I=2,K
105	M=M*(LEVEL(I)+1)
C
C	MOVE DATA TO THE UPPER PART OF THE ARRAY X
C	FOR THE PURPOSE OF REARRANGEMENT
C
	N1=M+1
	N2=N+1
	DO 107 I=1,N
	N1=N1-1
	N2=N2-1
107	X(N1)=X(N2)
C
C	CALCULATE MULTIPLIERS TO BE USED IN FINDING STORAGE LOCATIONS FOR
C	INPUT DATA
C
	ISTEP(1)=1
	DO 110 I=2,K
110	ISTEP(I)=ISTEP(I-1)*(LEVEL(I-1)+1)
	DO 115 I=1,K
115	KOUNT(I)=1
C
C	PLACE DATA IN PROPER LOCATIONS
C
	N1=N1-1
	DO 135 I=1,N
	L=KOUNT(1)
	DO 120 J=2,K
120	L=L+ISTEP(J)*(KOUNT(J)-1)
	N1=N1+1
	X(L)=X(N1)
	DO 130 J=1,K
	IF(KOUNT(J)-LEVEL(J)) 124, 125, 124
124	KOUNT(J)=KOUNT(J)+1
	GO TO 135
125	KOUNT(J)=1
130	CONTINUE
135	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BDTR
C
C	   PURPOSE
C	      COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U,
C	      DISTRIBUTED ACCORDING TO THE BETA DISTRIBUTION WITH
C	      PARAMETERS A AND B, IS LESS THAN OR EQUAL TO X.  F(A,B,X),
C	      THE ORDINATE OF THE BETA DENSITY AT X, IS ALSO COMPUTED.
C
C	   USAGE
C	      CALL BDTR(X,A,B,P,D,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X   - INPUT SCALAR FOR WHICH P(X) IS COMPUTED.
C	      A   - BETA DISTRIBUTION PARAMETER (CONTINUOUS).
C	      B   - BETA DISTRIBUTION PARAMETER (CONTINUOUS).
C	      P   - OUTPUT PROBABILITY.
C	      D   - OUTPUT DENSITY.
C	      IER - RESULTANT ERROR CODE WHERE
C	          IER= 0 --- NO ERROR
C	          IER=-1,+1  CDTR HAS BEEN CALLED AND AN ERROR HAS
C	                     OCCURRED.  SEE CDTR.
C	          IER=-2 --- AN INPUT PARAMETER IS INVALID.  X IS LESS
C	                     THAN 0.0 OR GREATER THAN 1.0, OR EITHER A OR
C	                     B IS LESS THAN 0.5 OR GREATER THAN 10**(+5).
C	                     P AND D ARE SET TO -1.7E38.                          0
C	          IER=+2 --- INVALID OUTPUT.  P IS LESS THAN ZERO OR
C	                     GREATER THAN ONE.  P IS SET TO 1.7E38.               0
C
C	   REMARKS
C	      SEE MATHEMATICAL DESCRIPTION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DLGAM
C	      NDTR
C	      CDTR
C
C	   METHOD
C	      REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL
C	      DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE,
C	      IBM RESEARCH REPORT RC-1094, 1963.
C
C	..................................................................
C
	SUBROUTINE BDTR(X,A,B,P,D,IER)
	DOUBLE PRECISION XX,DLXX,DL1X,AA,BB,G1,G2,G3,G4,DD,PP,XO,FF,FN,
     1XI,SS,CC,RR,DLBETA
C
C	   TEST FOR VALID INPUT DATA
C
	IF(A-(.5-1.E-5)) 640,10,10
10	IF(B-(.5-1.E-5)) 640,20,20
20	IF(A-1.E+5) 30,30,640
30	IF(B-1.E+5) 40,40,640
40	IF(X) 640,50,50
50	IF(1.-X) 640,60,60
C
C	   COMPUTE LOG(BETA(A,B))
C
60	AA=DBLE(A)
	BB=DBLE(B)
	CALL DLGAM(AA,G1,IOK)
	CALL DLGAM(BB,G2,IOK)
	CALL DLGAM(AA+BB,G3,IOK)
	DLBETA=G1+G2-G3
C
C	   TEST FOR X NEAR 0.0 OR 1.0
C
	IF(X-1.E-8) 80,80,70
70	IF((1.-X)-1.E-8) 130,130,140
80	P=0.0
	IF(A-1.) 90,100,120
90	D=1.7E38
	GO TO 660
100	DD=-DLBETA
	IF(DD+1.68D02)  120,120,110
110	DD=DEXP(DD)
	D=SNGL(DD)
	GO TO 660
120	D=0.0
	GO TO 660
130	P=1.0
	IF(B-1.) 90,100,120
C
C	   SET PROGRAM PARAMETERS
C
140	XX=DBLE(X)
	DLXX=DLOG(XX)
	DL1X=DLOG(1.D0-XX)
	XO=XX/(1.D0-XX)
	ID=0
C
C	   COMPUTE ORDINATE
C
	DD=(AA-1.D0)*DLXX+(BB-1.D0)*DL1X-DLBETA
	IF(DD-1.68D02) 150,150,160
150	IF(DD+1.68D02) 170,170,180
160	D=1.7E38                                                                  0
	GO TO 190
170	D=0.0
	GO TO 190
180	DD=DEXP(DD)
	D=SNGL(DD)
C
C	   A OR B OR BOTH WITHIN 1.E-8 OF 1.0
C
190	IF(ABS(A-1.)-1.E-8)  200,200,210
200	IF(ABS(B-1.)-1.E-8)  220,220,230
210	IF(ABS(B-1.)-1.E-8)  260,260,290
220	P=X
	GO TO 660
230	PP=BB*DL1X
	IF(PP+1.68D02) 240,240,250
240	P=1.0
	GO TO 660
250	PP=DEXP(PP)
	PP=1.D0-PP
	P=SNGL(PP)
	GO TO 600
260	PP=AA*DLXX
	IF(PP+1.68D02) 270,270,280
270	P=0.0
	GO TO 660
280	PP=DEXP(PP)
	P=SNGL(PP)
	GO TO 600
C
C	   TEST FOR A OR B GREATER THAN 1000.0
C
290	IF(A-1000.) 300,300,310
300	IF(B-1000.) 330,330,320
310	XX=2.D0*AA/XO
	XS=SNGL(XX)
	AA=2.D0*BB
	DF=SNGL(AA)
	CALL CDTR(XS,DF,P,DUMMY,IER)
	P=1.0-P
	GO TO 670
320	XX=2.D0*BB*XO
	XS=SNGL(XX)
	AA=2.D0*AA
	DF=SNGL(AA)
	CALL CDTR(XS,DF,P,DUMMY,IER)
	GO TO 670
C
C	   SELECT PARAMETERS FOR CONTINUED FRACTION COMPUTATION
C
330	IF(X-.5) 340,340,380
340	IF(AA-1.D0) 350,350,360
350	RR=AA+1.D0
	GO TO 370
360	RR=AA
370	DD=DLXX/5.D0
	DD=DEXP(DD)
	DD=(RR-1.D0)-(RR+BB-1.D0)*XX*DD +2.D0
	IF(DD) 420,420,430
380	IF(BB-1.D0) 390,390,400
390	RR=BB+1.D0
	GO TO 410
400	RR=BB
410	DD=DL1X/5.D0
	DD=DEXP(DD)
	DD=(RR-1.D0)-(AA+RR-1.D0)*(1.D0-XX)*DD +2.D0
	IF(DD) 430,430,420
420	ID=1
	FF=DL1X
	DL1X=DLXX
	DLXX=FF
	XO=1.D0/XO
	FF=AA
	AA=BB
	BB=FF
	G2=G1
C
C	   TEST FOR A LESS THAN 1.0
C
430	FF=0.D0
	IF(AA-1.D0) 440,440,470
440	CALL DLGAM(AA+1.D0,G4,IOK)
	DD=AA*DLXX+BB*DL1X+G3-G2-G4
	IF(DD+1.68D02) 460,460,450
450	FF=FF+DEXP(DD)
460	AA=AA+1.D0
C
C	   COMPUTE P USING CONTINUED FRACTION EXPANSION
C
470	FN=AA+BB-1.D0
	RR=AA-1.D0
	II=80
	XI=DFLOAT(II)
	SS=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI))
	SS=SS*XO
	DO 480 I=1,79
	II=80-I
	XI=DFLOAT(II)
	DD=(XI*(FN+XI))/((RR+2.D0*XI+1.D0)*(RR+2.D0*XI))
	DD=DD*XO
	CC=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI))
	CC=CC*XO
	SS=CC/(1.D0+DD/(1.D0-SS))
480	CONTINUE
	SS=1.D0/(1.D0-SS)
	IF(SS) 650,650,490
490	CALL DLGAM(AA+BB,G1,IOK)
	CALL DLGAM(AA+1.D0,G4,IOK)
	CC=G1-G2-G4+AA*DLXX+(BB-1.D0)*DL1X
	PP=CC+DLOG(SS)
	IF(PP+1.68D02) 500,500,510
500	PP=FF
	GO TO 520
510	PP=DEXP(PP)+FF
520	IF(ID) 540,540,530
530	PP=1.D0-PP
540	P=SNGL(PP)
C
C	   SET ERROR INDICATOR
C
	IF(P) 550,570,570
550	IF(ABS(P)-1.E-7) 560,560,650
560	P=0.0
	GO TO 660
570	IF(1.-P) 580,600,600
580	IF(ABS(1.-P)-1.E-7) 590,590,650
590	P=1.0
	GO TO 660
600	IF(P-1.E-8) 610,610,620
610	P=0.0
	GO TO 660
620	IF((1.0-P)-1.E-8) 630,630,660
630	P=1.0
	GO TO 660
640	IER=-2
	D=-1.7E38                                                                 0
	P=-1.7E38                                                                 0
	GO TO 670
650	IER=+2
	P= 1.7E38                                                                 0
	GO TO 670
660	IER=0
670	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BESJ
C
C	   PURPOSE
C	      COMPUTE THE J BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
C
C	   USAGE
C	      CALL BESJ(X,N,BJ,D,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X  -THE ARGUMENT OF THE J BESSEL FUNCTION DESIRED
C	      N  -THE ORDER OF THE J BESSEL FUNCTION DESIRED
C	      BJ -THE RESULTANT J BESSEL FUNCTION
C	      D  -REQUIRED ACCURACY
C	      IER-RESULTANT ERROR CODE WHERE
C	         IER=0  NO ERROR
C	         IER=1  N IS NEGATIVE
C	         IER=2  X IS NEGATIVE OR ZERO
C	         IER=3  REQUIRED ACCURACY NOT OBTAINED
C	         IER=4  RANGE OF N COMPARED TO X NOT CORRECT (SEE REMARKS)
C
C	   REMARKS
C	      N MUST BE GREATER THAN OR EQUAL TO ZERO, BUT IT MUST BE
C	      LESS THAN
C	         20+10*X-X** 2/3   FOR X LESS THAN OR EQUAL TO 15
C	         90+X/2           FOR X GREATER THAN 15
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      RECURRENCE RELATION TECHNIQUE DESCRIBED BY H. GOLDSTEIN AND
C	      R.M. THALER,'RECURRENCE TECHNIQUES FOR THE CALCULATION OF
C	      BESSEL FUNCTIONS',M.T.A.C.,V.13,PP.102-108 AND I.A. STEGUN
C	      AND M. ABRAMOWITZ,'GENERATION OF BESSEL FUNCTIONS ON HIGH
C	      SPEED COMPUTERS',M.T.A.C.,V.11,1957,PP.255-257
C
C	..................................................................
C
	SUBROUTINE BESJ(X,N,BJ,D,IER)
C
	BJ=.0
	IF(N)10,20,20
10	IER=1
	RETURN
20	IF(X)30,30,31
30	IER=2
	RETURN
31	IF(X-15.)32,32,34
32	NTEST=20.+10.*X-X** 2/3
	GO TO 36
34	NTEST=90.+X/2.
36	IF(N-NTEST)40,38,38
38	IER=4
	RETURN
40	IER=0
	N1=N+1
	BPREV=.0
C
C	COMPUTE STARTING VALUE OF M
C
	IF(X-5.)50,60,60
50	MA=X+6.
	GO TO 70
60	MA=1.4*X+60./X
70	MB=N+IFIX(X)/4+2
	MZERO=MAX0(MA,MB)
C
C	SET UPPER LIMIT OF M
C
	MMAX=NTEST
100	DO 190 M=MZERO,MMAX,3
C
C	SET F(M),F(M-1)
C
	FM1=1.0E-28
	FM=.0
	ALPHA=.0
	IF(M-(M/2)*2)120,110,120
110	JT=-1
	GO TO 130
120	JT=1
130	M2=M-2
	DO 160 K=1,M2
	MK=M-K
	BMK=2.*FLOAT(MK)*FM1/X-FM
	FM=FM1
	FM1=BMK
	IF(MK-N-1)150,140,150
140	BJ=BMK
150	JT=-JT
	S=1+JT
160	ALPHA=ALPHA+BMK*S
	BMK=2.*FM1/X-FM
	IF(N)180,170,180
170	BJ=BMK
180	ALPHA=ALPHA+BMK
	BJ=BJ/ALPHA
	IF(ABS(BJ-BPREV)-ABS(D*BJ))200,200,190
190	BPREV=BJ
	IER=3
200	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BESK
C
C	      COMPUTE THE K BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
C
C	   USAGE
C	      CALL BESK(X,N,BK,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X  -THE ARGUMENT OF THE K BESSEL FUNCTION DESIRED
C	      N  -THE ORDER OF THE K BESSEL FUNCTION DESIRED
C	      BK -THE RESULTANT K BESSEL FUNCTION
C	      IER-RESULTANT ERROR CODE WHERE
C	         IER=0  NO ERROR
C	         IER=1  N IS NEGATIVE
C	         IER=2  X IS ZERO OR NEGATIVE
C	         IER=3  X .GT. 170, MACHINE RANGE EXCEEDED
C	         IER=4  BK .GT. 10**70
C
C	   REMARKS
C	      N MUST BE GREATER THAN OR EQUAL TO ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      COMPUTES ZERO ORDER AND FIRST ORDER BESSEL FUNCTIONS USING
C	      SERIES APPROXIMATIONS AND THEN COMPUTES N TH ORDER FUNCTION
C	      USING RECURRENCE RELATION.
C	      RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE
C	      AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS
C	      TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED
C	      FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON,
C	      'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE
C	      UNIVERSITY PRESS, 1958, P. 62
C
C	..................................................................
C
	SUBROUTINE BESK(X,N,BK,IER)
	DIMENSION T(12)
	BK=.0
	IF(N)10,11,11
10	IER=1
	RETURN
11	IF(X)12,12,20
12	IER=2
	RETURN
20	IF(X-170.0)22,22,21
21	IER=3
	RETURN
22	IER=0
	IF(X-1.)36,36,25
25	A=EXP(-X)
	B=1./X
	C=SQRT(B)
	T(1)=B
	DO 26 L=2,12
26	T(L)=T(L-1)*B
	IF(N-1)27,29,27
C
C	COMPUTE KO USING POLYNOMIAL APPROXIMATION
C
27	G0=A*(1.2533141-.1566642*T(1)+.08811128*T(2)-.09139095*T(3)
     2+.1344596*T(4)-.2299850*T(5)+.3792410*T(6)-.5247277*T(7)
     3+.5575368*T(8)-.4262633*T(9)+.2184518*T(10)-.06680977*T(11)
     4+.009189383*T(12))*C
	IF(N)20,28,29
28	BK=G0
	RETURN
C
C	COMPUTE K1 USING POLYNOMIAL APPROXIMATION
C
29	G1=A*(1.2533141+.4699927*T(1)-.1468583*T(2)+.1280427*T(3)
     2-.1736432*T(4)+.2847618*T(5)-.4594342*T(6)+.6283381*T(7)
     3-.6632295*T(8)+.5050239*T(9)-.2581304*T(10)+.07880001*T(11)
     4-.01082418*T(12))*C
	IF(N-1)20,30,31
30	BK=G1
	RETURN
C
C	FROM KO,K1 COMPUTE KN USING RECURRENCE RELATION
C
31	DO 35 J=2,N
	GJ=2.*(FLOAT(J)-1.)*G1/X+G0
	IF(GJ-1.7E33)33,33,32
32	IER=4
	GO TO 34
33	G0=G1
35	G1=GJ
34	BK=GJ
	RETURN
36	B=X/2.
	A=.5772157+ALOG(B)
	C=B*B
	IF(N-1)37,43,37
C
C	COMPUTE KO USING SERIES EXPANSION
C
37	G0=-A
	X2J=1.
	FACT=1.
	HJ=.0
	DO 40 J=1,6
	RJ=1./FLOAT(J)
	X2J=X2J*C
	FACT=FACT*RJ*RJ
	HJ=HJ+RJ
40	G0=G0+X2J*FACT*(HJ-A)
	IF(N)43,42,43
42	BK=G0
	RETURN
C
C	COMPUTE K1 USING SERIES EXPANSION
C
43	X2J=B
	FACT=1.
	HJ=1.
	G1=1./X+X2J*(.5+A-HJ)
	DO 50 J=2,8
	X2J=X2J*C
	RJ=1./FLOAT(J)
	FACT=FACT*RJ*RJ
	HJ=HJ+RJ
50	G1=G1+X2J*FACT*(.5+(A-HJ)*FLOAT(J))
	IF(N-1)31,52,31
52	BK=G1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BESY
C
C	   PURPOSE
C	      COMPUTE THE Y BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER
C
C	   USAGE
C	      CALL BESY(X,N,BY,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X  -THE ARGUMENT OF THE Y BESSEL FUNCTION DESIRED
C	      N  -THE ORDER OF THE Y BESSEL FUNCTION DESIRED
C	      BY -THE RESULTANT Y BESSEL FUNCTION
C	      IER-RESULTANT ERROR CODE WHERE
C	         IER=0  NO ERROR
C	         IER=1  N IS NEGATIVE
C	         IER=2  X IS NEGATIVE OR ZERO
C	         IER=3  BY HAS EXCEEDED MAGNITUDE OF 10**70
C
C	   REMARKS
C	      VERY SMALL VALUES OF X MAY CAUSE THE RANGE OF THE LIBRARY
C	      FUNCTION ALOG TO BE EXCEEDED
C	      X MUST BE GREATER THAN ZERO
C	      N MUST BE GREATER THAN OR EQUAL TO ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE
C	      AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS
C	      TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED
C	      FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON,
C	      'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE
C	      UNIVERSITY PRESS, 1958, P. 62
C
C	..................................................................
C
	SUBROUTINE BESY(X,N,BY,IER)
C
C	CHECK FOR ERRORS IN N AND X
C
	IF(N)180,10,10
10	IER=0
	IF(X)190,190,20
C
C	BRANCH IF X LESS THAN OR EQUAL 4
C
20	IF(X-4.0)40,40,30
C
C	  COMPUTE Y0 AND Y1 FOR X GREATER THAN 4
C
30	T1=4.0/X
	T2=T1*T1
	P0=((((-.0000037043*T2+.0000173565)*T2-.0000487613)*T2
     1  +.00017343)*T2-.001753062)*T2+.3989423
	Q0=((((.0000032312*T2-.0000142078)*T2+.0000342468)*T2
     1  -.0000869791)*T2+.0004564324)*T2-.01246694
	P1=((((.0000042414*T2-.0000200920)*T2+.0000580759)*T2
     1  -.000223203)*T2+.002921826)*T2+.3989423
	Q1=((((-.0000036594*T2+.00001622)*T2-.0000398708)*T2
     1  +.0001064741)*T2-.0006390400)*T2+.03740084
	A=2.0/SQRT(X)
	B=A*T1
	C=X-.7853982
	Y0=A*P0*SIN(C)+B*Q0*COS(C)
	Y1=-A*P1*COS(C)+B*Q1*SIN(C)
	GO TO 90
C
C	  COMPUTE Y0 AND Y1 FOR X LESS THAN OR EQUAL TO 4
C
40	XX=X/2.
	X2=XX*XX
	T=ALOG(XX)+.5772157
	SUM=0.
	TERM=T
	Y0=T
	DO 70 L=1,15
	IF(L-1)50,60,50
50	SUM=SUM+1./FLOAT(L-1)
60	FL=L
	TS=T-SUM
	TERM=(TERM*(-X2)/FL**2)*(1.-1./(FL*TS))
70	Y0=Y0+TERM
	TERM = XX*(T-.5)
	SUM=0.
	Y1=TERM
	DO 80 L=2,16
	SUM=SUM+1./FLOAT(L-1)
	FL=L
	FL1=FL-1.
	TS=T-SUM
	TERM=(TERM*(-X2)/(FL1*FL))*((TS-.5/FL)/(TS+.5/FL1))
80	Y1=Y1+TERM
	PI2=.6366198
	Y0=PI2*Y0
	Y1=-PI2/X+PI2*Y1
C
C	CHECK IF ONLY Y0 OR Y1 IS DESIRED
C
90	IF(N-1)100,100,130
C
C	RETURN EITHER Y0 OR Y1 AS REQUIRED
C
100	IF(N)110,120,110
110	BY=Y1
	GO TO 170
120	BY=Y0
	GO TO 170
C
CP	ERFORM RECURRENCE OPERATIONS TO FIND YN(X)
C
130	YA=Y0
	YB=Y1
	K=1
140	T=FLOAT(2*K)/X
	YC=T*YB-YA
	IF(ABS(YC)-1.7E33)145,145,141
141	IER=3
	RETURN
145	K=K+1
	IF(K-N)150,160,150
150	YA=YB
	YB=YC
	GO TO 140
160	BY=YC
170	RETURN
180	IER=1
	RETURN
190	IER=2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BISER
C
C	   PURPOSE
C	      TO COMPUTE THE BISERIAL CORRELATION COEFFICIENT BETWEEN TWO
C	      CONTINUOUS VARIABLES WHEN ONE OF THEM HAS BEEN ARTIFICIALLY
C	      DICHOTOMIZED.
C
C	   USAGE
C	      CALL BISER (N,A,B,HI,ANS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      N   - NUMBER OF OBSERVATIONS
C	      A   - INPUT VECTOR OF LENGTH N CONTAINING THE CONTINUOUS
C	            VARIABLE
C	      B   - INPUT VECTOR OF LENGTH N CONTAINING THE DICHOTOMIZED
C	            VARIABLE
C	      HI  - INPUT - NUMERICAL CODE TO INDICATE THE HIGHER CATEGORY
C	            OF THE DICHOTOMIZED VARIABLE.  ANY VALUE IN VECTOR B
C	            EQUAL TO OR GREATER THAN HI WILL BE CLASSIFIED INTO
C	            THE HIGHER CATEGORY.
C	      ANS - OUTPUT VECTOR OF LENGTH 8 CONTAINING THE FOLLOWING
C	            ANS(1) - MEAN OF VARIABLE A
C	            ANS(2) - STANDARD DEVIATION OF VARIABLE A
C	            ANS(3) - PROPORTION OF THE CASES IN THE HIGHER
C	                     CATEGORY OF VARIABLE B
C	            ANS(4) - PROPORTION OF THE CASES IN THE LOWER
C	                     CATEGORY OF VARIABLE B
C	            ANS(5) - MEAN OF VARIABLE A FOR THOSE CASES FALLING
C	                     INTO THE HIGHER CATEGORY OF VARIABLE B
C	            ANS(6) - MEAN OF VARIABLE A FOR THOSE CASES FALLING
C	                     INTO THE LOWER CATEGORY OF VARIABLE B
C	            ANS(7) - BISERIAL CORRELATION COEFFICIENT
C	            ANS(8) - STANDARD ERROR OF BISERIAL CORRELATION
C	                     COEFFICIENT
C	      IER -  1, IF NO CASES ARE IN THE LOWER CATEGORY OF VARIABLE
C	            B.
C	            -1, IF ALL CASES ARE IN THE LOWER CATEGORY OF
C	            VARIABLE B.
C	            0, OTHERWISE.
C	            IF IER IS NON-ZERO, ANS(I)=10**75,I=5,...,8.
C
C	   REMARKS
C	      THE VALUES OF THE DICHOTOMIZED VARIABLE, B, MUST BE IN
C	      NUMERIC FORM.  THEY CANNOR BE SPECIFIED BY MEANS OF
C	      ALPHABETIC OR SPECIAL CHARACTERS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NDTRI
C
C	   METHOD
C	      REFER TO P. HORST, 'PSYCHOLOGICAL MEASUREMENT AND
C	      PREDICTION', P.95-96 (WADSWORTH, 1966).
C
C	..................................................................
C
	SUBROUTINE BISER (N,A,B,HI,ANS,IER)
C
	DIMENSION A(1),B(1),ANS(1)
C
C	   COMPUTE MEAN AND STANDARD DEVIATION OF VARIABLE A
C
	IER=0
	SUM=0.0
	SUM2=0.0
	DO 10 I=1,N
	SUM=SUM+A(I)
10	SUM2=SUM2+A(I)*A(I)
	FN=N
	ANS(1)=SUM/FN
	ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0)
	ANS(2)= SQRT(ANS(2))
C
C	   FIND PROPORTIONS OF CASES IN THE HIGHER AND LOWER CATEGORIES
C
	P=0.0
	SUM=0.0
	SUM2=0.0
	DO 30 I=1,N
	IF(B(I)-HI) 20, 25, 25
20	SUM2=SUM2+A(I)
	GO TO 30
25	P=P+1.0
	SUM=SUM+A(I)
30	CONTINUE
	ANS(4)=1.0
	ANS(3)=0.0
	Q=FN-P
	IF (P) 35,35,40
35	IER=-1
	GO TO 50
40	ANS(5)=SUM/P
	IF (Q) 45,45,60
45	IER=1
	ANS(4)=0.0
	ANS(3)=1.0
50	DO 55 I=5,8
55	ANS(I)=1.7E38                                                             0
	GO TO 65
60	ANS(6)=SUM2/Q
	P=P/FN
	Q=1.0-P
C
C	   FIND ORDINATE OF THE NORMAL DISTRIBUTION CURVE AT THE POINT OF
C	   DIVISION BETWEEN SEGMENTS CONTAINING P AND Q PROPORTIONS
C
	CALL NDTRI (Q,X,Y,ER)
C
C	   COMPUTE THE BISERIAL COEFFICIENT OF CORRELATION
C
	R=((ANS(5)-ANS(1))/ANS(2))*(P/Y)
C
C	   COMPUTE THE STANDARD ERROR OF R
C
	ANS(8)=( SQRT(P*Q)/Y-R*R)/SQRT(FN)
C
C	   STORE RESULTS
C
	ANS(3)=P
	ANS(4)=Q
	ANS(7)=R
C
65	RETURN
	END
C
C	..................................................................
C
C	   USER-SUPPLIED SPECIAL SUBROUTINE - BOOL
C
C	   THIS SPECIAL SUBROUTINE ILLUSTRATES AN EXTERNAL SUBROUTINE
C	   CALLED BY SUBROUTINE SUBST.
C
C	   IF DIFFERENT PROPOSITIONS ARE USED FOR DIFFERENT PROBLEMS IN
C	   THE SAME RUN, DIFFERENT SUBROUTINES WITH APPROPRIATE PROPOSI-
C	   TIONS MUST BE COMPILED UNDER DIFFERENT NAMES.  IF SO, THESE
C	   SUBROUTINE NAMES MUST BE DEFINED BY AN EXTERNAL STATEMENT
C	   APPEARING IN THE MAIN PROGRAM WHICH CALLS SUBST.  THEN, FOR
C	   EACH PROBLEM, SUBST IS CALLED WITH A PROPER SUBROUTINE NAME
C	   IN ITS ARGUMENT LIST.
C
C	..................................................................
C
	SUBROUTINE BOOL(R,T)
	DIMENSION R(1)
C
	T=R(1)*R(2)
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE BOUND
C
C	   PURPOSE
C	      SELECT FROM A SET (OR A SUBSET) OF OBSERVATIONS THE NUMBER
C	      OF OBSERVATIONS UNDER, BETWEEN AND OVER TWO GIVEN BOUNDS
C	      FOR EACH VARIABLE
C
C	   USAGE
C	      CALL BOUND (A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - OBSERVATION MATRIX, NO BY NV
C	      S     - VECTOR INDICATING SUBSET OF A. ONLY THOSE
C	              OBSERVATIONS WITH A NON-ZERO S(J) ARE CONSIDERED.
C	              VECTOR LENGTH IS NO.
C	      BLO   - INPUT VECTOR OF LOWER BOUNDS ON ALL VARIABLES.
C	              VECTOR LENGTH IS NV.
C	      BHI   - INPUT VECTOR OF UPPER BOUNDS ON ALL VARIABLES.
C	              VECTOR LENGTH IS NV.
C	      UNDER - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
C	              OF OBSERVATIONS UNDER LOWER BOUNDS. VECTOR LENGTH
C	              IS NV.
C	      BETW  - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
C	              OF OBSERVATIONS EQUAL TO OR BETWEEN LOWER AND UPPER
C	              BOUNDS. VECTOR LENGTH IS NV.
C	      OVER  - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER
C	              OF OBSERVATIONS OVER UPPER BOUNDS. VECTOR LENGTH
C	              IS NV.
C	      NO    - NUMBER OF OBSERVATIONS
C	      NV    - NUMBER OF VARIABLES FOR EACH OBSERVATION
C	      IER   - ZERO, IF NO ERROR.
C	            - 1, IF LOWER BOUND IS GREATER THAN THE UPPER BOUND
C	              FOR SOME VARIABLE
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EACH ROW (OBSERVATION) OF MATRIX A WITH CORRESPONDING
C	      NON-ZERO ELEMENT IN S VECTOR IS TESTED. OBSERVATIONS ARE
C	      COMPARED WITH SPECIFIED LOWER AND UPPER VARIABLE BOUNDS AND
C	      A COUNT IS KEPT IN VECTORS UNDER, BETWEEN, AND OVER.
C
C	..................................................................
C
	SUBROUTINE BOUND(A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV)
	DIMENSION A(1),S(1),BLO(1),BHI(1),UNDER(1),BETW(1),OVER(1)
C
C	   CLEAR OUTPUT VECTORS.
C
	IER=0
	DO 10 I=1,NV
	IF (BLO(I)-BHI(I)) 10,10,11
11	IER=1
	GO TO 12
10	CONTINUE
	DO 1 K=1,NV
	UNDER(K)=0.0
	BETW(K)=0.0
1	OVER(K)=0.0
C
C	   TEST SUBSET VECTOR
C
	DO 8 J=1,NO
	IJ=J-NO
	IF(S(J)) 2,8,2
C
C	   COMPARE OBSERVATIONS WITH BOUNDS
C
2	DO 7 I=1,NV
	IJ=IJ+NO
	IF(A(IJ)-BLO(I)) 5,3,3
3	IF(A(IJ)-BHI(I)) 4,4,6
C
C	  COUNT
C
4	BETW(I)=BETW(I)+1.0
	GO TO 7
5	UNDER(I)=UNDER(I)+1.0
	GO TO 7
6	OVER(I)=OVER(I)+1.0
7	CONTINUE
8	CONTINUE
12	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CADD
C
C	   PURPOSE
C	      ADD COLUMN OF ONE MATRIX TO COLUMN OF ANOTHER MATRIX
C
C	   USAGE
C	      CALL CADD(A,ICA,R,ICR,N,M,MS,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - NAME OF INPUT MATRIX
C	      ICA - COLUMN IN MATRIX A TO BE ADDED TO COLUMN ICR OF R
C	      R   - NAME OF OUTPUT MATRIX
C	      ICR - COLUMN IN MATRIX R WHERE SUMMATION IS DEVELOPED
C	      N   - NUMBER OF ROWS IN A AND R
C	      M   - NUMBER OF COLUMNS IN A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      L   - NUMBER OF COLUMNS IN R
C
C	   REMARKS
C	      MATRIX R MUST BE A GENERAL MATRIX
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A UNLESS
C	      A IS GENERAL
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      EACH ELEMENT OF COLUMN ICA OF MATRIX A IS ADDED TO
C	      CORRESPONDING ELEMENT OF COLUMN ICR OF MATRIX R
C
C	..................................................................
C
	SUBROUTINE CADD(A,ICA,R,ICR,N,M,MS,L)
	DIMENSION A(1),R(1)
C
	IR=N*(ICR-1)
	DO 2 I=1,N
	IR=IR+1
C
C	   LOCATE INPUT ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,ICA,IA,N,M,MS)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IA) 1,2,1
C
C	   ADD ELEMENTS
C
1	R(IR)=R(IR)+A(IA)
2	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CANOR
C
C	   PURPOSE
C	      COMPUTE THE CANONICAL CORRELATIONS BETWEEN TWO SETS OF
C	      VARIABLES.  CANOR IS NORMALLY PRECEDED BY A CALL TO SUBROU-
C	      TINE CORRE.
C
C	   USAGE
C	      CALL CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR,
C	                  COEFL,R)
C
C	   DESCRIPTION OF PARAMETERS
C	      N     - NUMBER OF OBSERVATIONS
C	      MP    - NUMBER OF LEFT HAND VARIABLES
C	      MQ    - NUMBER OF RIGHT HAND VARIABLES
C	      RR    - INPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
C	              SYMMETRIC MATRIX OF M X M, WHERE M = MP + MQ)
C	              CONTAINING CORRELATION COEFFICIENTS.  (STORAGE MODE
C	              OF 1)
C	      ROOTS - OUTPUT VECTOR OF LENGTH MQ CONTAINING EIGENVALUES
C	              COMPUTED IN THE NROOT SUBROUTINE.
C	      WLAM  - OUTPUT VECTOR OF LENGTH MQ CONTAINING LAMBDA.
C	      CANR  - OUTPUT VECTOR OF LENGTH MQ CONTAINING CANONICAL
C	              CORRELATIONS.
C	      CHISQ - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE
C	              VALUES OF CHI-SQUARES.
C	      NDF   - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE DEGREES
C	              OF FREEDOM ASSOCIATED WITH CHI-SQUARES.
C	      COEFR - OUTPUT MATRIX (MQ X MQ) CONTAINING MQ SETS OF
C	              RIGHT HAND COEFFICIENTS COLUMNWISE.
C	      COEFL - OUTPUT MATRIX (MP X MQ) CONTAINING MQ SETS OF
C	              LEFT HAND COEFFICIENTS COLUMNWISE.
C	      R     - WORK MATRIX (M X M)
C
C	   REMARKS
C	      THE NUMBER OF LEFT HAND VARIABLES (MP) SHOULD BE GREATER
C	      THAN OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES (MQ).
C	      THE VALUES OF CANONICAL CORRELATION, LAMBDA, CHI-SQUARE,
C	      DEGREES OF FREEDOM, AND CANONICAL COEFFICIENTS ARE COMPUTED
C	      ONLY FOR THOSE EIGENVALUES IN ROOTS WHICH ARE GREATER THAN
C	      ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      MINV
C	      NROOT  (WHICH, IN TURN, CALLS THE SUBROUTINE EIGEN.)
C
C	   METHOD
C	      REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-
C	      CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,
C	      1962, CHAPTER 3.
C
C	..................................................................
C
	SUBROUTINE CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR,
     1                  COEFL,R)
	DIMENSION RR(1),ROOTS(1),WLAM(1),CANR(1),CHISQ(1),NDF(1),COEFR(1),
     1          COEFL(1),R(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION RR,ROOTS,WLAM,CANR,CHISQ,COEFR,COEFL,R,DET,SUM
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENT
C	   165 MUST BE CHANGED TO DSQRT.  ALOG IN STATEMENT 175 MUST BE
C	   CHANGED TO DLOG.
C
C	   ...............................................................
C
C	PARTITION INTERCORRELATIONS AMONG LEFT HAND VARIABLES, BETWEEN
C	LEFT AND RIGHT HAND VARIABLES, AND AMONG RIGHT HAND VARIABLES.
C
	M=MP+MQ
	N1=0
	DO 105 I=1,M
	DO 105 J=1,M
	IF(I-J) 102, 103, 103
102	L=I+(J*J-J)/2
	GO TO 104
103	L=J+(I*I-I)/2
104	N1=N1+1
105	R(N1)=RR(L)
	L=MP
	DO 108 J=2,MP
	N1=M*(J-1)
	DO 108 I=1,MP
	L=L+1
	N1=N1+1
108	R(L)=R(N1)
	N2=MP+1
	L=0
	DO 110 J=N2,M
	N1=M*(J-1)
	DO 110 I=1,MP
	L=L+1
	N1=N1+1
110	COEFL(L)=R(N1)
	L=0
	DO 120 J=N2,M
	N1=M*(J-1)+MP
	DO 120 I=N2,M
	L=L+1
	N1=N1+1
120	COEFR(L)=R(N1)
C
C	SOLVE THE CANONICAL EQUATION
C
	L=MP*MP+1
	K=L+MP
	CALL MINV (R,MP,DET,R(L),R(K))
C
C	   CALCULATE T = INVERSE OF R11 * R12
C
	DO 140 I=1,MP
	N2=0
	DO 130 J=1,MQ
	N1=I-MP
	ROOTS(J)=0.0
	DO 130 K=1,MP
	N1=N1+MP
	N2=N2+1
130	ROOTS(J)=ROOTS(J)+R(N1)*COEFL(N2)
	L=I-MP
	DO 140 J=1,MQ
	L=L+MP
140	R(L)=ROOTS(J)
C
C	   CALCULATE A = R21 * T
C
	L=MP*MQ
	N3=L+1
	DO 160 J=1,MQ
	N1=0
	DO 160 I=1,MQ
	N2=MP*(J-1)
	SUM=0.0
	DO 150 K=1,MP
	N1=N1+1
	N2=N2+1
150	SUM=SUM+COEFL(N1)*R(N2)
	L=L+1
160	R(L)=SUM
C
C	   CALCULATE EIGENVALUES WITH ASSOCIATED EIGENVECTORS OF THE
C	   INVERSE OF R22 * A
C
	L=L+1
	CALL NROOT (MQ,R(N3),COEFR,ROOTS,R(L))
C
C	FOR EACH VALUE OF I = 1, 2, ..., MQ, CALCULATE THE FOLLOWING
C	STATISTICS
C
	DO 210 I=1,MQ
C
C	   TEST WHETHER EIGENVALUE IS GREATER THAN ZERO
C
	IF(ROOTS(I)) 220, 220, 165
C
C	   CANONICAL CORRELATION
C
165	CANR(I)= SQRT(ROOTS(I))
C
C	   CHI-SQUARE
C
	WLAM(I)=1.0
	DO 170 J=I,MQ
170	WLAM(I)=WLAM(I)*(1.0-ROOTS(J))
	FN=N
	FMP=MP
	FMQ=MQ
175	CHISQ(I)=-(FN-0.5*(FMP+FMQ+1.0))*ALOG(WLAM(I))
C
C	   DEGREES OF FREEDOM FOR CHI-SQUARE
C
	N1=I-1
	NDF(I)=(MP-N1)*(MQ-N1)
C
C	   I-TH SET OF RIGHT HAND COEFFICIENTS
C
	N1=MQ*(I-1)
	N2=MQ*(I-1)+L-1
	DO 180 J=1,MQ
	N1=N1+1
	N2=N2+1
180	COEFR(N1)=R(N2)
C
C	   I-TH SET OF LEFT HAND COEFFICIENTS
C
	DO 200 J=1,MP
	N1=J-MP
	N2=MQ*(I-1)
	K=MP*(I-1)+J
	COEFL(K)=0.0
	DO 190 JJ=1,MQ
	N1=N1+MP
	N2=N2+1
190	COEFL(K)=COEFL(K)+R(N1)*COEFR(N2)
200	COEFL(K)=COEFL(K)/CANR(I)
210	CONTINUE
220	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CCPY
C
C	   PURPOSE
C	      COPY SPECIFIED COLUMN OF A MATRIX INTO A VECTOR
C
C	   USAGE
C	      CALL CCPY(A,L,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      L - COLUMN OF A TO BE MOVED TO R
C	      R - NAME OF OUTPUT VECTOR OF LENGTH N
C	      N - NUMBER OR ROWS IN A
C	      M - NUMBER OF COLUMNS IN A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      ELEMENTS OF COLUMN L ARE MOVED TO CORRESPONDING POSITIONS
C	      OF VECTOR R
C
C	..................................................................
C
	SUBROUTINE CCPY(A,L,R,N,M,MS)
	DIMENSION A(1),R(1)
C
	DO 3 I=1,N
C
C	   LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,L,IL,N,M,MS)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IL) 1,2,1
C
C	   MOVE ELEMENT TO R
C
1	R(I)=A(IL)
	GO TO 3
2	R(I)=0.0
3	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CCUT
C
C	   PURPOSE
C	      PARTITION A MATRIX BETWEEN SPECIFIED COLUMNS TO FORM TWO
C	      RESULTANT MATRICES
C
C	   USAGE
C	      CALL CCUT (A,L,R,S,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      L - COLUMN OF A TO THE LEFT OF WHICH PARTITIONING TAKES
C	          PLACE
C	      R - NAME OF MATRIX TO BE FORMED FROM LEFT PORTION OF A
C	      S - NAME OF MATRIX TO BE FORMED FROM RIGHT PORTION OF A
C	      N - NUMBER OF ROWS IN A
C	      M - NUMBER OF COLUMNS IN A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX A
C	      MATRIX S CANNOT BE IN SAME LOCATION AS MATRIX A
C	      MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX S
C	      MATRIX R AND MATRIX S ARE ALWAYS GENERAL MATRICES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      ELEMENTS OF MATRIX A TO THE LEFT OF COLUMN L ARE MOVED TO
C	      FORM MATRIX R OF N ROWS AND L-1 COLUMNS. ELEMENTS OF
C	      MATRIX A IN COLUMN L AND TO THE RIGHT OF L ARE MOVED TO FORM
C	      MATRIX S OF N ROWS AND M-L+1 COLUMNS.
C
C	..................................................................
C
	SUBROUTINE CCUT(A,L,R,S,N,M,MS)
	DIMENSION A(1),R(1),S(1)
C
	IR=0
	IS=0
	DO 70 J=1,M
	DO 70 I=1,N
C
C	   FIND LOCATION IN OUTPUT MATRIX AND SET TO ZERO
C
	IF(J-L) 20,10,10
10	IS=IS+1
	S(IS)=0.0
	GO TO 30
20	IR=IR+1
	R(IR)=0.0
C
C	   LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
30	CALL LOC(I,J,IJ,N,M,MS)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IJ) 40,70,40
C
C	   DETERMINE WHETHER RIGHT OR LEFT OF L
C
40	IF(J-L) 60,50,50
50	S(IS)=A(IJ)
	GO TO 70
60	R(IR)=A(IJ)
70	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CDTR
C
C	   PURPOSE
C	      COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U,
C	      DISTRIBUTED ACCORDING TO THE CHI-SQUARE DISTRIBUTION WITH G
C	      DEGREES OF FREEDOM, IS LESS THAN OR EQUAL TO X.  F(G,X), THE
C	      ORDINATE OF THE CHI-SQUARE DENSITY AT X, IS ALSO COMPUTED.
C
C	   USAGE
C	      CALL CDTR(X,G,P,D,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X   - INPUT SCALAR FOR WHICH P(X) IS COMPUTED.
C	      G   - NUMBER OF DEGREES OF FREEDOM OF THE CHI-SQUARE
C	            DISTRIBUTION.  G IS A CONTINUOUS PARAMETER.
C	      P   - OUTPUT PROBABILITY.
C	      D   - OUTPUT DENSITY.
C	      IER - RESULTANT ERROR CODE WHERE
C	          IER= 0 --- NO ERROR
C	          IER=-1 --- AN INPUT PARAMETER IS INVALID.  X IS LESS
C	                     THAN 0.0, OR G IS LESS THAN 0.5 OR GREATER
C	                     THAN 2*10**(+5).  P AND D ARE SET TO -1.7E38.        0
C	          IER=+1 --- INVALID OUTPUT.  P IS LESS THAN ZERO OR
C	                     GREATER THAN ONE, OR SERIES FOR T1 (SEE
C	                     MATHEMATICAL DESCRIPTION) HAS FAILED TO
C	                     CONVERGE.  P IS SET TO 1.7E38.                       0
C
C	   REMARKS
C	      SEE MATHEMATICAL DESCRIPTION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DLGAM
C	      NDTR
C
C	   METHOD
C	      REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL
C	      DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE,
C	      IBM RESEARCH REPORT RC-1094, 1963.
C
C	..................................................................
C
	SUBROUTINE CDTR(X,G,P,D,IER)
	DOUBLE PRECISION XX,DLXX,X2,DLX2,GG,G2,DLT3,THETA,THP1,
     1GLG2,DD,T11,SER,CC,XI,FAC,TLOG,TERM,GTH,A2,A,B,C,DT2,DT3,THPI
C
C	   TEST FOR VALID INPUT DATA
C
	IF(G-(.5-1.E-5)) 590,10,10
10	IF(G-2.E+5) 20,20,590
20	IF(X) 590,30,30
C
C	   TEST FOR X NEAR 0.0
C
30	IF(X-1.E-8) 40,40,80
40	P=0.0
	IF(G-2.) 50,60,70
50	D=1.7E38                                                                  0
	GO TO 610
60	D=0.5
	GO TO 610
70	D=0.0
	GO TO 610
C
C	   TEST FOR X GREATER THAN 1.E+6
C
80	IF(X-1.E+6) 100,100,90
90	D=0.0
	P=1.0
	GO TO 610
C
C	   SET PROGRAM PARAMETERS
C
100	XX=DBLE(X)
	DLXX=DLOG(XX)
	X2=XX/2.D0
	DLX2=DLOG(X2)
	GG=DBLE(G)
	G2=GG/2.D0
C
C	   COMPUTE ORDINATE
C
	CALL DLGAM(G2,GLG2,IOK)
	DD=(G2-1.D0)*DLXX-X2-G2*.6931471805599453 -GLG2
	IF(DD-1.68D02) 110,110,120
110	IF(DD+1.68D02) 130,130,140
120	D=1.7E38                                                                  0
	GO TO 150
130	D=0.0
	GO TO 150
140	DD=DEXP(DD)
	D=SNGL(DD)
C
C	   TEST FOR G GREATER THAN 1000.0
C	   TEST FOR X GREATER THAN 2000.0
C
150	IF(G-1000.) 160,160,180
160	IF(X-2000.) 190,190,170
170	P=1.0
	GO TO 610
180	A=DLOG(XX/GG)/3.D0
	A=DEXP(A)
	B=2.D0/(9.D0*GG)
	C=(A-1.D0+B)/DSQRT(B)
	SC=SNGL(C)
	CALL NDTR(SC,P,DUMMY)
	GO TO 490
C
C	   COMPUTE THETA
C
190	K= IDINT(G2)
	THETA=G2-DFLOAT(K)
	IF(THETA-1.D-8) 200,200,210
200	THETA=0.D0
210	THP1=THETA+1.D0
C
C	   SELECT METHOD OF COMPUTING T1
C
	IF(THETA) 230,230,220
220	IF(XX-10.D0) 260,260,320
C
C	   COMPUTE T1 FOR THETA EQUALS 0.0
C
230	IF(X2-1.68D02) 250,240,240
240	T1=1.0
	GO TO 400
250	T11=1.D0-DEXP(-X2)
	T1=SNGL(T11)
	GO TO 400
C
C	   COMPUTE T1 FOR THETA GREATER THAN 0.0 AND
C	   X LESS THAN OR EQUAL TO 10.0
C
260	SER=X2*(1.D0/THP1 -X2/(THP1+1.D0))
	J=+1
	CC=DFLOAT(J)
	DO 270 IT1=3,30
	XI=DFLOAT(IT1)
	CALL DLGAM(XI,FAC,IOK)
	TLOG= XI*DLX2-FAC-DLOG(XI+THETA)
	TERM=DEXP(TLOG)
	TERM=DSIGN(TERM,CC)
	SER=SER+TERM
	CC=-CC
	IF(DABS(TERM)-1.D-9) 280,270,270
270	CONTINUE
	GO TO 600
280	IF(SER) 600,600,290
290	CALL DLGAM(THP1,GTH,IOK)
	TLOG=THETA*DLX2+DLOG(SER)-GTH
	IF(TLOG+1.68D02) 300,300,310
300	T1=0.0
	GO TO 400
310	T11=DEXP(TLOG)
	T1=SNGL(T11)
	GO TO 400
C
C	   COMPUTE T1 FOR THETA GREATER THAN 0.0 AND
C	   X GREATER THAN 10.0 AND LESS THAN 2000.0
C
320	A2=0.D0
	DO 340 I=1,25
	XI=DFLOAT(I)
	CALL DLGAM(THP1,GTH,IOK)
	T11=-(13.D0*XX)/XI +THP1*DLOG(13.D0*XX/XI) -GTH-DLOG(XI)
	IF(T11+1.68D02) 340,340,330
330	T11=DEXP(T11)
	A2=A2+T11
340	CONTINUE
	A=1.01282051+THETA/156.D0-XX/312.D0
	B=DABS(A)
	C= -X2+THP1*DLX2+DLOG(B)-GTH-3.951243718581427
	IF(C+1.68D02) 370,370,350
350	IF (A) 360,370,380
360	C=-DEXP(C)
	GO TO 390
370	C=0.D0
	GO TO 390
380	C=DEXP(C)
390	C=A2+C
	T11=1.D0-C
	T1=SNGL(T11)
C
C	   SELECT PROPER EXPRESSION FOR P
C
400	IF(G-2.) 420,410,410
410	IF(G-4.) 450,460,460
C
C	   COMPUTE P FOR G GREATER THAN ZERO AND LESS THAN 2.0
C
420	CALL DLGAM(THP1,GTH,IOK)
	DT2=THETA*DLXX-X2-THP1*.6931471805599453 -GTH
	IF(DT2+1.68D02) 430,430,440
430	P=T1
	GO TO 490
440	DT2=DEXP(DT2)
	T2=SNGL(DT2)
	P=T1+T2+T2
	GO TO 490
C
C	   COMPUTE P FOR G GREATER THAN OR EQUAL TO 2.0
C	   AND LESS THAN 4.0
C
450	P=T1
	GO TO 490
C
C	   COMPUTE P FOR G GREATER THAN OR EQUAL TO 4.0
C	   AND LESS THAN OR EQUAL TO 1000.0
C
460	DT3=0.D0
	DO 480 I3=2,K
	THPI=DFLOAT(I3)+THETA
	CALL DLGAM(THPI,GTH,IOK)
	DLT3=THPI*DLX2-DLXX-X2-GTH
	IF(DLT3+1.68D02) 480,480,470
470	DT3=DT3+DEXP(DLT3)
480	CONTINUE
	T3=SNGL(DT3)
	P=T1-T3-T3
C
C	   SET ERROR INDICATOR
C
490	IF(P) 500,520,520
500	IF(ABS(P)-1.E-7) 510,510,600
510	P=0.0
	GO TO 610
520	IF(1.-P) 530,550,550
530	IF(ABS(1.-P)-1.E-7) 540,540,600
540	P=1.0
	GO TO 610
550	IF(P-1.E-8) 560,560,570
560	P=0.0
	GO TO 610
570	IF((1.0-P)-1.E-8) 580,580,610
580	P=1.0
	GO TO 610
590	IER=-1
	D=-1.7E38                                                                 0
	P=-1.7E38                                                                 0
	GO TO 620
600	IER=+1
	P= 1.7E38                                                                 0
	GO TO 620
610	IER=0
620	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CEL1
C
C	   PURPOSE
C	      CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND
C
C	   USAGE
C	      CALL CEL1(RES,AK,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE
C	      AK    - MODULUS (INPUT)
C	      IER   - RESULTANT ERROR CODE WHERE
C	              IER=0  NO ERROR
C	              IER=1  AK NOT IN RANGE -1 TO +1
C
C	   REMARKS
C	      THE RESULT IS SET TO 1.7E38 IF ABS(AK) GE 1                         0
C	      FOR MODULUS AK AND COMPLEMENTARY MODULUS CK,
C	      EQUATION AK*AK+CK*CK=1.0 IS USED.
C	      AK MUST BE IN THE RANGE -1 TO +1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
C	      OVER T FROM 0 TO INFINITY).
C	      EQUIVALENT ARE THE DEFINITIONS
C	      CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED
C	      OVER T FROM 0 TO PI/2),
C	      CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T
C	      FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
C	      AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
C	      NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE CEL1(RES,AK,IER)
	IER=0
	ARI=2.
	GEO=(0.5-AK)+0.5
	GEO=GEO+GEO*AK
	RES=0.5
	IF(GEO)1,2,4
1	IER=1
2	RES=1.7E38                                                                0
	RETURN
3	GEO=GEO*AARI
4	GEO=SQRT(GEO)
	GEO=GEO+GEO
	AARI=ARI
	ARI=ARI+GEO
	RES=RES+RES
	IF(GEO/AARI-0.9999)3,5,5
5	RES=RES/ARI*6.283185E0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CEL2
C
C	   PURPOSE
C	      COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF
C	      SECOND KIND.
C
C	   USAGE
C	      CALL CEL2(RES,AK,A,B,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE
C	      AK    - MODULUS (INPUT)
C	      A     - CONSTANT TERM IN NUMERATOR
C	      B     - FACTOR OF QUADRATIC TERM IN NUMERATOR
C	      IER   - RESULTANT ERROR CODE WHERE
C	              IER=0  NO ERROR
C	              IER=1  AK NOT IN RANGE -1 TO +1
C
C	   REMARKS
C	      FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.7E38 IF B IS                0
C	      POSITIVE, TO -1.7E38 IF B IS NEGATIVE.                              0
C	      SPECIAL CASES ARE
C	      K(K) OBTAINED WITH A = 1, B = 1
C	      E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS
C	      COMPLEMENTARY MODULUS.
C	      B(K) OBTAINED WITH A = 1, B = 0
C	      D(K) OBTAINED WITH A = 0, B = 1
C	      WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED
C	      COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL
C	      NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS
C	      THE MODULUS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T))
C	      SUMMED OVER T FROM 0 TO INFINITY).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
C	      AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
C	      NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE CEL2(RES,AK,A,B,IER)
	IER=0
	ARI=2.
	GEO=(0.5-AK)+0.5
	GEO=GEO+GEO*AK
	RES=A
	A1=A+B
	B0=B+B
	IF(GEO)1,2,6
1	IER=1
2	IF(B)3,8,4
3	RES=-1.7E38                                                               0
	RETURN
4	RES=1.7E38                                                                0
	RETURN
5	GEO=GEO*AARI
6	GEO=SQRT(GEO)
	GEO=GEO+GEO
	AARI=ARI
	ARI=ARI+GEO
	B0=B0+RES*GEO
	RES=A1
	B0=B0+B0
	A1=B0/ARI+A1
	IF(GEO/AARI-0.9999)5,7,7
7	RES=A1/ARI
	RES=RES+0.5707963E0*RES
8	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CHISQ
C
C	   PURPOSE
C	      COMPUTE CHI-SQUARE FROM A CONTINGENCY TABLE
C
C	   USAGE
C	      CALL CHISQ(A,N,M,CS,NDF,IERR,TR,TC)
C
C	   DESCRIPTION OF PARAMETERS
C	      A    - INPUT MATRIX, N BY M, CONTAINING CONTINGENCY TABLE
C	      N    - NUMBER OF ROWS IN A
C	      M    - NUMBER OF COLUMNS IN A
C	      CS   - CHI-SQUARE (OUTPUT)
C	      NDF  - NUMBER OF DEGREES OF FREEDOM (OUTPUT)
C	      IERR - ERROR CODE (OUTPUT)
C	               0 - NORMAL CASE
C	               1 - EXPECTED VALUE IS LESS THAN 1.0 IN ONE OR
C	                   MORE CELLS
C	               3 - NUMBER OF DEGREES OF FREEDOM IS ZERO
C	      TR   - WORK VECTOR OF LENGTH N
C	      TC   - WORK VECTOR OF LENGTH M
C
C	   REMARKS
C	      IF ONE OR MORE CELLS CONTAIN AN EXPECTED VALUE (I.E.,
C	      THEORETICAL VALUE) LESS THAN 1.0, CHI-SQUARE WILL BE
C	      COMPUTED, BUT ERROR CODE WILL BE SET TO 1.
C	      SEE REFERENCE GIVEN BELOW.
C	      CHI-SQUARE IS SET TO ZERO IF EITHER N OR M IS ONE (ERROR
C	      CODE 3).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 6 AND CHAPTER 8.
C
C	..................................................................
C
	SUBROUTINE CHISQ(A,N,M,CS,NDF,IERR,TR,TC)
	DIMENSION A(1),TR(1),TC(1)
C
	NM=N*M
	IERR=0
	CS=0.0
C
C	   FIND DEGREES OF FREEDOM
C
	NDF=(N-1)*(M-1)
	IF(NDF) 5,5,10
5	IERR=3
	RETURN
C
C	   COMPUTE TOTALS OF ROWS
C
10	DO 90 I=1,N
	TR(I)=0.0
	IJ=I-N
	DO 90 J=1,M
	IJ=IJ+N
90	TR(I)=TR(I)+A(IJ)
C
C	   COMPUTE TOTALS OF COLUMNS
C
	IJ=0
	DO 100 J=1,M
	TC(J)=0.0
	DO 100 I=1,N
	IJ=IJ+1
100	TC(J)=TC(J)+A(IJ)
C
C	   COMPUTE GRAND TOTAL
C
	GT=0.0
	DO 110 I=1,N
110	GT=GT+TR(I)
C
C	   COMPUTE CHI SQUARE FOR 2 BY 2 TABLE (SPECIAL CASE)
C
	IF(NM-4) 130,120,130
120	CS=GT*(ABS(A(1)*A(4)-A(2)*A(3))-GT/2.0)**2  /(TC(1)*TC(2)*TR(1)
     1*TR(2))
	RETURN
C
C	   COMPUTE CHI SQUARE FOR OTHER CONTINGENCY TABLES
C
130	IJ=0
	DO 140 J=1,M
	DO 140 I=1,N
	IJ=IJ+1
	E=TR(I)*TC(J)/GT
	IF(E-1.0) 135, 140, 140
135	IERR=1
140	CS=CS+(A(IJ)-E)*(A(IJ)-E)/E
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CINT
C
C	   PURPOSE
C	      INTERCHANGE TWO COLUMNS OF A MATRIX
C
C	   USAGE
C	      CALL CINT(A,N,LA,LB)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - NAME OF MATRIX
C	      N  - NUMBER OF ROWS IN A
C	      LA - COLUMN TO BE INTERCHANGED WITH COLUMN LB
C	      LB - COLUMN TO BE INTERCHANGED WITH COLUMN LA
C
C	   REMARKS
C	      MATRIX A MUST BE A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EACH ELEMENT OF COLUMN LA IS INTERCHANGED WITH CORRESPONDING
C	      ELEMENT OF COLUMN LB
C
C	..................................................................
C
	SUBROUTINE CINT(A,N,LA,LB)
	DIMENSION A(1)
C
C	   LOCATE STARTING POINT OF BOTH COLUMNS
C
	ILA=N*(LA-1)
	ILB=N*(LB-1)
C
	DO 3 I=1,N
	ILA=ILA+1
	ILB=ILB+1
C
C	   INTERCHANGE ELEMENTS
C
	SAVE=A(ILA)
	A(ILA)=A(ILB)
3	A(ILB)=SAVE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CNP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL CNP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	      Y     - RESULT VALUE
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF CHEBYSHEV POLYNOMIAL
C	      N     - ORDER OF CHEBYSHEV POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      CHEBYSHEV POLYNOMIALS T(N,X)
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
C
C	..................................................................
C
	SUBROUTINE CNP(Y,X,N)
C
	DIMENSION Y(1)
	Y(1)=1.
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	F=X+X
C
	DO 4 I=2,N
4	Y(I+1)=F*Y(I)-Y(I-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CNPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL CNPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	      X     - ARGUMENT VALUE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X).
C
C	..................................................................
C
	SUBROUTINE CNPS(Y,X,C,N)
C
	DIMENSION C(1)
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	IF(N-2)3,4,4
3	Y=C(1)
	RETURN
C
C	   INITIALIZATION
4	ARG=X+X
	H1=0.
	H0=0.
C
	DO 5 I=1,N
	K=N-I
	H2=H1
	H1=H0
5	H0=ARG*H1-H2+C(K+1)
	Y=0.5*(C(1)-H2+H0)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CONVT
C
C	   PURPOSE
C	      CONVERT NUMBERS FROM SINGLE PRECISION TO DOUBLE PRECISION
C	      OR FROM DOUBLE PRECISION TO SINGLE PRECISION.
C
C	   USAGE
C	      CALL CONVT (N,M,MODE,S,D,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      N    - NUMBER OF ROWS IN MATRICES S AND D.
C	      M    - NUMBER OF COLUMNS IN MATRICES S AND D.
C	      MODE - CODE INDICATING TYPE OF CONVERSION
C	               1 - FROM SINGLE PRECISION TO DOUBLE PRECISION
C	               2 - FROM DOUBLE PRECISION TO SINGLE PRECISION
C	      S    - IF MODE=1, THIS MATRIX CONTAINS SINGLE PRECISION
C	             NUMBERS AS INPUT.  IF MODE=2, IT CONTAINS SINGLE
C	             PRECISION NUMBERS AS OUTPUT.  THE SIZE OF MATRIX S
C	             IS N BY M.
C	      D    - IF MODE=1, THIS MATRIX CONTAINS DOUBLE PRECISION
C	             NUMBERS AS OUTPUT.  IF MODE=2, IT CONTAINS DOUBLE
C	             PRECISION NUMBERS AS INPUT.  THE SIZE OF MATRIX D IS
C	             N BY M.
C	      MS   - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX
C	               0 - GENERAL
C	               1 - SYMMETRIC
C	               2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX D CANNOT BE IN THE SAME LOCATION AS MATRIX S.
C	      MATRIX D MUST BE DEFINED BY A DOUBLE PRECISION STATEMENT IN
C	      THE CALLING PROGRAM.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      ACCORDING TO THE TYPE OF CONVERSION INDICATED IN MODE, THIS
C	      SUBROUTINE COPIES NUMBERS FROM MATRIX S TO MATRIX D OR FROM
C	      MATRIX D TO MATRIX S.
C
C	..................................................................
C
	SUBROUTINE CONVT (N,M,MODE,S,D,MS)
	DIMENSION S(1),D(1)
	DOUBLE PRECISION D
C
C	   FIND STORAGE MODE OF MATRIX AND NUMBER OF DATA POINTS
C
	IF(MS-1) 2, 4, 6
2	NM=N*M
	GO TO 8
4	NM=((N+1)*N)/2
	GO TO 8
6	NM=N
C
C	   TEST TYPE OF CONVERSION
C
8	IF(MODE-1) 10, 10, 20
C
C	   SINGLE PRECISION TO DOUBLE PRECISION
C
10	DO 15 L=1,NM
15	D(L)=S(L)
	GO TO 30
C
C	   DOUBLE PRECISION TO SINGLE PRECISION
C
20	DO 25 L=1,NM
25	S(L)=D(L)
C
30	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CORRE
C
C	   PURPOSE
C	      COMPUTE MEANS, STANDARD DEVIATIONS, SUMS OF CROSS-PRODUCTS
C	      OF DEVIATIONS, AND CORRELATION COEFFICIENTS.
C
C	   USAGE
C	      CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T)
C
C	   DESCRIPTION OF PARAMETERS
C	      N     - NUMBER OF OBSERVATIONS. N MUST BE > OR = TO 2.
C	      M     - NUMBER OF VARIABLES. M MUST BE > OR = TO 1.
C	      IO    - OPTION CODE FOR INPUT DATA
C	              0 IF DATA ARE TO BE READ IN FROM INPUT DEVICE IN THE
C	                SPECIAL SUBROUTINE NAMED DATA.  (SEE SUBROUTINES
C	                USED BY THIS SUBROUTINE BELOW.)
C	              1 IF ALL DATA ARE ALREADY IN CORE.
C	      X     - IF IO=0, THE VALUE OF X IS 0.0.
C	              IF IO=1, X IS THE INPUT MATRIX (N BY M) CONTAINING
C	                       DATA.
C	      XBAR  - OUTPUT VECTOR OF LENGTH M CONTAINING MEANS.
C	      STD   - OUTPUT VECTOR OF LENGTH M CONTAINING STANDARD
C	              DEVIATIONS.
C	      RX    - OUTPUT MATRIX (M X M) CONTAINING SUMS OF CROSS-
C	              PRODUCTS OF DEVIATIONS FROM MEANS.
C	      R     - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
C	              SYMMETRIC MATRIX OF M BY M) CONTAINING CORRELATION
C	              COEFFICIENTS.  (STORAGE MODE OF 1)
C	      B     - OUTPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL
C	              OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF
C	              DEVIATIONS FROM MEANS.
C	      D     - WORKING VECTOR OF LENGTH M.
C	      T     - WORKING VECTOR OF LENGTH M.
C
C	   REMARKS
C	      CORRE WILL NOT ACCEPT A CONSTANT VECTOR.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DATA(M,D) - THIS SUBROUTINE MUST BE PROVIDED BY THE USER.
C	                  (1) IF IO=0, THIS SUBROUTINE IS EXPECTED TO
C	                      FURNISH AN OBSERVATION IN VECTOR D FROM AN
C	                      EXTERNAL INPUT DEVICE.
C	                  (2) IF IO=1, THIS SUBROUTINE IS NOT USED BY
C	                      CORRE BUT MUST EXIST IN JOB DECK. IF USER
C	                      HAS NOT SUPPLIED A SUBROUTINE NAMED DATA,
C	                      THE FOLLOWING IS SUGGESTED.
C	                           SUBROUTINE DATA
C	                           RETURN
C	                           END
C
C	   METHOD
C	      PRODUCT-MOMENT CORRELATION COEFFICIENTS ARE COMPUTED.
C
C	..................................................................
C
	SUBROUTINE CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T)
	DIMENSION X(1),XBAR(1),STD(1),RX(1),R(1),B(1),D(1),T(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION XBAR,STD,RX,R,B,T
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
C	   STATEMENT 220 MUST BE CHANGED TO DSQRT AND DABS.
C
C	   ...............................................................
C
C	INITIALIZATION
C
	DO 100 J=1,M
	B(J)=0.0
100	T(J)=0.0
	K=(M*M+M)/2
	DO 102 I=1,K
102	R(I)=0.0
	FN=N
	L=0
C
	IF(IO) 105, 127, 105
C
C	DATA ARE ALREADY IN CORE
C
105	DO 108 J=1,M
	DO 107 I=1,N
	L=L+1
107	T(J)=T(J)+X(L)
	XBAR(J)=T(J)
108	T(J)=T(J)/FN
C
	DO 115 I=1,N
	JK=0
	L=I-N
	DO 110 J=1,M
	L=L+N
	D(J)=X(L)-T(J)
110	B(J)=B(J)+D(J)
	DO 115 J=1,M
	DO 115 K=1,J
	JK=JK+1
115	R(JK)=R(JK)+D(J)*D(K)
	GO TO 205
C
C	READ OBSERVATIONS AND CALCULATE TEMPORARY
C	MEANS FROM THESE DATA IN T(J)
C
127	IF(N-M) 130, 130, 135
130	KK=N
	GO TO 137
135	KK=M
137	DO 140 I=1,KK
	CALL DATA (M,D)
	DO 140 J=1,M
	T(J)=T(J)+D(J)
	L=L+1
140	RX(L)=D(J)
	FKK=KK
	DO 150 J=1,M
	XBAR(J)=T(J)
150	T(J)=T(J)/FKK
C
C	CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C	FROM TEMPORARY MEANS FOR M OBSERVATIONS
C
	L=0
	DO 180 I=1,KK
	JK=0
	DO 170 J=1,M
	L=L+1
170	D(J)=RX(L)-T(J)
	DO 180 J=1,M
	B(J)=B(J)+D(J)
	DO 180 K=1,J
	JK=JK+1
180	R(JK)=R(JK)+D(J)*D(K)
C
	IF(N-KK) 205, 205, 185
C
C	READ THE REST OF OBSERVATIONS ONE AT A TIME, SUM
C	THE OBSERVATION, AND CALCULATE SUMS OF CROSS-
C	PRODUCTS OF DEVIATIONS FROM TEMPORARY MEANS
C
185	KK=N-KK
	DO 200 I=1,KK
	JK=0
	CALL DATA (M,D)
	DO 190 J=1,M
	XBAR(J)=XBAR(J)+D(J)
	D(J)=D(J)-T(J)
190	B(J)=B(J)+D(J)
	DO 200 J=1,M
	DO 200 K=1,J
	JK=JK+1
200	R(JK)=R(JK)+D(J)*D(K)
C
C	CALCULATE MEANS
C
205	JK=0
	DO 210 J=1,M
	XBAR(J)=XBAR(J)/FN
C
C	ADJUST SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C	FROM TEMPORARY MEANS
C
	DO 210 K=1,J
	JK=JK+1
210	R(JK)=R(JK)-B(J)*B(K)/FN
C
C	CALCULATE CORRELATION COEFFICIENTS
C
	JK=0
	DO 220 J=1,M
	JK=JK+J
220	STD(J)= SQRT( ABS(R(JK)))
	DO 230 J=1,M
	DO 230 K=J,M
	JK=J+(K*K-K)/2
	L=M*(J-1)+K
	RX(L)=R(JK)
	L=M*(K-1)+J
	RX(L)=R(JK)
	IF(STD(J)*STD(K)) 225, 222, 225
222	R(JK)=0.0
	GO TO 230
225	R(JK)=R(JK)/(STD(J)*STD(K))
230	CONTINUE
C
C	CALCULATE STANDARD DEVIATIONS
C
	FN=SQRT(FN-1.0)
	DO 240 J=1,M
240	STD(J)=STD(J)/FN
C
C	COPY THE DIAGONAL OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF
C	DEVIATIONS FROM MEANS.
C
	L=-M
	DO 250 I=1,M
	L=L+M+1
250	B(I)=RX(L)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CROSS
C
C	   PURPOSE
C	      TO FIND THE CROSSCOVARIANCES OF SERIES A WITH SERIES B
C	      (WHICH LEADS AND LAGS A).
C
C	   USAGE
C	      CALL CROSS (A,B,N,L,R,S)
C
C	   DESCRIPTION OF PARAMETERS
C	      A    - INPUT VECTOR OF LENGTH N CONTAINING FIRST TIME
C	             SERIES.
C	      B    - INPUT VECTOR OF LENGTH N CONTAINING SECOND TIME
C	             SERIES.
C	      N    - LENGTH OF SERIES A AND B.
C	      L    - CROSSCOVARIANCE IS CALCULATED FOR LAGS AND LEADS OF
C	             0, 1, 2,..., L-1.
C	      R    - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI-
C	             ANCES OF A WITH B, WHERE B LAGS A.
C	      S    - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI-
C	             ANCES OF A WITH B, WHERE B LEADS A.
C
C	   REMARKS
C	      N MUST BE GREATER THAN L.  IF NOT, R(1) AND S(1) ARE SET TO
C	      ZERO AND RETURN IS MADE TO THE CALLING PROGRAM.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT
C	   OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959.
C
C	..................................................................
C
	SUBROUTINE CROSS (A,B,N,L,R,S)
	DIMENSION A(1),B(1),R(1),S(1)
C
C	CALCULATE AVERAGES OF SERIES A AND B
C
	FN=N
	AVERA=0.0
	AVERB=0.0
	IF(N-L)50,50,100
50	R(1)=0.0
	S(1)=0.0
	RETURN
100	DO 110 I=1,N
	AVERA=AVERA+A(I)
110	AVERB=AVERB+B(I)
	AVERA=AVERA/FN
	AVERB=AVERB/FN
C
C	CALCULATE CROSSCOVARIANCES OF SERIES A AND B
C
	DO 130 J=1,L
	NJ=N-J+1
	SUMR=0.0
	SUMS=0.0
	DO 120 I=1,NJ
	IJ=I+J-1
	SUMR=SUMR+(A(I)-AVERA)*(B(IJ)-AVERB)
120	SUMS=SUMS+(A(IJ)-AVERA)*(B(I)-AVERB)
	FNJ=NJ
	R(J)=SUMR/FNJ
130	S(J)=SUMS/FNJ
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CS
C
C	   PURPOSE
C	      COMPUTES THE FRESNEL INTEGRALS.
C
C	   USAGE
C	      CALL CS (C,S,X)
C
C	   DESCRIPTION OF PARAMETERS
C	      C     - THE RESULTANT VALUE C(X).
C	      S     - THE RESULTANT VALUE S(X).
C	      X     - THE ARGUMENT OF FRESNEL INTEGRALS
C	              IF X IS NEGATIVE, THE ABSOLUTE VALUE IS USED.
C
C	   REMARKS
C	      THE ARGUMENT VALUE X REMAINS UNCHANGED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      C(X)=INTEGRAL(COS(T)/SQRT(2*LI*T) SUMMED OVER T FROM 0 TO X)
C	      S(X)=INTEGRAL(SIN(T)/SQRT(I*LI*T) SUMMED OVER T FROM 0 TO X)
C	      EVALUATION
C	      USING DIFFERENT APPROXIMATIONS FOR X LESS THAN 4 AND X
C	      GREATER THAN 4.
C	      REFERENCE
C	      'COMPUTATION OF FRESNEL INTEGRALS' BY BOERSMA,
C	      MATHEMATICAL TABLES AND OTHER AIDS TO COMPUTATION, VOL. 14,
C	      1960, NO. 72, P. 380.
C
C	..................................................................
C
	SUBROUTINE CS(C,S,X)
	Z=ABS(X)
	IF(Z-4.)1,1,2
1	C=SQRT(Z)
	S=Z*C
	Z=(4.-Z)*(4.+Z)
	C=C*((((((5.100785E-11*Z+5.244297E-9)*Z+5.451182E-7)*Z
     1+3.273308E-5)*Z+1.020418E-3)*Z+1.102544E-2)*Z+1.840965E-1)
	S=S*(((((6.677681E-10*Z+5.883158E-8)*Z+5.051141E-6)*Z
     1+2.441816E-4)*Z+6.121320E-3)*Z+8.026490E-2)
	RETURN
2	D=COS(Z)
	S=SIN(Z)
	Z=4./Z
	A=(((((((8.768258E-4*Z-4.169289E-3)*Z+7.970943E-3)*Z-6.792801E-3)
     1*Z-3.095341E-4)*Z+5.972151E-3)*Z-1.606428E-5)*Z-2.493322E-2)*Z
     2-4.444091E-9
	B=((((((-6.633926E-4*Z+3.401409E-3)*Z-7.271690E-3)*Z+7.428246E-3)
     1*Z-4.027145E-4)*Z-9.314910E-3)*Z-1.207998E-6)*Z+1.994711E-1
	Z=SQRT(Z)
	C=0.5+Z*(D*A+S*B)
	S=0.5+Z*(S*A-D*B)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CSP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS
C	      TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL CSP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL
C	      N     - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
C
C	..................................................................
C
	SUBROUTINE CSP(Y,X,N)
C
	DIMENSION Y(1)
C
C	   TEST OF ORDER
	Y(1)=1.
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X+X-1.
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	F=Y(2)+Y(2)
C
	DO 4 I=2,N
4	Y(I+1)=F*Y(I)-Y(I-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CSPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED
C	      CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C
C	      FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL CSPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	      X     - ARGUMENT VALUE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR SHIFTED
C	      CHEBYSHEV POLYNOMIALS
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X).
C
C	..................................................................
C
	SUBROUTINE CSPS(Y,X,C,N)
C
	DIMENSION C(1)
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	IF(N-2)3,4,4
3	Y=C(1)
	RETURN
C
C	   INITIALIZATION
4	ARG=X+X-1.
	ARG=ARG+ARG
	H1=0.
	H0=0.
C
	DO 5 I=1,N
	K=N-I
	H2=H1
	H1=H0
5	H0=ARG*H1-H2+C(K+1)
	Y=0.5*(C(1)-H2+H0)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CSRT
C
C	   PURPOSE
C	      SORT COLUMNS OF A MATRIX
C
C	   USAGE
C	      CALL CSRT(A,B,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX TO BE SORTED
C	      B - NAME OF INPUT VECTOR WHICH CONTAINS SORTING KEY
C	      R - NAME OF SORTED OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A AND R
C	      M - NUMBER OF COLUMNS IN A AND R AND LENGTH OF B
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX R IS ALWAYS A GENERAL MATRIX
C	      M MUST BE GREATER THAN ONE.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C	      CCPY
C
C	   METHOD
C	      COLUMNS OF INPUT MATRIX A ARE SORTED TO FORM OUTPUT MATRIX
C	      R. THE SORTED COLUMN SEQUENCE IS DETERMINED BY THE VALUES OF
C	      ELEMENTS IN ROW VECTOR B. THE LOWEST VALUED ELEMENT IN
C	      B WILL CAUSE THE CORRESPONDING COLUMN OF A TO BE PLACED IN
C	      THE FIRST COLUMN OF R. THE HIGHEST VALUED ELEMENT OF B WILL
C	      CAUSE THE CORRESPONDING ROW OF A TO BE PLACED IN THE LAST
C	      COLUMN OF R. IF DUPLICATE VALUES EXIST IN B, THE
C	      CORRESPONDING COLUMNS OF A ARE MOVED TO R IN THE SAME ORDER
C	      AS IN A.
C
C	..................................................................
C
	SUBROUTINE CSRT(A,B,R,N,M,MS)
	DIMENSION A(1),B(1),R(1)
C
C	   MOVE SORTING KEY VECTOR TO FIRST ROW OF OUTPUT MATRIX
C	   AND BUILD ORIGINAL SEQUENCE LIST IN SECOND ROW
C
	IK=1
	DO 10 J=1,M
	R(IK)=B(J)
	R(IK+1)=J
10	IK=IK+N
C
C	   SORT ELEMENTS IN SORTING KEY VECTOR (ORIGINAL SEQUENCE LIST
C	   IS RESEQUENCED ACCORDINGLY)
C
	L=M+1
20	ISORT=0
	L=L-1
	IP=1
	IQ=N+1
	DO 50 J=2,L
	IF(R(IQ)-R(IP)) 30,40,40
30	ISORT=1
	RSAVE=R(IQ)
	R(IQ)=R(IP)
	R(IP)=RSAVE
	SAVER=R(IQ+1)
	R(IQ+1)=R(IP+1)
	R(IP+1)=SAVER
40	IP=IP+N
	IQ=IQ+N
50	CONTINUE
	IF(ISORT) 20,60,20
C
C	   MOVE COLUMNS FROM MATRIX A TO MATRIX R (NUMBER IN SECOND ROW
C	   OF R REPRESENTS COLUMN NUMBER OF MATRIX A TO BE MOVED)
C
60	IQ=-N
	DO 70 J=1,M
	IQ=IQ+N
C
C	   GET COLUMN NUMBER IN MATRIX A
C
	I2=IQ+2
	IN=R(I2)
C
C	   MOVE COLUMN
C
	IR=IQ+1
	CALL CCPY(A,IN,R(IR),N,M,MS)
70	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CSUM
C
C	   PURPOSE
C	      SUM ELEMENTS OF EACH COLUMN TO FORM ROW VECTOR
C
C	   USAGE
C	      CALL CSUM(A,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      R - NAME OF VECTOR OF LENGTH M
C	      N - NUMBER OF ROWS IN A
C	      M - NUMBER OF COLUMNS IN A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      VECTOR R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      UNLESS A IS GENERAL
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      ELEMENTS ARE SUMMED DOWN EACH COLUMN INTO A CORRESPONDING
C	      ELEMENT OF OUTPUT ROW VECTOR R
C
C	..................................................................
C
	SUBROUTINE CSUM(A,R,N,M,MS)
	DIMENSION A(1),R(1)
C
	DO 3 J=1,M
C
C	   CLEAR OUTPUT LOCATION
C
	R(J)=0.0
C
	DO 3 I=1,N
C
C	   LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,J,IJ,N,M,MS)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IJ) 2,3,2
C
C	   ACCUMULATE IN OUTPUT VECTOR
C
2	R(J)=R(J)+A(IJ)
3	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CTAB
C
C	   PURPOSE
C	      TABULATE COLUMNS OF A MATRIX TO FORM A SUMMARY MATRIX
C
C	   USAGE
C	      CALL CTAB(A,B,R,S,N,M,MS,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      B - NAME OF INPUT VECTOR OF LENGTH M CONTAINING KEY
C	      R - NAME OF OUTPUT MATRIX CONTAINING SUMMARY OF COLUMN DATA.
C	          IT IS INITIALLY SET TO ZERO BY THIS SUBROUTINE.
C	      S - NAME OF OUTPUT VECTOR OF LENGTH L+1 CONTAINING COUNTS
C	      N - NUMBER OF ROWS IN A AND R
C	      M - NUMBER OF COLUMNS IN A
C	      L - NUMBER OF COLUMNS IN R
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R IS ALWAYS A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C	      CADD
C
C	   METHOD
C	      COLUMNS OF DATA IN MATRIX A ARE TABULATED BASED ON THE KEY
C	      CONTAINED IN VECTOR B. THE FLOATING POINT NUMBER IN B(I) IS
C	      TRUNCATED TO FORM J. THE ITH COLUMN OF A IS ADDED TO THE JTH
C	      COLUMN OF MATRIX R AND ONE IS ADDED TO S(J). IF THE VALUE OF
C	      J IS NOT BETWEEN 1 AND L, ONE IS ADDED TO S(L+1)
C	      UPON COMPLETION, THE OUTPUT MATRIX R CONTAINS A SUMMARY OF
C	      COLUMN DATA AS SPECIFIED BY VECTOR B. EACH ELEMENT IN VECTOR
C	      S CONTAINS A COUNT OF THE NUMBER OF COLUMNS OF A USED TO
C	      FORM R. ELEMENT S(L+1) CONTAINS THE NUMBER OF COLUMNS OF A
C	      NOT INCLUDED IN R AS A RESULT OF J BEING LESS THAN ONE OR
C	      GREATER THAN L.
C
C	..................................................................
C
	SUBROUTINE CTAB(A,B,R,S,N,M,MS,L)
	DIMENSION A(1),B(1),R(1),S(1)
C
C	   CLEAR OUTPUT AREAS
C
	CALL LOC(N,L,IT,N,L,0)
	DO 10 IR=1,IT
10	R(IR)=0.0
	DO 20 IS=1,L
20	S(IS)=0.0
	S(L+1)=0.0
C
	DO 60 I=1,M
C
C	   TEST FOR THE KEY OUTSIDE THE RANGE
C
	JR=B(I)
	IF (JR-1) 50,40,30
30	IF (JR-L) 40,40,50
C
C
C	   ADD COLUMN OF A TO COLUMN OF R AND 1 TO COUNT
C
40	CALL CADD (A,I,R,JR,N,M,MS,L)
	S(JR)=S(JR)+1.0
	GO TO 60
C
50	S(L+1)=S(L+1)+1.0
60	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE CTIE
C
C	   PURPOSE
C	      ADJOIN TWO MATRICES WITH SAME ROW DIMENSION TO FORM ONE
C	      RESULTANT MATRIX (SEE METHOD)
C
C	   USAGE
C	      CALL CTIE(A,B,R,N,M,MSA,MSB,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A,B,R
C	      M - NUMBER OF COLUMNS IN A
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSB - SAME AS MSA EXCEPT FOR MATRIX B
C	      L - NUMBER OF COLUMNS IN B
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B
C	      MATRIX R IS ALWAYS A GENERAL MATRIX
C	      MATRIX A MUST HAVE THE SAME NUMBER OF ROWS AS MATRIX B
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      MATRIX B IS ATTACHED TO THE RIGHT OF MATRIX A .
C	      THE RESULTANT MATRIX R CONTAINS N ROWS AND M+L COLUMNS
C
C	..................................................................
C
	SUBROUTINE CTIE(A,B,R,N,M,MSA,MSB,L)
	DIMENSION A(1),B(1),R(1)
C
	MM=M
	IR=0
	MSX=MSA
	DO 6 JJ=1,2
	DO 5 J=1,MM
	DO 5 I=1,N
	IR=IR+1
	R(IR)=0.0
C
C	   LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,J,IJ,N,MM,MSX)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IJ) 2,5,2
C
C	   MOVE ELEMENT TO MATRIX R
C
2	GO TO(3,4),JJ
3	R(IR)=A(IJ)
	GO TO 5
4	R(IR)=B(IJ)
5	CONTINUE
C
C	   REPEAT ABOVE FOR MATRIX B
C
	MSX=MSB
	MM=L
6	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DACFI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL DACFI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
C	               ARGUMENT VALUES OF THE TABLE (POSSIBLY DESTROYED).
C	      VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
C	               FUNCTION VALUES OF THE TABLE (DESTROYED).
C	      Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
C	               VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               UPPER BOUND FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS
C	          DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN
C	          THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME
C	          AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY
C	          ELEMENT BY INTERCHANGING OF TABLE POINTS).
C	          FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO
C	          ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL.
C	          DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS
C	          CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED-
C	      DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406.
C
C	..................................................................
C
	SUBROUTINE DACFI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	DOUBLE PRECISION ARG,VAL,X,Y,Z,P1,P2,P3,Q1,Q2,Q3,AUX,H
	IER=2
	IF(NDIM)20,20,1
1	Y=VAL(1)
	DELT2=0.
	IF(NDIM-1)20,20,2
C
C	PREPARATIONS FOR INTERPOLATION LOOP
2	P2=1.D0
	P3=Y
	Q2=0.D0
	Q3=1.D0
C
C
C	START INTERPOLATION LOOP
	DO 16 I=2,NDIM
	II=0
	P1=P2
	P2=P3
	Q1=Q2
	Q2=Q3
	Z=Y
	DELT1=DELT2
	JEND=I-1
C
C	COMPUTATION OF INVERTED DIFFERENCES
3	AUX=VAL(I)
	DO 10 J=1,JEND
	H=VAL(I)-VAL(J)
	IF(DABS(H)-1.D-13*DABS(VAL(I)))4,4,9
4	IF(ARG(I)-ARG(J))5,17,5
5	IF(J-JEND)8,6,6
C
C	INTERCHANGE ROW I WITH ROW I+II
6	II=II+1
	III=I+II
	IF(III-NDIM)7,7,19
7	VAL(I)=VAL(III)
	VAL(III)=AUX
	AUX=ARG(I)
	ARG(I)=ARG(III)
	ARG(III)=AUX
	GOTO 3
C
C	COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1
8	VAL(I)=1.7D38                                                             0
	GOTO 10
C
C	COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J)
9	VAL(I)=(ARG(I)-ARG(J))/H
10	CONTINUE
C	INVERTED DIFFERENCES ARE COMPUTED
C
C	COMPUTATION OF NEW Y
	P3=VAL(I)*P2+(X-ARG(I-1))*P1
	Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1
	IF(Q3)11,12,11
11	Y=P3/Q3
	GOTO 13
12	Y=1.7D38                                                                  0
13	DELT2=DABS(Z-Y)
	IF(DELT2-EPS)19,19,14
14	IF(I-10)16,15,15
15	IF(DELT2-DELT1)16,18,18
16	CONTINUE
C	END OF INTERPOLATION LOOP
C
C
	RETURN
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
17	IER=3
	RETURN
C
C	TEST VALUE DELT2 STARTS OSCILLATING
18	Y=Z
	IER=1
	RETURN
C
C	THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS
19	IER=0
20	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DAHI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND
C	      DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL DAHI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
C	               ARGUMENT VALUES OF THE TABLE (NOT DESTROYED).
C	      VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION 2*NDIM) OF
C	               FUNCTION AND DERIVATIVE VALUES OF THE TABLE (DES-
C	               TROYED). FUNCTION AND DERIVATIVE VALUES MUST BE
C	               STORED IN PAIRS, THAT MEANS BEGINNING WITH FUNCTION
C	               VALUE AT POINT ARG(1) EVERY FUNCTION VALUE MUST BE
C	               FOLLOWED BY THE DERIVATIVE VALUE AT THE SAME POINT.
C	      Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
C	               VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               UPPER BOUND FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE
C	          PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
C	          WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
C	          ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
C	      HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND
C	      GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION,
C	      JACM, VOL.11, ISS.3 (1964), PP.352-356.
C
C	..................................................................
C
	SUBROUTINE DAHI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	DOUBLE PRECISION ARG,VAL,X,Y,H,H1,H2
	IER=2
	H2=X-ARG(1)
	IF(NDIM-1)2,1,3
1	Y=VAL(1)+VAL(2)*H2
2	RETURN
C
C	VECTOR ARG HAS MORE THAN 1 ELEMENT.
C	THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE
C	USED.
3	I=1
	DO 5 J=2,NDIM
	H1=H2
	H2=X-ARG(J)
	Y=VAL(I)
	VAL(I)=Y+VAL(I+1)*H1
	H=H1-H2
	IF(H)4,13,4
4	VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H
5	I=I+2
	VAL(I)=VAL(I)+VAL(I+1)*H2
C	END OF FIRST STEP
C
C	PREPARE AITKEN SCHEME
	DELT2=0.
	IEND=I-1
C
C	START AITKEN-LOOP
	DO 9 I=1,IEND
	DELT1=DELT2
	Y=VAL(1)
	M=(I+3)/2
	H1=ARG(M)
	DO 6 J=1,I
	K=I+1-J
	L=(K+1)/2
	H=ARG(L)-H1
	IF(H)6,14,6
6	VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H
	DELT2=DABS(Y-VAL(1))
	IF(DELT2-EPS)11,11,7
7	IF(I-8)9,8,8
8	IF(DELT2-DELT1)9,12,12
9	CONTINUE
C	END OF AITKEN-LOOP
C
10	Y=VAL(1)
	RETURN
C
C	THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS
11	IER=0
	GOTO 10
C
C	TEST VALUE DELT2 STARTS OSCILLATING
12	IER=1
	RETURN
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
13	Y=VAL(1)
14	IER=3
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DALI
C
C	   PURPOSE
C	      TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE
C	      X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL DALI (X,ARG,VAL,Y,NDIM,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT.
C	      ARG    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
C	               ARGUMENT VALUES OF THE TABLE (NOT DESTROYED).
C	      VAL    - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF
C	               FUNCTION VALUES OF THE TABLE (DESTROYED).
C	      Y      - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION
C	               VALUE.
C	      NDIM   - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF
C	               POINTS IN TABLE (ARG,VAL).
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               UPPER BOUND FOR THE ABSOLUTE ERROR.
C	               FOR THE ABSOLUTE ERROR.
C	      IER    - A RESULTING ERROR PARAMETER.
C
C	   REMARKS
C	      (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED
C	          FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE
C	          DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING
C	          SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL),
C	          SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A
C	          PREVIOUS STAGE.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS
C	          THAN 1.
C	      (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE
C	          BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS
C	          ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE
C	          VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER
C	          (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE
C	          PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG
C	          WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES,
C	          ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	           IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY (NO ERROR).
C	           IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED
C	                   ACCURACY BECAUSE OF ROUNDING ERRORS.
C	           IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE
C	                   NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY
C	                   COULD NOT BE REACHED BY MEANS OF THE GIVEN
C	                   TABLE. NDIM SHOULD BE INCREASED.
C	           IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES
C	                   IN VECTOR ARG WHICH ARE IDENTICAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF
C	      LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED
C	      FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK
C	      (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50.
C
C	..................................................................
C
	SUBROUTINE DALI(X,ARG,VAL,Y,NDIM,EPS,IER)
C
C
	DIMENSION ARG(1),VAL(1)
	DOUBLE PRECISION ARG,VAL,X,Y,H
	IER=2
	DELT2=0.
	IF(NDIM-1)9,7,1
C
C	START OF AITKEN-LOOP
1	DO 6 J=2,NDIM
	DELT1=DELT2
	IEND=J-1
	DO 2 I=1,IEND
	H=ARG(I)-ARG(J)
	IF(H)2,13,2
2	VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H
	DELT2=DABS(VAL(J)-VAL(IEND))
	IF(J-2)6,6,3
3	IF(DELT2-EPS)10,10,4
4	IF(J-8)6,5,5
5	IF(DELT2-DELT1)6,11,11
6	CONTINUE
C	END OF AITKEN-LOOP
C
7	J=NDIM
8	Y=VAL(J)
9	RETURN
C
C	THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS
10	IER=0
	GOTO 8
C
C	TEST VALUE DELT2 STARTS OSCILLATING
11	IER=1
12	J=IEND
	GOTO 8
C
C	THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG
13	IER=3
	GOTO 12
	END
C
C	..................................................................
C
C	   SUBROUTINE DAPCH
C
C	   PURPOSE
C	      SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF
C	      CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION
C
C	   USAGE
C	      CALL DAPCH(DATI,N,IP,XD,X0,WORK,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      DATI  - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1)
C	              CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE
C	              FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT
C	              VALUES. THE CONTENT OF VECTOR DATI REMAINS
C	              UNCHANGED.
C	              DATI MUST BE OF DOUBLE PRECISION
C	      N     - NUMBER OF GIVEN POINTS
C	      IP    - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF
C	              CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS
C	              IP SHOULD NOT EXCEED N
C	      XD    - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR
C	              TRANSFORMATION OF ARGUMENT RANGE
C	              XD MUST BE DOUBLE PRECISION
C	      X0    - RESULTANT ADDITIVE CONSTANT FOR LINEAR
C	              TRANSFORMATION OF ARGUMENT RANGE
C	              X0 MUST BE DOUBLE PRECISION
C	      WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2
C	              ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
C	              MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM
C	              FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE
C	              AND SQUARE SUM OF FUNCTION VALUES
C	              WORK MUST BE OF DOUBLE PRECISION
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS IN DIMENSION
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1 MEANS COINCIDING ARGUMENTS
C
C	   REMARKS
C	      NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS
C	      NOT POSITIVE.
C	      EXECUTION OF SUBROUTINE DAPCH IS A PREPARATORY STEP FOR
C	      CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS
C	      IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV
C	      POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM.
C	      THE METHOD IS DISCUSSED IN THE ARTICLE
C	      A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED
C	      DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227.
C
C	..................................................................
C
	SUBROUTINE DAPCH(DATI,N,IP,XD,X0,WORK,IER)
C
C
C	  DIMENSIONED DUMMY VARIABLES
	DIMENSION DATI(1),WORK(1)
	DOUBLE PRECISION DATI,WORK,XD,X0,XA,XE,XM,DF,T,SUM
C
C	   CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
	IF(N-1)19,20,1
1	IF(IP)19,19,2
C
C	   SEARCH SMALLEST AND LARGEST ARGUMENT
2	IF(IP-N)3,3,19
3	XA=DATI(1)
	X0=XA
	XE=0.D0
	DO 7 I=1,N
	XM=DATI(I)
	IF(XA-XM)5,5,4
4	XA=XM
5	IF(X0-XM)6,7,7
6	X0=XM
7	CONTINUE
C
C	   INITIALIZE CALCULATION OF NORMAL EQUATIONS
	XD=X0-XA
	M=(IP*(IP+1))/2
	IEND=M+IP+1
	MT2=IP+IP
	MT2M=MT2-1
C
C	   SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
	DO 8 I=1,IP
	J=MT2-I
	WORK(J)=0.D0
	WORK(I)=0.D0
	K=M+I
8	WORK(K)=0.D0
C
C	   CHECK FOR DEGENERATE ARGUMENT RANGE
	IF(XD)20,20,9
C
C	   CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS
9	X0=-(X0+XA)/XD
	XD=2.D0/XD
	SUM=0.D0
C
C	   START GREAT LOOP OVER ALL GIVEN POINTS
	DO 15 I=1,N
	T=DATI(I)*XD+X0
	J=I+N
	DF=DATI(J)
C
C	   CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS
C	   FOR ARGUMENT T
	XA=1.D0
	XM=T
	IF(DATI(2*N+1))11,11,10
10	J=J+N
	XA=DATI(J)
	XM=T*XA
11	T=T+T
	SUM=SUM+DF*DF*XA
	DF=DF+DF
	J=1
12	K=M+J
	WORK(K)=WORK(K)+DF*XA
13	WORK(J)=WORK(J)+XA
	IF(J-MT2M)14,15,15
14	J=J+1
	XE=T*XM-XA
	XA=XM
	XM=XE
	IF(J-IP)12,12,13
15	CONTINUE
	WORK(IEND)=SUM+SUM
C
C	   CALCULATE MATRIX OF NORMAL EQUATIONS
	LL=M
	KK=MT2M
	JJ=1
	K=KK
	DO 18 J=1,M
	WORK(LL)=WORK(K)+WORK(JJ)
	LL=LL-1
	IF(K-JJ)16,16,17
16	KK=KK-2
	K=KK
	JJ=1
	GOTO 18
17	JJ=JJ+1
	K=K-1
18	CONTINUE
	IER=0
	RETURN
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
19	IER=-1
	RETURN
C
C	   ERROR RETURN IN CASE OF COINCIDING ARGUMENTS
20	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DAPFS
C
C	   PURPOSE
C	      PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL
C	      EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT
C	      OPTIONALLY
C
C	   USAGE
C	      CALL DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      WORK  - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED
C	              COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE.
C	              THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP
C	              LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK
C	              CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0
C	              THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G.
C	              BY SUBROUTINE APLL.
C	              THE GIVEN MATRIX IS FACTORED IN THE FORM
C	              TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS
C	              DIVIDED BY TRANSPOSE(T).
C	              THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF
C	              IOP EQUALS ZERO.
C	              IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE
C	              STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF
C	              CORRESPONDING DIMENSION AND E0  IS REPLACED BY THE
C	              SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES.
C	              THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2
C	              WORK MUST BE OF DOUBLE PRECISION
C	      IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
C	              SQUARES FIT
C	      IRES  - DIMENSION OF CALCULATED LEAST SQUARES FIT.
C	              LET N1, N2, DENOTE THE FOLLOWING NUMBERS
C	              N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF
C	                   SIGNIFICANCE WAS INDICATED DURING FACTORIZATION
C	              N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF
C	                   THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ)
C	              THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE
C	              AND  IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE
C	      IOP   - INPUT PARAMETER FOR SELECTION OF OPERATION
C	              IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF
C	                      THE RIGHT HAND SIDE BY TRANSPOSE(T) AND
C	                      CALCULATION OF THE SQUARE SUM OF ERRORS IS
C	                      PERFORMED ONLY
C	              IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES
C	                      IS CALCULATED ADDITIONALLY
C	              IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE
C	                      UP TO IRES ARE CALCULATED ADDITIONALLY
C	      EPS   - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	              A SENSIBLE VALUE IS BETWEEN 1.E-10 AND 1.E-15
C	      ETA   - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF
C	              ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-15
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER =-1 MEANS NONPOSITIVE IP
C	              IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED
C	                      AND SPECIFIED TOLERANCE OF ERRORS REACHED
C	              IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR
C	                      SPECIFIED TOLERANCE OF ERRORS NOT REACHED
C
C	   REMARKS
C	      THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF
C	      SIGNIFICANCE IS TOL=ABS(EPS*SNGL(WORK(1))).
C	      THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF
C	      ERRORS IS ABS(ETA*SNGL(FSQ)).
C	      IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2.
C	      IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2.
C	      IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN
C	      ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      CALCULATION OF THE LEAST SQUARES FITS IS DONE USING
C	      CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION.
C	      THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH
C	      RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE
C	      TOLERANCE TOL.
C	      IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A
C	      SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED.
C	      IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS
C	      TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE
C	      ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION
C	      FOR LOSS OF SIGNIFICANCE
C
C	..................................................................
C
	SUBROUTINE DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION WORK(1)
	DOUBLE PRECISION WORK,SUM,PIV
	IRES=0
C
C	   TEST OF SPECIFIED DIMENSION
	IF(IP)1,1,2
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSION
1	IER=-1
	RETURN
C
C	   INITIALIZE FACTORIZATION PROCESS
2	IPIV=0
	IPP1=IP+1
	IER=1
	ITE=IP*IPP1/2
	IEND=ITE+IPP1
	TOL=ABS(EPS*SNGL(WORK(1)))
	TEST=ABS(ETA*SNGL(WORK(IEND)))
C
C	   START LOOP OVER ALL ROWS OF WORK
	DO 11 I=1,IP
	IPIV=IPIV+I
	JA=IPIV-IRES
	JE=IPIV-1
C
C	   FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS
	JK=IPIV
	DO 9 K=I,IPP1
	SUM=0.D0
	IF(IRES)5,5,3
3	JK=JK-IRES
	DO 4 J=JA,JE
	SUM=SUM+WORK(J)*WORK(JK)
4	JK=JK+1
5	IF(JK-IPIV)6,6,8
C
C	   TEST FOR LOSS OF SIGNIFICANCE
6	SUM=WORK(IPIV)-SUM
	IF(SNGL(SUM)-TOL)12,12,7
7	SUM=DSQRT(SUM)
	WORK(IPIV)=SUM
	PIV=1.D0/SUM
	GOTO 9
C
C	   UPDATE OFF-DIAGONAL TERMS
8	SUM=(WORK(JK)-SUM)*PIV
	WORK(JK)=SUM
9	JK=JK+K
C
C	   UPDATE SQUARE SUM OF ERRORS
	WORK(IEND)=WORK(IEND)-SUM*SUM
C
C	   RECORD ADDRESS OF LAST PIVOT ELEMENT
	IRES=IRES+1
	IADR=IPIV
C
C	   TEST FOR TOLERABLE ERROR IF SPECIFIED
	IF(IOP)10,11,11
10	IF(SNGL(WORK(IEND))-TEST)13,13,11
11	CONTINUE
	IF(IOP)12,22,12
C
C	   PERFORM BACK SUBSTITUTION IF SPECIFIED
12	IF(IOP)14,23,14
13	IER=0
14	IPIV=IRES
15	IF(IPIV)23,23,16
16	SUM=0.D0
	JA=ITE+IPIV
	JJ=IADR
	JK=IADR
	K=IPIV
	DO 19 I=1,IPIV
	WORK(JK)=(WORK(JA)-SUM)/WORK(JJ)
	IF(K-1)20,20,17
17	JE=JJ-1
	SUM=0.D0
	DO 18 J=K,IPIV
	SUM=SUM+WORK(JK)*WORK(JE)
	JK=JK+1
18	JE=JE+J
	JK=JE-IPIV
	JA=JA-1
	JJ=JJ-K
19	K=K-1
20	IF(IOP/2)21,23,21
21	IADR=IADR-IPIV
	IPIV=IPIV-1
	GOTO 15
C
C	   NORMAL RETURN
22	IER=0
23	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DAPLL
C	   PURPOSE
C	      SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT
C	      TO A GIVEN DISCRETE FUNCTION
C
C	   USAGE
C	      CALL DAPLL(FFCT,N,IP,P,WORK,DATI,IER)
C	      SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FFCT  - USER CODED SUBROUTINE WHICH MUST BE DECLARED
C	              EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED
C	              CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS
C	              THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR
C	              THE I-TH ARGUMENT IN P(1) UP TO P(IP)
C	              FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1)
C	              N IS THE NUMBER OF ALL POINTS
C	              P,DATI,WGT MUST BE OF DOUBLE PRECISION.
C	              DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY
C	              NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI
C	              WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT
C	              IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT
C	      N     - NUMBER OF GIVEN POINTS
C	      IP    - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST
C	              SQUARES FIT
C	              IP SHOULD NOT EXCEED N
C	      P     - WORKING STORAGE OF DIMENSION IP+1, WHICH
C	              IS USED AS INTERFACE BETWEEN APLL AND THE USER
C	              CODED SUBROUTINE FFCT
C	              P MUST BE OF DOUBLE PRECISION.
C	      WORK  - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2.
C	              ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT
C	              MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM,
C	              I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE.
C	              THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT
C	              HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS
C	              THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES
C	              WORK MUST BE OF DOUBLE PRECISION.
C	      DATI  - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN
C	              MAIN LINE AND SUBROUTINE FFCT.
C	              DATI MUST BE OF DOUBLE PRECISION.
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT
C
C	   REMARKS
C	      TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES
C	      BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR
C	      PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN
C	      SUBROUTINE DAPLL. ADDITIONAL COMPONENTS OF IER MAY BE
C	      INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH.
C	      IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A
C	      VECTOR IN HIS MAINLINE.
C	      EXECUTION OF SUBROUTINE DAPLL IS A PREPARATORY STEP FOR
C	      CALCULATION OF THE LINEAR LEAST SQUARES FIT.
C	      NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS
C
C	  SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER
C
C	   METHOD
C	      HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES
C	      AND WEIGHTS) IS COMPLETELY LEFT TO THE USER
C	      ESSENTIALLY HE HAS THREE CHOICES
C	      (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I.
C	      (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS
C	          REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI
C	          (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1
C	          LOCATIONS).
C	          ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE
C	          BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE
C	          STORAGE FOR THE DATA SET IN COMMON.
C	      (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT
C	          ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY
C	          ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM
C	          ONE UP TO N WITHIN APLL
C
C	..................................................................
C
	SUBROUTINE DAPLL(FFCT,N,IP,P,WORK,DATI,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION P(1),WORK(1),DATI(1),IER(1)
	DOUBLE PRECISION P,WORK,DATI,WGT,AUX
C
C	   CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS
	IF(N)10,10,1
1	IF(IP)10,10,2
2	IF(N-IP)10,3,3
C
C	   SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO
3	IPP1=IP+1
	M=IPP1*(IP+2)/2
	IER(1)=0
	DO 4 I=1,M
4	WORK(I)=0.D0
C
C	   START GREAT LOOP OVER ALL GIVEN POINTS
	DO 8 I=1,N
	CALL FFCT(I,N,IP,P,DATI,WGT,IER)
	IF(IER(1))9,5,9
5	J=0
	DO 7 K=1,IPP1
	AUX=P(K)*WGT
	DO 6 L=1,K
	J=J+1
6	WORK(J)=WORK(J)+P(L)*AUX
7	CONTINUE
8	CONTINUE
C
C	   NORMAL RETURN
9	RETURN
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
10	IER(1)=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DAPMM
C
C	   PURPOSE
C	      APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR
C	      COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE
C	      OF CHEBYSHEV.
C
C	   USAGE
C	      CALL DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE
C	      CALLING PROGRAM.
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER.
C	               IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR
C	               ARGUMENT VALUE X.
C	               USAGE
C	                  CALL FCT(Y,X,K)
C	               DESCRIPTION OF PARAMETERS
C	                  Y   - DOUBLE PRECISION RESULT VECTOR OF DIMEN-
C	                        SION M CONTAINING THE VALUES OF GIVEN
C	                        CONTINUOUS FUNCTIONS FOR GIVEN ARGUMENT X
C	                  X   - DOUBLE PRECISON ARGUMENT VALUE
C	                  K   - AN INTEGER VALUE WHICH IS EQUAL TO M-1
C	               REMARKS
C	                  IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED
C	                  CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO-
C	                  MIALS IS DESIRED SUBROUTINES DCNP,DCSP,DLEP,
C	                  DLAP,DHEP, RESPECTIVELY FROM SSP COULD BE USED.
C	      N      - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH
C	               IS TO BE APPROXIMATED
C	      M      - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH
C	               THE APPROXIMATING FUNCTION IS CONSTRUCTED.
C	      TOP    - DOUBLE PRECISION VECTOR OF DIMENSION 3*N.
C	               ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N)
C	               THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP
C	               TO TOP(2*N) THE CORRESPONDING NODES
C	               ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N)
C	               THE ERRORS AT THOSE N NODES.
C	               OTHER VALUES OF TOP ARE SCRATCH.
C	      IHE    - INTEGER VECTOR OF DIMENSION 3*M+4*N+6
C	      PIV    - DOUBLE PRECISION VECTOR OF DIMENSION 3*M+6.
C	               ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE
C	               RESULTING COEFFICIENTS OF LINEAR APPROXIMATION.
C	      T      - DOUBLE PRECISION AUXILIARY VECTOR OF DIMENSION
C	               (M+2)*(M+2)
C	      ITER   - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF
C	               ITERATIONS NEEDED
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - THE NUMBER OF ITERATIONS HAS REACHED
C	                         THE INTERNAL MAXIMUM N+M
C	                IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA-
C	                         METER M OR N OR SINCE AT SOME ITERATION
C	                         NO SUITABLE PIVOT COULD BE FOUND
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR
C	      N LESS THAN 2.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY
C	      LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF
C	      CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS-
C	      FORMED INTO A LINEAR PROGRAMMING PROBLEM. DAPMM USES A
C	      REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL
C	      PROBLEM. FOR REFERENCE, SEE
C	      I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND
C	      L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET,
C	      NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306.
C
C	..................................................................
C
	SUBROUTINE DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER)
C
C
	DIMENSION TOP(1),IHE(1),PIV(1),T(1)
	DOUBLE PRECISION DSUM,TOP,PIV,T,SAVE,HELP,REPI,TOL
C
C	   TEST ON WRONG INPUT PARAMETERS N AND M
	IER=-1
	IF (N-1) 81,81,1
1	IF(M) 81,81,2
C
C	   INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU
2	IER=0
C
C	   PREPARE TOP-ROW TOP
	DO 3 I=1,N
	K=I+N
	J=K+N
	TOP(J)=TOP(K)
3	TOP(K)=-TOP(I)
C
C	   PREPARE INVERSE TRANSFORMATION MATRIX T
	L=M+2
	LL=L*L
	DO 4 I=1,LL
4	T(I)=0.D0
	K=1
	J=L+1
	DO 5 I=1,L
	T(K)=1.D0
5	K=K+J
C
C	   PREPARE INDEX-VECTOR IHE
	DO 6 I=1,L
	K=I+L
	J=K+L
	IHE(I)=0
	IHE(K)=I
6	IHE(J)=1-I
	NAN=N+N
	K=L+L+L
	J=K+NAN
	DO 7 I=1,NAN
	K=K+1
	IHE(K)=I
	J=J+1
7	IHE(J)=I
C
C	   SET COUNTER ITER FOR ITERATION-STEPS
	ITER=-1
8	ITER=ITER+1
C
C	   TEST FOR MAXIMUM ITERATION-STEPS
	IF(N+M-ITER) 9,9,10
9	IER=1
	GO TO 69
C
C	   DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP
10	ISE=0
	IPIV=0
	K=L+L+L
	SAVE=0.D0
C
C	   START TOP-LOOP
	DO 14 I=1,NAN
	IDO=K+I
	HELP=TOP(I)
	IF(HELP-SAVE) 12,12,11
11	SAVE=HELP
	IPIV=I
12	IF(IHE(IDO)) 14,13,14
13	ISE=I
14	CONTINUE
C	   END OF TOP-LOOP
C
C	   IS OPTIMAL TABLEAU REACHED
	IF(IPIV) 69,69,15
C
C	   DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE
15	ILAB=1
	IND=0
	J=ISE
	IF(J) 21,21,34
C
C	   TRANSFER K-TH COLUMN FROM T TO PIV
16	K=(K-1)*L
	DO 17 I=1,L
	J=L+I
	K=K+1
17	PIV(J)=T(K)
C
C	   IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT
18	IF(ISE) 22,22,19
19	ISE=-ISE
C
C	   TRANSFER COLUMNS IN PIV
	J=L+1
	IDO=L+L
	DO 20 I=J,IDO
	K=I+L
20	PIV(K)=PIV(I)
21	J=IPIV
	GO TO 34
C
C	   SEARCH PIVOT-ELEMENT PIV(IND)
22	SAVE=1.D38
	IDO=0
	K=L+1
	LL=L+L
	IND=0
C
C	   START PIVOT-LOOP
	DO 29 I=K,LL
	J=I+L
	HELP=PIV(I)
	IF(HELP) 29,29,23
23	HELP=-HELP
	IF(ISE) 26,24,26
24	IF(IHE(J)) 27,25,27
25	IDO=I
	GO TO 29
26	HELP=-PIV(J)/HELP
27	IF(HELP-SAVE) 28,29,29
28	SAVE=HELP
	IND=I
29	CONTINUE
C	   END OF PIVOT-LOOP
C
C	   TEST FOR SUITABLE PIVOT-ELEMENT
	IF(IND) 30,30,32
30	IF(IDO) 68,68,31
31	IND=IDO
C	   PIVOT-ELEMENT IS STORED IN PIV(IND)
C
C	   COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI
32	REPI=1.D0/PIV(IND)
	IND=IND-L
C
C	   UPDATE THE TOP-ROW TOP OF THE TABLEAU
	ILAB=0
	SAVE=-TOP(IPIV)*REPI
	TOP(IPIV)=SAVE
C
C	   INITIALIZE J AS COUNTER FOR TOP-LOOP
	J=NAN
33	IF(J-IPIV) 34,53,34
34	K=0
C
C	   SEARCH COLUMN IN TRANSFORMATION-MATRIX T
	DO 36 I=1,L
	IF(IHE(I)-J) 36,35,36
35	K=I
	IF(ILAB) 50,50,16
36	CONTINUE
C
C	   GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX
	I=L+L+L+NAN+J
	I=IHE(I)-N
	IF(I) 37,37,38
37	I=I+N
	K=1
38	I=I+NAN
C
C	   CALL SUBROUTINE FCT
	CALL FCT(PIV,TOP(I),M-1)
C
C	   PREPARE THE CALLED VECTOR PIV
	DSUM=0.D0
	IDO=M
	DO 41 I=1,M
	HELP=PIV(IDO)
	IF(K) 39,39,40
39	HELP=-HELP
40	DSUM=DSUM+HELP
	PIV(IDO+1)=HELP
41	IDO=IDO-1
	PIV(L)=-DSUM
	PIV(1)=1.D0
C
C	   TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T
	IDO=IND
	IF(ILAB) 44,44,42
42	K=1
43	IDO=K
44	DSUM=0.D0
	HELP=0.D0
C
C	   START MULTIPLICATION-LOOP
	DO 46 I=1,L
	DSUM=DSUM+PIV(I)*T(IDO)
	TOL=DABS(DSUM)
	IF(TOL-HELP) 46,46,45
45	HELP=TOL
46	IDO=IDO+L
C	   END OF MULTIPLICATION-LOOP
C
	TOL=1.D-14*HELP
	IF(DABS(DSUM)-TOL) 47,47,48
47	DSUM=0.D0
48	IF(ILAB) 51,51,49
49	I=K+L
	PIV(I)=DSUM
C
C	   TEST FOR LAST COLUMN-TERM
	K=K+1
	IF(K-L) 43,43,18
50	I=(K-1)*L+IND
	DSUM=T(I)
C
C	   COMPUTE NEW TOP-ELEMENT
51	DSUM=DSUM*SAVE
	TOL=1.D-14*DABS(DSUM)
	TOP(J)=TOP(J)+DSUM
	IF(DABS(TOP(J))-TOL) 52,52,53
52	TOP(J)=0.D0
C
C	   TEST FOR LAST TOP-TERM
53	J=J-1
	IF(J) 54,54,33
C	   END OF TOP-LOOP
C
C	   TRANSFORM PIVOT-COLUMN
54	I=IND+L
	PIV(I)=-1.D0
	DO 55 I=1,L
	J=I+L
55	PIV(I)=-PIV(J)*REPI
C
C	   UPDATE TRANSFORMATION-MATRIX T
	J=0
	DO 57 I=1,L
	IDO=J+IND
	SAVE=T(IDO)
	T(IDO)=0.D0
	DO 56 K=1,L
	ISE=K+J
56	T(ISE)=T(ISE)+SAVE*PIV(K)
57	J=J+L
C
C	   UPDATE INDEX-VECTOR IHE
C	   INITIALIZE CHARACTERISTICS
	J=0
	K=0
	ISE=0
	IDO=0
C
C	   START QUESTION-LOOP
	DO 61 I=1,L
	LL=I+L
	ILAB=IHE(LL)
	IF(IHE(I)-IPIV) 59,58,59
58	ISE=I
	J=ILAB
59	IF(ILAB-IND) 61,60,61
60	IDO=I
	K=IHE(I)
61	CONTINUE
C	   END OF QUESTION-LOOP
C
C	   START MODIFICATION
	IF(K) 62,62,63
62	IHE(IDO)=IPIV
	IF(ISE) 67,67,65
63	IF(IND-J) 64,66,64
64	LL=L+L+L+NAN
	K=K+LL
	I=IPIV+LL
	ILAB=IHE(K)
	IHE(K)=IHE(I)
	IHE(I)=ILAB
	IF(ISE) 67,67,65
65	IDO=IDO+L
	I=ISE+L
	IHE(IDO)=J
	IHE(I)=IND
66	IHE(ISE)=0
67	LL=L+L
	J=LL+IND
	I=LL+L+IPIV
	ILAB=IHE(I)
	IHE(I)=IHE(J)
	IHE(J)=ILAB
C	   END OF MODIFICATION
C
	GO TO 8
C
C	   SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND
68	IER=-1
C
C	   EVALUATE FINAL TABLEAU
C	   COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND
C	   HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS
69	SAVE=0.D0
	HELP=0.D0
	K=L+L+L
	DO 73 I=1,NAN
	IDO=K+I
	J=IHE(IDO)
	IF(J) 71,70,73
70	SAVE=-TOP(I)
71	IF(M+J+1) 73,72,73
72	HELP=TOP(I)
73	CONTINUE
C
C	   PREPARE T,TOP,PIV
	T(1)=SAVE
	IDO=NAN+1
	J=NAN+N
	DO 74 I=IDO,J
74	TOP(I)=SAVE
	DO 75 I=1,M
75	PIV(I)=HELP
C
C	   COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI
C	   AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N)
	DO 79 I=1,NAN
	IDO=K+I
	J=IHE(IDO)
	IF(J) 76,79,77
76	J=-J
	PIV(J)=HELP-TOP(I)
	GO TO 79
77	IF(J-N) 78,78,79
78	J=J+NAN
	TOP(J)=SAVE+TOP(I)
79	CONTINUE
	DO 80 I=1,N
	IDO=NAN+I
80	TOP(I)=TOP(IDO)
81	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DARAT
C
C	   PURPOSE
C	      CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE
C	      FUNCTION IN THE LEAST SQUARES SENSE
C
C	   USAGE
C	      CALL DARAT(DATI,N,WORK,P,IP,IQ,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      DATI  - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS
C	              THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS,
C	              THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND
C	              THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY.
C	              IF NO WEIGHTS ARE TO BE USED THEN THE THIRD
C	              COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT
C	              WHICH MUST CONTAIN A NONPOSITIVE VALUE
C	              DATI MUST BE OF DOUBLE PRECISION
C	      N     - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION
C	      WORK  - WORKING STORAGE WHICH IS OF DIMENSION
C	              (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST.
C	              ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED
C	              IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF
C	              THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO
C	              WORK(3*N)
C	              WORK MUST BE OF DOUBLE PRECISION
C	      P     - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND
C	              NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ
C	              LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP
C	              LOCATIONS.
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH.
C	              P MUST BE OF DOUBLE PRECISION
C	      IP    - DIMENSION OF THE NUMERATOR   (INPUT VALUE)
C	      IQ    - DIMENSION OF THE DENOMINATOR (INPUT VALUE)
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER =-1 MEANS FORMAL ERRORS
C	              IER = 0 MEANS NO ERRORS
C	              IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION
C	              IER IS ALSO USED AS INPUT VALUE
C	              A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN
C	              INITIAL APPROXIMATION STORED IN P
C
C	   REMARKS
C	      THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR
C	      OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P
C	      STARTING WITH LOW POWERS (DENOMINATOR FIRST).
C	      IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE.
C	      SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL
C	      FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL
C	      (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR
C	      TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS.
C	      IF A FIT IN OTHER FUNCTIONS IS REQUIRED, DCNP AND DCNPS MUST
C	      BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DAPLL, DAPFS, DFRAT, DCNPS, DCNP
C	      DCNP IS REQUIRED WITHIN DFRAT
C
C	   METHOD
C	      THE ITERATIVE SCHEME USED FOR CALCULATION OF THE
C	      APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS
C	      WHICH ARE OBTAINED BY LINEARIZATION.
C	      A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH
C	      IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF
C	      ZEROES WITHIN THE APPROXIMATION INTERVAL.
C	      FOR REFERENCE SEE
C	      D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN,
C	      COMPUTING(1966), VOL.1, ED.3, PP.264-272.
C	      D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION
C	      OF NONLINEAR PARAMETERS,
C	      JSIAM(1963), VOL.11, ED.2, PP.431-441.
C
C	..................................................................
C
	SUBROUTINE DARAT(DATI,N,WORK,P,IP,IQ,IER)
C
C
	EXTERNAL DFRAT
C
C	   DIMENSIONED LOCAL VARIABLE
	DIMENSION IERV(3)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION DATI(1),WORK(1),P(1)
	DOUBLE PRECISION DATI,WORK,P,T,OSUM,DIAG,RELAX,SUM,SSOE,SAVE
C
C	   INITIALIZE TESTVALUES
	LIMIT=20
	ETA=1.E-29
	EPS=1.E-14
C
C	   CHECK FOR FORMAL ERRORS
	IF(N)4,4,1
1	IF(IP)4,4,2
2	IF(IQ)4,4,3
3	IPQ=IP+IQ
	IF(N-IPQ)4,5,5
C
C	   ERROR RETURN IN CASE OF FORMAL ERRORS
4	IER=-1
	RETURN
C
C	   INITIALIZE ITERATION PROCESS
5	KOUNT=0
	IERV(2)=IP
	IERV(3)=IQ
	NDP=N+N+1
	NNE=NDP+NDP
	IX=IPQ-1
	IQP1=IQ+1
	IRHS=NNE+IPQ*IX/2
	IEND=IRHS+IX
C
C	   TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION
	IF(IER)8,6,8
C
C	   INITIALIZE NUMERATOR AND DENOMINATOR
6	DO 7 I=2,IPQ
7	P(I)=0.D0
	P(1)=1.D0
C
C	   CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL
C	   APPROXIMATION
8	DO 9 J=1,N
	T=DATI(J)
	I=J+N
	CALL DCNPS(WORK(I),T,P(IQP1),IP)
	K=I+N
9	CALL DCNPS(WORK(K),T,P,IQ)
C
C	   SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION)
10	CALL DAPLL(DFRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV)
C
C	   CHECK FOR ZERO DENOMINATOR
	IF(IERV(1))4,11,4
11	INCR=0
	RELAX=2.D0
C
C	   RESTORE MATRIX IN WORKING STORAGE
12	J=IEND
	DO 13 I=NNE,IEND
	J=J+1
13	WORK(I)=WORK(J)
	IF(KOUNT)14,14,15
C
C	   SAVE SQUARE SUM OF ERRORS
14	OSUM=WORK(IEND)
	DIAG=OSUM*EPS
	K=IQ
C
C	   ADD CONSTANT TO DIAGONAL
	IF(WORK(NNE))17,17,19
15	IF(INCR)19,19,16
16	K=IPQ
17	J=NNE-1
	DO 18 I=1,K
	WORK(J)=WORK(J)+DIAG
18	J=J+I
C
C	   SOLVE NORMAL EQUATIONS
19	CALL DAPFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER)
C
C	   CHECK FOR FAILURE OF EQUATION SOLVER
	IF(IRES)4,4,20
C
C	   TEST FOR DEFECTIVE NORMALEQUATIONS
20	IF(IRES-IX)21,24,24
21	IF(INCR)22,22,23
22	DIAG=DIAG*0.125D0
23	DIAG=DIAG+DIAG
	INCR=INCR+1
C
C	   START WITH OVER RELAXATION
	RELAX=8.D0
	IF(INCR-LIMIT)12,45,45
C
C	   CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR
24	L=NDP
	J=NNE+IRES*(IRES-1)/2-1
	K=J+IQ
	WORK(J)=0.D0
	IRQ=IQ
	IRP=IRES-IQ+1
	IF(IRP)25,26,26
25	IRQ=IRES+1
26	DO 29 I=1,N
	T=DATI(I)
	WORK(I)=0.D0
	CALL DCNPS(WORK(I),T,WORK(K),IRP)
	M=L+N
	CALL DCNPS(WORK(M),T,WORK(J),IRQ)
	IF(WORK(M)*WORK(L))27,29,29
27	SUM=WORK(L)/WORK(M)
	IF(RELAX+SUM)29,29,28
28	RELAX=-SUM
29	L=L+1
C
C	   MODIFY RELAXATION FACTOR IF NECESSARY
	SSOE=OSUM
	ITER=LIMIT
30	SUM=0.D0
	RELAX=RELAX*0.5D0
	DO 32 I=1,N
	M=I+N
	K=M+N
	L=K+N
	SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L))
	SAVE=SAVE*SAVE
	IF(DATI(NDP))32,32,31
31	SAVE=SAVE*DATI(K)
32	SUM=SUM+SAVE
	IF(ITER)45,33,33
33	ITER=ITER-1
	IF(SUM-OSUM)34,37,35
34	OSUM=SUM
	GOTO 30
C
C	   TEST FOR IMPROVEMENT
35	IF(OSUM-SSOE)36,30,30
36	RELAX=RELAX+RELAX
37	T=0.
	SAVE=0.D0
	K=IRES+1
	DO 38 I=2,K
	J=J+1
	T=T+DABS(P(I))
	P(I)=P(I)+RELAX*WORK(J)
38	SAVE=SAVE+DABS(P(I))
C
C	   UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR
	DO 39 I=1,N
	J=I+N
	K=J+N
	L=K+N
	WORK(J)=WORK(J)+RELAX*WORK(I)
39	WORK(K)=WORK(K)+RELAX*WORK(L)
C
C	   TEST FOR CONVERGENCE
	IF(INCR)40,40,42
40	IF(SSOE-OSUM-RELAX*OSUM*DBLE(EPS))46,46,41
41	IF(DABS(T-SAVE)-RELAX*SAVE*DBLE(EPS))46,46,42
42	IF(OSUM-SAVE*DBLE(ETA))46,46,43
43	KOUNT=KOUNT+1
	IF(KOUNT-LIMIT)10,44,44
C
C	   ERROR RETURN IN CASE OF POOR CONVERGENCE
44	IER=2
	RETURN
45	IER=1
	RETURN
C
C	   NORMAL RETURN
46	IER=0
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR DATA SCREENING - DASCR
C
C	   PURPOSE
C	      PERFORM DATA SCREENING CALCULATIONS ON A SET OF OBSERVATIONS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SUBST
C	      TAB1
C	      LOC
C	      BOOL
C	      HIST
C	      MATIN
C
C	   METHOD
C	      DERIVE A SUBSET OF OBSERVATIONS SATISFYING CERTAIN
C	      CONDITIONS ON THE VARIABLES. FOR THIS SUBSET, THE FREQUENCY
C	      OF A SELECTED VARIABLE OVER GIVEN CLASS INTERVALS IS
C	      OBTAINED. THIS IS PLOTTED IN THE FORM OF A HISTOGRAM.
C	      TOTAL, AVERAGE, STANDARD DEVIATION, MINIMUM, AND MAXIMUM
C	      ARE ALSO CALCULATED.
C
C	..................................................................
cC
c	DIMENSION A(1000),C(63),UBO(3),S(200),R(21),FREQ(20),
c     1PCT(20),STATS(5)
c	EXTERNAL BOOL
c10	FORMAT(1H1,22HDATA SCREENING PROBLEM,I3)
c11	FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4)
c12	FORMAT(1H0,20HEXECUTION TERMINATED)
c13	FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4)
c14	FORMAT(1H0,18HGO ON TO NEXT CASE)
c15	FORMAT(1H0,11HEND OF CASE)
c16	FORMAT(7(F2.0,F1.0,F7.0))
c17	FORMAT(3F10.0)
c18	FORMAT(1H0,13HSUBSET VECTOR,///)
c19	FORMAT(1H ,I3,F5.0)
c20	FORMAT(1H1,32HSUMMARY STATISTICS FOR VARIABLE ,I3)
c21	FORMAT(1H0,7HTOTAL =,F10.3,2X,9HAVERAGE =,F10.3,2X,20HSTANDARD DEV
c     1IATION =,F10.3,2X,9HMINIMUM =,F10.3,2X,9HMAXIMUM =,F10.3)
c22	FORMAT(2I2)
cC	DOUBLE PRECISION TMPFIL,FILE
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC	FILE = TMPFIL('SSP')
cC	OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
cC	1	DISPOSE='DELETE')
cC
c	KC=0
c24	KC=KC+1
c	CALL MATIN(ICOD,A,1000,NO,NV,MS,IER)
c	IF(NO) 25,50,25
c25	IF(IER-1) 40,30,35
c30	WRITE(6,11) ICOD
c	WRITE(6,14)
c	GO TO 24
c35	WRITE(6,13)
c	WRITE(6,12)
c	GO TO 50
c40	READ(5,22)NC,NOVAR
c	JC=NC*3
c	READ(5,16)(C(I),I=1,JC)
c	READ(5,17)(UBO(I),I=1,3)
c	CALL SUBST(A,C,R,BOOL,S,NO,NV,NC)
c	WRITE(6,10)KC
c	WRITE(6,18)
c	WRITE(6,19) (I,S(I),I=1,NO)
c	CALL TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV)
c	WRITE(6,20) NOVAR
c	WRITE(6,21)(STATS(I),I=1,5)
c	JZ=UBO(2)
c	CALL HIST(KC,FREQ,JZ)
c	WRITE(6,15)
c	GO TO 24
c   50	CONTINUE
c	END
C
C	..................................................................
C
C	   SAMPLE INPUT SUBROUTINE - DATA
C
C	   PURPOSE
C	      READ AN OBSERVATION (M DATA VALUES) FROM INPUT DEVICE.
C	      THIS SUBROUTINE IS CALLED BY THE SUBROUTINE CORRE AND MUST
C	      BE PROVIDED BY THE USER.  IF SIZE AND LOCATION OF DATA
C	      FIELDS ARE DIFFERENT FROM PROBLEM TO PROBLEM, THIS SUB-
C	      ROUTINE MUST BE RECOMPILED WITH A PROPER FORMAT STATEMENT.
C
C	   USAGE
C	      CALL DATA (M,D)
C
C	   DESCRIPTION OF PARAMETERS
C	      M - THE NUMBER OF VARIABLES IN AN OBSERVATION.
C	      D - OUTPUT VECTOR OF LENGTH M CONTAINING THE OBSERVATION
C	          DATA.
C
C	   REMARKS
C	      THE TYPE OF CONVERSION SPECIFIED IN THE FORMAT MUST BE
C	      EITHER F OR E.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C	..................................................................
C
	SUBROUTINE DATA (M,D)
C
	DIMENSION D(1)
C
1	FORMAT(12F6.0)
C
C	READ AN OBSERVATION FROM INPUT DEVICE.
C
	READ (5,1) (D(I),I=1,M)
C
C	INPUT DATA ARE WRITTEN ON LOGICAL TAPE 9 FOR THE RESIDUAL ANALY-
C	SIS PERFORMED IN THE SAMPLE MULTIPLE REGRESSION PROGRAM.
C
	WRITE (9) (D(I),I=1,M)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DATSE
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE
C	      SELECTED AND ORDERED SUCH THAT
C	      ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL DATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION SEARCH ARGUMENT.
C	      ZS     - DOUBLE PRECISION STARTING VALUE OF ARGUMENTS.
C	      DZ     - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
C	      F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION VALUES (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
C	               MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
C	               TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
C	      IROW   - THE DIMENSION OF EACH COLUMN IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
C	               ORDERED ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
C	               FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
C	               IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
C	               2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
C	               TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE.
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE DATSE.
C	      SUBROUTINE DATSE ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT
C	      ARGUMENT, WHICH IS NEXT TO X.
C	      AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
C	      SELECTED IN THE ABOVE SENSE.
C
C	..................................................................
C
	SUBROUTINE DATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION F(1),ARG(1),VAL(1)
	DOUBLE PRECISION X,ZS,DZ,F,ARG,VAL
	IF(IROW-1)19,17,1
C
C	CASE DZ=0 IS CHECKED OUT
1	IF(DZ)2,17,2
2	N=NDIM
C
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)4,4,3
3	N=IROW
C
C	COMPUTATION OF STARTING SUBSCRIPT J.
4	J=(X-ZS)/DZ+1.5D0
	IF(J)5,5,6
5	J=1
6	IF(J-IROW)8,8,7
7	J=IROW
C
C	GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0.
8	II=J
	JL=0
	JR=0
	DO 16 I=1,N
	ARG(I)=ZS+DFLOAT(II-1)*DZ
	IF(ICOL-2)9,10,10
9	VAL(I)=F(II)
	GOTO 11
10	VAL(2*I-1)=F(II)
	III=II+IROW
	VAL(2*I)=F(III)
11	IF(J+JR-IROW)12,15,12
12	IF(J-JL-1)13,14,13
13	IF((ARG(I)-X)*DZ)14,15,15
14	JR=JR+1
	II=J+JR
	GOTO 16
15	JL=JL+1
	II=J-JL
16	CONTINUE
	RETURN
C
C	CASE DZ=0
17	ARG(1)=ZS
	VAL(1)=F(1)
	IF(ICOL-2)19,19,18
18	VAL(2)=F(2)
19	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DATSG
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND
C	      ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL DATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION SEARCH ARGUMENT.
C	      Z      - DOUBLE PRECISION VECTOR OD ARGUMENT VALUES
C	               (DIMENSION IROW).
C	      F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION VALUES (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
C	               MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
C	               TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
C	      WORK   - DOUBLE PRECISION WORKING STORAGE (DIMENSION IROW).
C	      IROW   - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH
C	               COLUMN IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
C	               ORDERED ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
C	               FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
C	               IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
C	               2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
C	               TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE (Z,F).
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE DATSG.
C	      SUBROUTINE DATSG ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH
C	      COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS
C	      (OR IROW STEPS IF NDIM IS GREATER THAN IROW)
C	      SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH
C	      IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN
C	      MAX(WORK(I)).
C
C	..................................................................
C
	SUBROUTINE DATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1)
	DOUBLE PRECISION X,Z,F,WORK,ARG,VAL,B,DELTA
	IF(IROW)11,11,1
1	N=NDIM
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)3,3,2
2	N=IROW
C
C	GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT.
3	B=0.D0
	DO 5 I=1,IROW
	DELTA=DABS(Z(I)-X)
	IF(DELTA-B)5,5,4
4	B=DELTA
5	WORK(I)=DELTA
C
C	GENERATION OF TABLE (ARG,VAL)
	B=B+1.D0
	DO 10 J=1,N
	DELTA=B
	DO 7 I=1,IROW
	IF(WORK(I)-DELTA)6,7,7
6	II=I
	DELTA=WORK(I)
7	CONTINUE
	ARG(J)=Z(II)
	IF(ICOL-1)8,9,8
8	VAL(2*J-1)=F(II)
	III=II+IROW
	VAL(2*J)=F(III)
	GOTO 10
9	VAL(J)=F(II)
10	WORK(II)=B
11	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DATSM
C
C	   PURPOSE
C	      NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE
C	      SELECTED AND ORDERED SUCH THAT
C	      ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J.
C
C	   USAGE
C	      CALL DATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION SEARCH ARGUMENT.
C	      Z      - DOUBLE PRECISION VECTOR OF ARGUMENT VALUES (DIMEN-
C	               SION IROW). THE ARGUMENT VALUES MUST BE STORED IN
C	               INCREASING OR DECREASING SEQUENCE.
C	      F      - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION VALUES (DIMENSION IROW).
C	               IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2
C	               MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC-
C	              TION VALUES AND THE SECOND VECTOR OF DERIVATIVES.
C	      IROW   - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN
C	               IN MATRIX F.
C	      ICOL   - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2).
C	      ARG    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND
C	               ORDERED ARGUMENT VALUES (DIMENSION NDIM).
C	      VAL    - RESULTING DOUBLE PRECISION VECTOR OF SELECTED
C	               FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1.
C	               IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR
C	               OF FUNCTION AND DERIVATIVE VALUES (DIMENSION
C	               2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC-
C	               TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE).
C	      NDIM   - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF
C	               THE GIVEN TABLE (Z,F).
C
C	   REMARKS
C	      NO ACTION IN CASE IROW LESS THAN 1.
C	      IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM
C	      SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS.  THEREFORE THE
C	      USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL)
C	      AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER
C	      TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL).
C	      THIS TEST MAY BE DONE BEFORE OR AFTER CALLING
C	      SUBROUTINE DATSM.
C	      SUBROUTINE DATSM ESPECIALLY CAN BE USED FOR GENERATING THE
C	      TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT
C	      ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH).
C	      AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND
C	      SELECTED IN THE ABOVE SENSE.
C
C	..................................................................
C
	SUBROUTINE DATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM)
C
C
	DIMENSION Z(1),F(1),ARG(1),VAL(1)
	DOUBLE PRECISION X,Z,F,ARG,VAL
C
C	CASE IROW=1 IS CHECKED OUT
	IF(IROW-1)23,21,1
1	N=NDIM
C
C	IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW.
	IF(N-IROW)3,3,2
2	N=IROW
C
C	CASE IROW.GE.2
C	SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X.
3	IF(Z(IROW)-Z(1))5,4,4
4	J=IROW
	I=1
	GOTO 6
5	I=IROW
	J=1
6	K=(J+I)/2
	IF(X-Z(K))7,7,8
7	J=K
	GOTO 9
8	I=K
9	IF(IABS(J-I)-1)10,10,6
10	IF(DABS(Z(J)-X)-DABS(Z(I)-X))12,12,11
11	J=I
C
C	TABLE SELECTION
12	K=J
	JL=0
	JR=0
	DO 20 I=1,N
	ARG(I)=Z(K)
	IF(ICOL-1)14,14,13
13	VAL(2*I-1)=F(K)
	KK=K+IROW
	VAL(2*I)=F(KK)
	GOTO 15
14	VAL(I)=F(K)
15	JJR=J+JR
	IF(JJR-IROW)16,18,18
16	JJL=J-JL
	IF(JJL-1)19,19,17
17	IF(DABS(Z(JJR+1)-X)-DABS(Z(JJL-1)-X))19,19,18
18	JL=JL+1
	K=J-JL
	GOTO 20
19	JR=JR+1
	K=J+JR
20	CONTINUE
	RETURN
C
C	CASE IROW=1
21	ARG(1)=Z(1)
	VAL(1)=F(1)
	IF(ICOL-2)23,22,23
22	VAL(2)=F(2)
23	RETURN
	END
C
C	..................................................................
C
C	SUBROUTINE DBAR
C
C	PURPOSE
C	   TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
C	   DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
C	   TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL -
C	   THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING
C	   FUNCTION VALUES ONLY ON THAT INTERVAL.
C
C	 USAGE
C	   CALL DBAR(X,H,IH,FCT,Z)
C	   PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	DESCRIPTION OF PARAMETERS
C	   X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
C	   H   - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END-
C	         POINTS ARE X AND X+H (SEE PURPOSE)
C	   IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
C	         IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
C	                       VALUE HH
C	         IH    =   0 - THE INTERNAL VALUE HH IS SET TO H
C	   FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL
C	         GENERATE THE NECESSARY FUNCTION VALUES
C	   Z   - RESULTING DERIVATIVE VALUE
C
C	REMARKS
C	   (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
C	   (2)  THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER-
C	        MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN
C	        THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE
C	        METHOD.)  IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES
C	        HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN-
C	        CATION ERROR.  HH ALWAYS HAS THE SAME SIGN AS H AND IT IS
C	        ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB-
C	        SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED
C	        INTERVAL DETERMINED BY H.
C
C	SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	   THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
C	   THE USER.
C
C	METHOD
C	   THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
C	   EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED
C	   DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
C	   (X,X+(K*HH)/10)K=1,...,10.  (SEE FILLIPI, S. AND ENGELS, H.,
C	   ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE
C	   DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
C
C	..................................................................
C
	SUBROUTINE DBAR(X,H,IH,FCT,Z)
C
C
	DIMENSION AUX(10)
C
C	   NO ACTION IN CASE OF ZERO INTERVAL LENGTH
	IF(H)1,17,1
C
C	   GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
1	C=ABS(H)
	B=H
	D=X
	D=FCT(D)
	IF(IH)2,9,2
2	HH=.5
	IF(C-HH)3,4,4
3	HH=B
4	HH=SIGN(HH,B)
	Z=ABS((FCT(X+HH)-D)/HH)
	A=ABS(D)
	HH=1.
	IF(A-1.)6,6,5
5	HH=HH*A
6	IF(Z-1.)8,8,7
7	HH=HH/Z
8	IF(HH-C)10,10,9
9	HH=B
10	HH=SIGN(HH,B)
C
C	   INITIALIZE DIFFERENTIATION LOOP
	Z=(FCT(X+HH)-D)/HH
	J=10
	JJ=J-1
	AUX(J)=Z
	DH=HH/FLOAT(J)
	DZ=1.7E38                                                                 0
C
C	   START DIFFERENTIATION LOOP
11	J=J-1
	C=J
	HH=C*DH
	AUX(J)=(FCT(X+HH)-D)/HH
C
C	   INITIALIZE EXTRAPOLATION LOOP
	D2=1.7E38                                                                 0
	B=0.
	A=1./C
C
C	   START EXTRAPOLATION LOOP
	DO 12 I=J,JJ
	D1=D2
	B=B+A
	HH=(AUX(I)-AUX(I+1))/B
	AUX(I+1)=AUX(I)+HH
C
C	   TEST ON OSCILLATING INCREMENTS
	D2=ABS(HH)
	IF(D2-D1)12,13,13
12	CONTINUE
C	   END OF EXTRAPOLATION LOOP
C
C	   UPDATE RESULT VALUE Z
	I=JJ+1
	GO TO 14
13	D2=D1
	JJ=I
14	IF(D2-DZ)15,16,16
15	DZ=D2
	Z=AUX(I)
16	IF(J-1)17,17,11
C	   END OF DIFFERENTIATION LOOP
C
17	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCAR
C
C	PURPOSE
C	   TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
C	   DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
C	   TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED
C	   SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION
C	   VALUES ONLY ON THAT CLOSED INTERVAL.
C
C	USAGE
C	      CALL DCAR (X,H,IH,FCT,Z)
C	   PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	DESCRIPTION OF PARAMETERS
C	   X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
C	   H   - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED,
C	         SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE)
C	   IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
C	         IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
C	                       VALUE HH
C	         IH    =   0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H
C	   FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL
C	         GENERATE THE NECESSARY FUNCTION VALUES
C	   Z   - RESULTING DERIVATIVE VALUE
C
C	REMARKS
C	   (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
C	   (2)  THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO
C	        IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF
C	        THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.)  IF IH IS
C	        NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO
C	        CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR.  HH
C	        IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE
C	        VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS
C	        ABSOLUTE H OF X.
C
C	SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	   THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
C	   THE USER.
C
C	METHOD
C	   THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
C	   EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL
C	   DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
C	   (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5.  (SEE FILLIPI, S. AND
C	   ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION,
C	   ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
C
C	..................................................................
C
	SUBROUTINE DCAR(X,H,IH,FCT,Z)
C
C
	DIMENSION AUX(5)
C
C	   NO ACTION IN CASE OF ZERO INTERVAL LENGTH
	IF(H)1,17,1
C
C	   GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
1	C=ABS(H)
	IF(IH)2,9,2
2	HH=.5
	IF(C-HH)3,4,4
3	HH=C
4	A=FCT(X+HH)
	B=FCT(X-HH)
	Z=ABS((A-B)/(HH+HH))
	A=.5*ABS(A+B)
	HH=.5
	IF(A-1.)6,6,5
5	HH=HH*A
6	IF(Z-1.)8,8,7
7	HH=HH/Z
8	IF(HH-C)10,10,9
9	HH=C
C
C	   INITIALIZE DIFFERENTIATION LOOP
10	Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
	J=5
	JJ=J-1
	AUX(J)=Z
	DH=HH/FLOAT(J)
	DZ=1.7E38                                                                 0
C
C	   START DIFFERENTIATION LOOP
11	J=J-1
	C=J
	HH=C*DH
	AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
C
C	   INITIALIZE EXTRAPOLATION LOOP
	D2=1.7E38                                                                 0
	B=0.
	A=1./C
C
C	   START EXTRAPOLATION LOOP
	DO 12 I=J,JJ
	D1=D2
	B=B+A
	HH=(AUX(I)-AUX(I+1))/(B*(2.+B))
	AUX(I+1)=AUX(I)+HH
C
C	   TEST ON OSCILLATING INCREMENTS
	D2=ABS(HH)
	IF(D2-D1)12,13,13
12	CONTINUE
C	   END OF EXTRAPOLATION LOOP
C
C	   UPDATE RESULT VALUE Z
	I=JJ+1
	GO TO 14
13	D2=D1
	JJ=I
14	IF(D2-DZ)15,16,16
15	DZ=D2
	Z=AUX(I)
16	IF(J-1)17,17,11
C	   END OF DIFFERENTIATION LOOP
C
17	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCEL1
C
C	   PURPOSE
C	      CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND
C
C	   USAGE
C	      CALL DCEL1(RES,AK,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE IN DOUBLE PRECISION
C	      AK    - MODULUS (INPUT) IN DOUBLE PRECISION
C	      IER   - RESULTANT ERROR CODE WHERE
C	              IER=0  NO ERROR
C	              IER=1  AK NOT IN RANGE -1 TO +1
C
C	   REMARKS
C	      THE RESULT IS SET TO 1.E75 IF ABS(AK) GE 1
C	      FOR MODULUS AK AND COMPLEMENTARY MODULUS CK,
C	      EQUATION AK*AK+CK*CK=1.D0 IS USED.
C	      AK MUST BE IN THE RANGE -1 TO +1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
C	      OVER T FROM 0 TO INFINITY).
C	      EQUIVALENT ARE THE DEFINITIONS
C	      CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED
C	      OVER T FROM 0 TO PI/2),
C	      CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T
C	      FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
C	      AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
C	      NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE DCEL1(RES,AK,IER)
	DOUBLE PRECISION RES,AK,GEO,ARI,AARI
	IER=0
	ARI=2.D0
	GEO=(0.5D0-AK)+0.5D0
	GEO=GEO+GEO*AK
	RES=0.5D0
	IF(GEO)1,2,4
1	IER=1
2	RES=1.7D38                                                                0
	RETURN
3	GEO=GEO*AARI
4	GEO=DSQRT(GEO)
	GEO=GEO+GEO
	AARI=ARI
	ARI=ARI+GEO
	RES=RES+RES
	IF(GEO/AARI-0.999999995D0)3,5,5
5	RES=RES/ARI*6.2831853071795865D0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCEL2
C
C	   PURPOSE
C	      COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF
C	      SECOND KIND.
C
C	   USAGE
C	      CALL DCEL2(RES,AK,A,B,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE IN DOUBLE PRECISION
C	      AK    - MODULUS (INPUT) IN DOUBLE PRECISION
C	      A     - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR
C	      B     - DOUBLE PRECISION FACTOR OF QUADRATIC TERM
C	              IN NUMERATOR
C	      IER   - RESULTANT ERROR CODE WHERE
C	              IER=0  NO ERROR
C	              IER=1  AK NOT IN RANGE -1 TO +1
C
C	   REMARKS
C	      FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.E75 IF B IS
C	      POSITIVE, TO -1.7D38 IF B IS NEGATIVE.                              0
C	      SPECIAL CASES ARE
C	      K(K) OBTAINED WITH A = 1, B = 1
C	      E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS
C	      COMPLEMENTARY MODULUS.
C	      B(K) OBTAINED WITH A = 1, B = 0
C	      D(K) OBTAINED WITH A = 0, B = 1
C	      WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED
C	      COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL
C	      NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS
C	      THE MODULUS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T))
C	      SUMMED OVER T FROM 0 TO INFINITY).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS
C	      AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS,
C	      NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE DCEL2(RES,AK,A,B,IER)
	DOUBLE PRECISION RES,AK,A,B,GEO,ARI,AARI,B0,A1
	IER=0
	ARI=2.D0
	GEO=(0.5D0-AK)+0.5D0
	GEO=GEO+GEO*AK
	RES=A
	A1=A+B
	B0=B+B
	IF(GEO)1,2,6
1	IER=1
2	IF(B)3,8,4
3	RES=-1.7D38                                                               0
	RETURN
4	RES=1.7D38                                                                0
	RETURN
5	GEO=GEO*AARI
6	GEO=DSQRT(GEO)
	GEO=GEO+GEO
	AARI=ARI
	ARI=ARI+GEO
	B0=B0+RES*GEO
	RES=A1
	B0=B0+B0
	A1=B0/ARI+A1
	IF(GEO/AARI-0.999999995D0)5,7,7
7	RES=A1/ARI
	RES=RES+0.57079632679489662D0*RES
8	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCLA
C
C	   PURPOSE
C	      SET EACH DIAGONAL ELEMENT OF A MATRIX EQUAL TO A SCALAR
C
C	   USAGE
C	      CALL DCLA (A,C,N,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      C - SCALAR
C	      N - NUMBER OF ROWS AND COLUMNS IN MATRIX A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      INPUT MATRIX MUST BE A SQUARE MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      EACH ELEMENT ON DIAGONAL OF MATRIX IS REPLACED BY SCALAR C
C
C	..................................................................
C
	SUBROUTINE DCLA(A,C,N,MS)
	DIMENSION A(1)
C
	DO 3 I=1,N
C
C	   LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,I,ID,N,N,MS)
C
C	   REPLACE DIAGONAL ELEMENTS
C
3	A(ID)=C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCNP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL DCNP,Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              DOUBLE PRECISION VECTOR.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE.
C	      X     - ARGUMENT OF CHEBYSHEV POLYNOMIAL
C	      N     - ORDER OF CHEBYSHEV POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      CHEBYSHEV POLYNOMIALS T(N,X)
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
C
C	..................................................................
C
	SUBROUTINE DCNP(Y,X,N)
C
	DIMENSION Y(1)
	DOUBLE PRECISION Y,X,F
C
	Y(1)=1.D0
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	F=X+X
C
	DO 4 I=2,N
4	Y(I+1)=F*Y(I)-Y(I-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCNPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL DCNPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      X     - ARGUMENT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X).
C
C	..................................................................
C
	SUBROUTINE DCNPS(Y,X,C,N)
C
	DIMENSION C(1)
	DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	IF(N-2)3,4,4
3	Y=C(1)
	RETURN
C
C	   INITIALIZATION
4	ARG=X+X
	H1=0.D0
	H0=0.D0
C
	DO 5 I=1,N
	K=N-I
	H2=H1
	H1=H0
5	H0=ARG*H1-H2+C(K+1)
	Y=0.5D0*(C(1)-H2+H0)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCPY
C
C	   PURPOSE
C	      COPY DIAGONAL ELEMENTS OF A MATRIX INTO A VECTOR
C
C	   USAGE
C	      CALL DCPY (A,R,N,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      R - NAME OF OUTPUT VECTOR OF LENGTH N
C	      N - NUMBER OF ROWS AND COLUMNS IN MATRIX A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      INPUT MATRIX MUST BE A SQUARE MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      ELEMENTS ON DIAGONAL OF MATRIX ARE MOVED TO CORRESPONDING
C	      POSITIONS OF VECTOR R
C
C	..................................................................
C
	SUBROUTINE DCPY(A,R,N,MS)
	DIMENSION A(1),R(1)
C
	DO 3 J=1,N
C
C	   LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(J,J,IJ,N,N,MS)
C
C	   MOVE DIAGONAL ELEMENT TO VECTOR R
C
3	R(J)=A(IJ)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCSP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS
C	      TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL DCSP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              DOUBLE PRECISION VECTOR.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL
C	              DOUBLE PRECISION VARIABLE.
C	      N     - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
C
C	..................................................................
C
	SUBROUTINE DCSP(Y,X,N)
C
	DIMENSION Y(1)
	DOUBLE PRECISION Y,X,F
C
C	   TEST OF ORDER
	Y(1)=1.D0
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X+X-1.D0
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	F=Y(2)+Y(2)
C
	DO 4 I=2,N
4	Y(I+1)=F*Y(I)-Y(I-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DCSPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED
C	      CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C
C	      FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL DCSPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      X     - ARGUMENT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR SHIFTED
C	      CHEBYSHEV POLYNOMIALS
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X).
C
C	..................................................................
C
	SUBROUTINE DCSPS(Y,X,C,N)
C
	DIMENSION C(1)
	DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	IF(N-2)3,4,4
3	Y=C(1)
	RETURN
C
C	   INITIALIZATION
4	ARG=X+X-1.D0
	ARG=ARG+ARG
	H1=0.D0
	H0=0.D0
	DO 5 I=1,N
	K=N-I
	H2=H1
	H1=H0
5	H0=ARG*H1-H2+C(K+1)
	Y=0.5D0*(C(1)-H2+H0)
	RETURN
	END
C
C	..................................................................
C
C	SUBROUTINE DDBAR
C
C	PURPOSE
C	   TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
C	   DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
C	   TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL -
C	   THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING
C	   FUNCTION VALUES ONLY ON THAT INTERVAL.
C
C	 USAGE
C	   CALL DDBAR(X,H,IH,FCT,Z,)
C	   PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	DESCRIPTION OF PARAMETERS
C	   X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
C	         X IS IN DOUBLE PRECISION
C	   H   - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END-
C	         POINTS ARE X AND X+H (SEE PURPOSE)
C	         H IS IN SINGLE PRECISION
C	   IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
C	         IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
C	                       VALUE HH
C	         IH    =   0 - THE INTERNAL VALUE HH IS SET TO H
C	   FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
C	         SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION
C	         VALUES.
C	   Z   - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION
C
C	REMARKS
C	   (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
C	   (2)  THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER-
C	        MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN
C	        THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE
C	        METHOD.)  IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES
C	        HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN-
C	        CATION ERROR.  HH ALWAYS HAS THE SAME SIGN AS H AND IT IS
C	        ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB-
C	        SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED
C	        INTERVAL DETERMINED BY H.
C
C	SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	   THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
C	   THE USER. FCT(T) IS IN DOUBLE PRECISION
C
C	METHOD
C	   THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
C	   EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED
C	   DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
C	   (X,X+(K*HH)/10)K=1,...,10.  (SEE FILLIPI, S. AND ENGELS, H.,
C	   ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE
C	   DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
C
C	..................................................................
C
	SUBROUTINE DDBAR(X,H,IH,FCT,Z)
C
C
	DIMENSION AUX(10)
	DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,D,DH,HH
C
C	   NO ACTION IN CASE OF ZERO INTERVAL LENGTH
	IF(H)1,17,1
C
C	   GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
1	C=ABS(H)
	B=H
	D=X
	D=FCT(D)
	IF(IH)2,9,2
2	HH=.5D-2
	IF(C-HH)3,4,4
3	HH=B
4	HH=DSIGN(HH,B)
	Z=DABS((FCT(X+HH)-D)/HH)
	A=DABS(D)
	HH=1.D-2
	IF(A-1.D0)6,6,5
5	HH=HH*A
6	IF(Z-1.D0)8,8,7
7	HH=HH/Z
8	IF(HH-C)10,10,9
9	HH=B
10	HH=DSIGN(HH,B)
C
C	   INITIALIZE DIFFERENTIATION LOOP
	Z=(FCT(X+HH)-D)/HH
	J=10
	JJ=J-1
	AUX(J)=Z
	DH=HH/DFLOAT(J)
	DZ=1.7E38                                                                 0
C
C	   START DIFFERENTIATION LOOP
11	J=J-1
	C=J
	HH=C*DH
	AUX(J)=(FCT(X+HH)-D)/HH
C
C	   INITIALIZE EXTRAPOLATION LOOP
	D2=1.7E38                                                                 0
	B=0.D0
	A=1.D0/C
C
C	   START EXTRAPOLATION LOOP
	DO 12 I=J,JJ
	D1=D2
	B=B+A
	HH=(AUX(I)-AUX(I+1))/B
	AUX(I+1)=AUX(I)+HH
C
C	   TEST ON OSCILLATING INCREMENTS
	D2=DABS(HH)
	IF(D2-D1)12,13,13
12	CONTINUE
C	   END OF EXTRAPOLATION LOOP
C
C	   UPDATE RESULT VALUE Z
	I=JJ+1
	GO TO 14
13	D2=D1
	JJ=I
14	IF(D2-DZ)15,16,16
15	DZ=D2
	Z=AUX(I)
16	IF(J-1)17,17,11
C	   END OF DIFFERENTIATION LOOP
C
17	RETURN
	END
C
C	..................................................................
C
C	SUBROUTINE DDCAR
C
C	PURPOSE
C	   TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE
C	   DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11-
C	   TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED
C	   SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION
C	   VALUES ONLY ON THAT CLOSED INTERVAL.
C
C	USAGE
C	   CALL DDCAR(X,H,IH,FCT,Z)
C	   PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	DESCRIPTION OF PARAMETERS
C	   X   - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED
C	         X IS IN DOUBLE PRECISION.
C	   H   - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED,
C	         SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE)
C	         H IS IN SINGLE PRECISION
C	   IH  - INPUT PARAMETER (SEE REMARKS AND METHOD)
C	         IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL
C	                       VALUE HH
C	         IH    =   0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H
C	   FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
C	         SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION
C	         VALUES.
C	   Z   - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION
C
C	REMARKS
C	   (1)  IF H = 0, THEN THERE IS NO COMPUTATION.
C	   (2)  THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO
C	        IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF
C	        THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.)  IF IH IS
C	        NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO
C	        CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR.  HH
C	        IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE
C	        VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS
C	        ABSOLUTE H OF X.
C
C	SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	   THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY
C	   THE USER. FCT(T) IS IN DOUBLE PRECISION
C
C	METHOD
C	   THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S
C	   EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL
C	   DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS
C	   (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5.  (SEE FILLIPI, S. AND
C	   ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION,
C	   ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.)
C
C	..................................................................
C
	SUBROUTINE DDCAR(X,H,IH,FCT,Z)
C
C
	DIMENSION AUX(5)
	DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,DH,HH
C
C	   NO ACTION IN CASE OF ZERO INTERVAL LENGTH
	IF(H)1,17,1
C
C	   GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES
1	C=ABS(H)
	IF(IH)2,9,2
2	HH=.5D-2
	IF(C-HH)3,4,4
3	HH=C
4	A=FCT(X+HH)
	B=FCT(X-HH)
	Z=DABS((A-B)/(HH+HH))
	A=.5D0*DABS(A+B)
	HH=.5D-2
	IF(A-1.D0)6,6,5
5	HH=HH*A
6	IF(Z-1.D0)8,8,7
7	HH=HH/Z
8	IF(HH-C)10,10,9
9	HH=C
C
C	   INITIALIZE DIFFERENTIATION LOOP
10	Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
	J=5
	JJ=J-1
	AUX(J)=Z
	DH=HH/DFLOAT(J)
	DZ=1.7E38                                                                 0
C
C	   START DIFFERENTIATION LOOP
11	J=J-1
	C=J
	HH=C*DH
	AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH)
C
C	   INITIALIZE EXTRAPOLATION LOOP
	D2=1.7E38                                                                 0
	B=0.D0
	A=1.D0/C
C
C	   START EXTRAPOLATION LOOP
	DO 12 I=J,JJ
	D1=D2
	B=B+A
	HH=(AUX(I)-AUX(I+1))/(B*(2.D0+B))
	AUX(I+1)=AUX(I)+HH
C
C	   TEST ON OSCILLATING INCREMENTS
	D2=DABS(HH)
	IF(D2-D1)12,13,13
12	CONTINUE
C	   END OF EXTRAPOLATION LOOP
C
C	   UPDATE RESULT VALUE Z
	I=JJ+1
	GO TO 14
13	D2=D1
	JJ=I
14	IF(D2-DZ)15,16,16
15	DZ=D2
	Z=AUX(I)
16	IF(J-1)17,17,11
C	   END OF DIFFERENTIATION LOOP
C
17	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DDET3
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
C	      FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
C	      SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DDET3(H,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      H     -  DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN
C	               SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE
C	               ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE)
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
C	               VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 3
C	               IER =  0  - NO ERROR
C	               IER =  1  - H = 0
C
C	   REMARKS
C	      (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
C	      DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP.82-84.)
C
C	..................................................................
C
	SUBROUTINE DDET3(H,Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION H,Y,Z,HH,YY,A,B
C
C	   TEST OF DIMENSION
	IF(NDIM-3)4,1,1
C
C	   TEST OF STEPSIZE
1	IF(H)2,5,2
C
C	   PREPARE DIFFERENTIATION LOOP
2	HH=.5D0/H
	YY=Y(NDIM-2)
	B=Y(2)+Y(2)
	B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1))
C
C	   START DIFFERENTIATION LOOP
	DO 3 I=3,NDIM
	A=B
	B=HH*(Y(I)-Y(I-2))
3	Z(I-2)=A
C	   END OF DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	A=Y(NDIM-1)+Y(NDIM-1)
	Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY)
	Z(NDIM-1)=B
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 3
4	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO STEPSIZE
5	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DDET5
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
C	      FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
C	      SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DDET5(H,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      H     -  DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN
C	               SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE
C	               ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE)
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
C	               VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C	               IER =  1  - H = 0
C
C	   REMARKS
C	      (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I)
C	      IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 82-84.)
C
C	..................................................................
C
	SUBROUTINE DDET5(H,Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION H,Y,Z,HH,YY,A,B,C
C
C	   TEST OF DIMENSION
	IF(NDIM-5)4,1,1
C
C	   TEST OF STEPSIZE
1	IF(H)2,5,2
C
C	   PREPARE DIFFERENTIATION LOOP
2	HH=.08333333333333333D0/H
	YY=Y(NDIM-4)
	B=HH*(-25.D0*Y(1)+48.D0*Y(2)-36.D0*Y(3)+16.D0*Y(4)-3.D0*Y(5))
	C=HH*(-3.D0*Y(1)-10.D0*Y(2)+18.D0*Y(3)-6.D0*Y(4)+Y(5))
C
C	   START DIFFERENTIATION LOOP
	DO 3 I=5,NDIM
	A=B
	B=C
	C=HH*(Y(I-4)-Y(I)+8.D0*(Y(I-1)-Y(I-3)))
3	Z(I-4)=A
C	   END OF DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	A=HH*(-YY+6.D0*Y(NDIM-3)-18.D0*Y(NDIM-2)+10.D0*Y(NDIM-1)
     1      +3.D0*Y(NDIM))
	Z(NDIM)=HH*(3.D0*YY-16.D0*Y(NDIM-3)+36.D0*Y(NDIM-2)
     1            -48.D0*Y(NDIM-1)+25.D0*Y(NDIM))
	Z(NDIM-1)=A
	Z(NDIM-2)=C
	Z(NDIM-3)=B
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
4	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO STEPSIZE
5	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DDGT3
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF
C	      ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES.
C
C	   USAGE
C	      CALL DDGT3(X,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -  GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES
C	               (DIMENSION NDIM)
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               CORRESPONDING TO X (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE
C	               VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS X,Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER  = -1  - NDIM IS LESS THAN 3
C	               IER  =  0  - NO ERROR
C	               IER POSITIVE  - X(IER) = X(IER-1) OR X(IER) =
C	                               X(IER-2)
C
C	   REMARKS
C	      (1)   IF IER = -1,2,3, THEN THERE IS NO COMPUTATION.
C	      (2)   IF IER =  4,...,N, THEN THE DERIVATIVE VALUES Z(1)
C	            ,..., Z(IER-1) HAVE BEEN COMPUTED.
C	      (3)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
C	            X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
C	      DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 64-68.)
C
C	..................................................................
C
	SUBROUTINE DDGT3(X,Y,Z,NDIM,IER)
C
C
	DIMENSION X(1),Y(1),Z(1)
	DOUBLE PRECISION X,Y,Z,DY1,DY2,DY3,A,B
C
C	   TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3
	IER=-1
	IF(NDIM-3)8,1,1
C
C	   PREPARE DIFFERENTIATION LOOP
1	A=X(1)
	B=Y(1)
	I=2
	DY2=X(2)-A
	IF(DY2)2,9,2
2	DY2=(Y(2)-B)/DY2
C
C	   START DIFFERENTIATION LOOP
	DO 6 I=3,NDIM
	A=X(I)-A
	IF(A)3,9,3
3	A=(Y(I)-B)/A
	B=X(I)-X(I-1)
	IF(B)4,9,4
4	DY1=DY2
	DY2=(Y(I)-Y(I-1))/B
	DY3=A
	A=X(I-1)
	B=Y(I-1)
	IF(I-3)5,5,6
5	Z(1)=DY1+DY3-DY2
6	Z(I-1)=DY1+DY2-DY3
C	   END OF DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	I=NDIM
7	Z(I)=DY2+DY3-DY1
8	RETURN
C
C	   ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS
9	IER=I
	I=I-1
	IF(I-2)8,8,7
	END
C
C	..................................................................
C
C	   SUBROUTINE DELI1
C
C	   PURPOSE
C	      COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND
C
C	   USAGE
C	      CALL DELI1(RES,X,CK)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE IN DOUBLE PRECISION
C	      X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
C	              INTEGRAL OF FIRST KIND) IN DOUBLE PRECISION
C	      CK    - COMPLEMENTARY MODULUS IN DOUBLE PRECISION
C
C	   REMARKS
C	      DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
C	      OVER T FROM 0 TO X).
C	      EQUIVALENT ARE THE DEFINITIONS
C	      RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED
C	      OVER T FROM 0 TO ATAN(X)),
C	      RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER
C	      T FROM 0 TO ATAN(X)).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIONS.
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE DELI1(RES,X,CK)
C
	DOUBLE PRECISION RES,X,CK,ANGLE,GEO,ARI,PIM,SQGEO,AARI,TEST
C
	IF(X)2,1,2
1	RES=0.D0
	RETURN
C
2	IF(CK)4,3,4
3	RES=DLOG(DABS(X)+DSQRT(1.D0+X*X))
	GOTO 13
C
4	ANGLE=DABS(1.D0/X)
	GEO=DABS(CK)
	ARI=1.D0
	PIM=0.D0
5	SQGEO=ARI*GEO
	AARI=ARI
	ARI=GEO+ARI
	ANGLE=-SQGEO/ANGLE+ANGLE
	SQGEO=DSQRT(SQGEO)
	IF(ANGLE)7,6,7
C
C	   REPLACE 0 BY SMALL VALUE
C
6	ANGLE=SQGEO*1.D-17
7	TEST=AARI*1.D-9
	IF(DABS(AARI-GEO)-TEST)10,10,8
8	GEO=SQGEO+SQGEO
	PIM=PIM+PIM
	IF(ANGLE)9,5,5
9	PIM=PIM+3.1415926535897932
	GOTO 5
10	IF(ANGLE)11,12,12
11	PIM=PIM+3.1415926535897932
12	RES=(DATAN(ARI/ANGLE)+PIM)/ARI
13	IF(X)14,15,15
14	RES=-RES
15	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DELI2
C
C	   PURPOSE
C	      COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND
C
C	   USAGE
C	      CALL DELI2(R,X,CK,A,B)
C
C	   DESCRIPTION OF PARAMETERS
C	      R     - RESULT VALUE IN DOUBLE PRECISION
C	      X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
C	              INTEGRAL OF SECOND KIND) IN DOUBLE PRECISION
C	      CK    - COMPLEMENTARY MODULUS IN DOUBLE PRECISION
C	      A     - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR
C	      B     - DOUBLE PRECISION QUATRATIC TERM IN NUMERATOR
C
C	   REMARKS
C	      DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK).
C	      SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF
C	      SECOND KIND ARE
C	      F(DATAN(X),K) OBTAINED WITH A=1.D0, B=1.D0
C	      E(DATAN(X),K) OBTAINED WITH A=1.D0, B=CK*CK
C	      B(DATAN(X),K) OBTAINED WITH A=1.D0, B=0.D0
C	      D(DATAN(X),K) OBTAINED WITH A=0.D0, B=1.D0.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)),
C	             SUMMED OVER T FROM 0 TO X).
C	      EQUIVALENT IS THE DEFINITION
C	      R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2),
C	             SUMMED OVER T FROM 0 TO ATAN(X)).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIONS
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE DELI2(R,X,CK,A,B)
C
	DOUBLE PRECISION R,X,A,B,AN,AA,ANG,AANG,PIM,PIMA,ARI,AARI
	DOUBLE PRECISION GEO,SGEO,C,D,P,CK
C
C	   TEST ARGUMENT
C
	IF(X)2,1,2
1	R=0.D0
	RETURN
C
C	   TEST MODULUS
C
2	C=0.D0
	D=0.5D0
	IF(CK)7,3,7
3	R=DSQRT(1.D0+X*X)
	R=(A-B)*DABS(X)/R+B*DLOG(DABS(X)+R)
4	R=R+C*(A-B)
C
C	   TEST SIGN OF ARGUMENT
C
	IF(X)5,6,6
5	R=-R
6	RETURN
C
C	   INITIALIZATION
C
7	AN=(B+A)*0.5D0
	AA=A
	R=B
	ANG=DABS(1.D0/X)
	PIM=0.D0
	ISI=0
	ARI=1.D0
	GEO=DABS(CK)
C
C	   LANDEN TRANSFORMATION
C
8	R=AA*GEO+R
	SGEO=ARI*GEO
	AA=AN
	AARI=ARI
C
C	   ARITHMETIC MEAN
C
	ARI=GEO+ARI
C
C	   SUM OF SINE VALUES
C
	AN=(R/ARI+AA)*0.5D0
	AANG=DABS(ANG)
	ANG=-SGEO/ANG+ANG
	PIMA=PIM
	IF(ANG)10,9,11
C
C	   REPLACE 0 BY SMALL VALUE
C
9	ANG=-1.D-17*AANG
10	PIM=PIM+3.1415926535897932
	ISI=ISI+1
11	AANG=ARI*ARI+ANG*ANG
	P=D/DSQRT(AANG)
	IF(ISI-4)13,12,12
12	ISI=ISI-4
13	IF(ISI-2)15,14,14
14	P=-P
15	C=C+P
	D=D*(AARI-GEO)*0.5D0/ARI
	IF(DABS(AARI-GEO)-1.D-9*AARI)17,17,16
16	SGEO=DSQRT(SGEO)
C
C	   GEOMETRIC MEAN
C
	GEO=SGEO+SGEO
	PIM=PIM+PIMA
	ISI=ISI+ISI
	GOTO 8
C
C	   ACCURACY WAS SUFFICIENT
C
17	R=(DATAN(ARI/ANG)+PIM)*AN/ARI
	C=C+D*ANG/AANG
	GOTO 4
	END
C
C	..................................................................
C
C	   SUBROUTINE DET3
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
C	      FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
C	      SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DET3(H,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      H     -  CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT
C	               VALUES (H IS POSITIVE IF THE ARGUMENT VALUES
C	               INCREASE AND NEGATIVE OTHERWISE)
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
C	               NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 3
C	               IER =  0  - NO ERROR
C	               IER =  1  - H = 0
C
C	   REMARKS
C	      (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
C	      DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP.82-84.)
C
C	..................................................................
C
	SUBROUTINE DET3(H,Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
C
C	   TEST OF DIMENSION
	IF(NDIM-3)4,1,1
C
C	   TEST OF STEPSIZE
1	IF(H)2,5,2
C
C	   PREPARE DIFFERENTIATION LOOP
2	HH=.5/H
	YY=Y(NDIM-2)
	B=Y(2)+Y(2)
	B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1))
C
C	   START DIFFERENTIATION LOOP
	DO 3 I=3,NDIM
	A=B
	B=HH*(Y(I)-Y(I-2))
3	Z(I-2)=A
C	   END OF DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	A=Y(NDIM-1)+Y(NDIM-1)
	Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY)
	Z(NDIM-1)=B
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 3
4	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO STEPSIZE
5	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DET5
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF
C	      FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY
C	      SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DET5(H,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      H     -  CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT
C	               VALUES (H IS POSITIVE IF THE ARGUMENT VALUES
C	               INCREASE AND NEGATIVE OTHERWISE)
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
C	               NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C	               IER =  1  - H = 0
C
C	   REMARKS
C	      (1)   IF IER = -1,1, THEN THERE IS NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I)
C	      IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 82-84.)
C
C	..................................................................
C
	SUBROUTINE DET5(H,Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
C
C	   TEST OF DIMENSION
	IF(NDIM-5)4,1,1
C
C	   TEST OF STEPSIZE
1	IF(H)2,5,2
C
C	   PREPARE DIFFERENTIATION LOOP
2	HH=.08333333/H
	YY=Y(NDIM-4)
	B=HH*(-25.*Y(1)+48.*Y(2)-36.*Y(3)+16.*Y(4)-3.*Y(5))
	C=HH*(-3.*Y(1)-10.*Y(2)+18.*Y(3)-6.*Y(4)+Y(5))
C
C	   START DIFFERENTIATION LOOP
	DO 3 I=5,NDIM
	A=B
	B=C
	C=HH*(Y(I-4)-Y(I)+8.*(Y(I-1)-Y(I-3)))
3	Z(I-4)=A
C	   END OF DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	A=HH*(-YY+6.*Y(NDIM-3)-18.*Y(NDIM-2)+10.*Y(NDIM-1)+3.*Y(NDIM))
	Z(NDIM)=HH*(3.*YY-16.*Y(NDIM-3)+36.*Y(NDIM-2)-48.*Y(NDIM-1)
     1            +25.*Y(NDIM))
	Z(NDIM-1)=A
	Z(NDIM-2)=C
	Z(NDIM-3)=B
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
4	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO STEPSIZE
5	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DFMCG
C
C	   PURPOSE
C	      TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
C	      BY THE METHOD OF CONJUGATE GRADIENTS
C
C	   USAGE
C	      CALL DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DESCRIPTION OF PARAMETERS
C	      FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
C	               BE MINIMIZED. IT MUST BE OF THE FORM
C	               SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
C	               AND MUST SERVE THE FOLLOWING PURPOSE
C	               FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
C	               FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
C	               AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
C	               ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION.
C	      N      - NUMBER OF VARIABLES
C	      X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
C	               ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
C	               X HOLDS THE ARGUMENT CORRESPONDING TO THE
C	               COMPUTED MINIMUM FUNCTION VALUE
C	               DOUBLE PRECISION VECTOR.
C	      F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
C	               VALUE ON RETURN, I.E. F=F(X).
C	               DOUBLE PRECISION VARIABLE.
C	      G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
C	               VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
C	               I.E. G=G(X).
C	               DOUBLE PRECISION VECTOR.
C	      EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
C	               SINGLE PRECISION VARIABLE.
C	      EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
C	               A REASONABLE CHOICE IS 10**(-16), I.E.
C	               SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
C	               NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
C	               REPRESENTATION.
C	               SINGLE PRECISION VARIABLE.
C	      LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
C	      IER    - ERROR PARAMETER
C	               IER = 0 MEANS CONVERGENCE WAS OBTAINED
C	               IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
C	               IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
C	               IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
C	               IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
C	      H      - WORKING STORAGE OF DIMENSION 2*N.
C	               DOUBLE PRECISION ARRAY.
C
C	   REMARKS
C	       I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
C	          MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
C	      II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
C	          DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
C	          A TOLERABLE RANGE OF ARGUMENT.
C	          IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
C	          INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
C	          RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
C	          MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
C	          TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
C	          IS FOUND WHERE THE FUNCTION INCREASES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      FUNCT
C
C	   METHOD
C	      THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
C	      R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY
C	      CONJUGATE GRADIENTS,
C	      COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154.
C
C	..................................................................
C
	SUBROUTINE DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION X(1),G(1),H(1)
	DOUBLE PRECISION X,G,GNRM,H,HNRM,F,FX,FY,OLDF,OLDG,SNRM,AMBDA,
     1ALFA,DALFA,T,Z,W,DX,DY
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
	CALL FUNCT(N,X,F,G)
C
C	   RESET ITERATION COUNTER
	KOUNT=0
	IER=0
	N1=N+1
C
C	   START ITERATION CYCLE FOR EVERY N+1 ITERATIONS
1	DO 43 II=1,N1
C
C	   STEP ITERATION COUNTER AND SAVE FUNCTION VALUE
	KOUNT=KOUNT+1
	OLDF=F
C
C	   COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO
	GNRM=0.D0
	DO 2 J=1,N
2	GNRM=GNRM+G(J)*G(J)
	IF(GNRM)46,46,3
C
C	   EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL
C	   BE IN DIRECTION OF STEEPEST DESCENT
3	IF(II-1)4,4,6
4	DO 5 J=1,N
5	H(J)=-G(J)
	GO TO 8
C
C	   FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING
C	   TO THE CONJUGATE GRADIENT METHOD
6	AMBDA=GNRM/OLDG
	DO 7 J=1,N
7	H(J)=AMBDA*H(J)-G(J)
C
C	   COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL
C	   DERIVATIVE
8	DY=0.D0
	HNRM=0.D0
	DO 9 J=1,N
	K=J+N
C
C	   SAVE ARGUMENT VECTOR
	H(K)=X(J)
	HNRM=HNRM+DABS(H(J))
9	DY=DY+H(J)*G(J)
C
C	   CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND
C	   SKIP LINEAR SEARCH ROUTINE IF NOT
	IF(DY)10,42,42
C
C	   COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE
10	SNRM=1.D0/HNRM
C
C	   SEARCH MINIMUM ALONG DIRECTION H
C
C	   SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
	FY=F
	ALFA=2.D0*(EST-F)/DY
	AMBDA=SNRM
C
C	   USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
C	   SNRM. OTHERWISE TAKE SNRM AS STEPSIZE.
	IF(ALFA)13,13,11
11	IF(ALFA-AMBDA)12,13,13
12	AMBDA=ALFA
13	ALFA=0.D0
C
C	   SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
14	FX=FY
	DX=DY
C
C	   STEP ARGUMENT ALONG H
	DO 15 I=1,N
15	X(I)=X(I)+AMBDA*H(I)
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
	CALL FUNCT(N,X,F,G)
	FY=F
C
C	   COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
C	   SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
	DY=0.D0
	DO 16 I=1,N
16	DY=DY+G(I)*H(I)
	IF(DY)17,38,20
C
C	   TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
C	   A MINIMUM HAS BEEN PASSED
17	IF(FY-FX)18,20,20
C
C	   REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
18	AMBDA=AMBDA+ALFA
	ALFA=AMBDA
C
C	   TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
	IF(HNRM*AMBDA-1.D10)14,14,19
C
C	   LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
19	IER=2
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
	F=OLDF
	DO 100 J=1,N
	G(J)=H(J)
	K=N+J
100	X(J)=H(K)
	RETURN
C	   END OF SEARCH LOOP
C
C	   INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
C	   ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
C	   POLYNOMIAL IS MINIMIZED
C
20	T=0.
21	IF(AMBDA)22,38,22
22	Z=3.D0*(FX-FY)/AMBDA+DX+DY
	ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY))
	DALFA=Z/ALFA
	DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
	IF(DALFA)23,27,27
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
23	DO 24 J=1,N
	K=N+J
24	X(J)=H(K)
	CALL FUNCT(N,X,F,G)
C
C	   TEST FOR REPEATED FAILURE OF ITERATION
25	IF(IER)47,26,47
26	IER=-1
	GOTO 1
27	W=ALFA*DSQRT(DALFA)
	ALFA=DY-DX+W+W
	IF(ALFA)270,271,270
270	ALFA=(DY-Z+W)/ALFA
	GO TO 272
271	ALFA=(Z+DY-W)/(Z+DX+Z+DY)
272	ALFA=ALFA*AMBDA
	DO 28 I=1,N
28	X(I)=X(I)+(T-ALFA)*H(I)
C
C	   TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
C	   THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
C	   THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
C	   THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
C	   VALUE OF THE FUNCTION AND ITS GRADIENT AT X
C
	CALL FUNCT(N,X,F,G)
	IF(F-FX)29,29,30
29	IF(F-FY)38,38,30
C
C	   COMPUTE DIRECTIONAL DERIVATIVE
30	DALFA=0.D0
	DO 31 I=1,N
31	DALFA=DALFA+G(I)*H(I)
	IF(DALFA)32,35,35
32	IF(F-FX)34,33,35
33	IF(DX-DALFA)34,38,34
34	FX=F
	DX=DALFA
	T=ALFA
	AMBDA=ALFA
	GO TO 21
35	IF(FY-F)37,36,37
36	IF(DY-DALFA)37,38,37
37	FY=F
	DY=DALFA
	AMBDA=AMBDA-ALFA
	GO TO 20
C
C	   TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
C	   OTHERWISE SAVE GRADIENT NORM
38	IF(OLDF-F+EPS)19,25,39
39	OLDG=GNRM
C
C	   COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR
	T=0.D0
	DO 40 J=1,N
	K=J+N
	H(K)=X(J)-H(K)
40	T=T+DABS(H(K))
C
C	   TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS
C	   HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS
	IF(KOUNT-N1)42,41,41
41	IF(T-EPS)45,45,42
C
C	   TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
42	IF(KOUNT-LIMIT)43,44,44
43	IER=0
C	   END OF ITERATION CYCLE
C
C	   START NEXT ITERATION CYCLE
	GO TO 1
C
C	   NO CONVERGENCE AFTER  LIMIT  ITERATIONS
44	IER=1
	IF(GNRM-EPS)46,46,47
C
C	   TEST FOR SUFFICIENTLY SMALL GRADIENT
45	IF(GNRM-EPS)46,46,25
46	IER=0
47	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DFMFP
C
C	   PURPOSE
C	      TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
C	      BY THE METHOD OF FLETCHER AND POWELL
C
C	   USAGE
C	      CALL DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DESCRIPTION OF PARAMETERS
C	      FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
C	               BE MINIMIZED. IT MUST BE OF THE FORM
C	               SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
C	               AND MUST SERVE THE FOLLOWING PURPOSE
C	               FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
C	               FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
C	               AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
C	               ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION.
C	      N      - NUMBER OF VARIABLES
C	      X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
C	               ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
C	               X HOLDS THE ARGUMENT CORRESPONDING TO THE
C	               COMPUTED MINIMUM FUNCTION VALUE
C	               DOUBLE PRECISION VECTOR.
C	      F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
C	               VALUE ON RETURN, I.E. F=F(X).
C	               DOUBLE PRECISION VARIABLE.
C	      G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
C	               VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
C	               I.E. G=G(X).
C	               DOUBLE PRECISION VECTOR.
C	      EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
C	               SINGLE PRECISION VARIABLE.
C	      EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
C	               A REASONABLE CHOICE IS 10**(-16), I.E.
C	               SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
C	               NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
C	               REPRESENTATION.
C	               SINGLE PRECISION VARIABLE.
C	      LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
C	      IER    - ERROR PARAMETER
C	               IER = 0 MEANS CONVERGENCE WAS OBTAINED
C	               IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
C	               IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
C	               IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
C	               IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
C	      H      - WORKING STORAGE OF DIMENSION N*(N+7)/2.
C	               DOUBLE PRECISION ARRAY.
C
C	   REMARKS
C	       I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
C	          MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
C	      II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
C	          DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
C	          A TOLERABLE RANGE OF ARGUMENT.
C	          IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
C	          INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
C	          RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
C	          MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
C	          TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
C	          IS FOUND WHERE THE FUNCTION INCREASES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      FUNCT
C
C	   METHOD
C	      THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
C	      R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR
C	      MINIMIZATION,
C	      COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168.
C
C	..................................................................
C
	SUBROUTINE DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION H(1),X(1),G(1)
	DOUBLE PRECISION X,F,FX,FY,OLDF,HNRM,GNRM,H,G,DX,DY,ALFA,DALFA,
     1AMBDA,T,Z,W
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
	CALL FUNCT(N,X,F,G)
C
C	   RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX
	IER=0
	KOUNT=0
	N2=N+N
	N3=N2+N
	N31=N3+1
1	K=N31
	DO 4 J=1,N
	H(K)=1.D0
	NJ=N-J
	IF(NJ)5,5,2
2	DO 3 L=1,NJ
	KL=K+L
3	H(KL)=0.D0
4	K=KL+1
C
C	   START ITERATION LOOP
5	KOUNT=KOUNT +1
C
C	   SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR
	OLDF=F
	DO 9 J=1,N
	K=N+J
	H(K)=G(J)
	K=K+N
	H(K)=X(J)
C
C	   DETERMINE DIRECTION VECTOR H
	K=J+N3
	T=0.D0
	DO 8 L=1,N
	T=T-G(L)*H(K)
	IF(L-J)6,7,7
6	K=K+N-L
	GO TO 8
7	K=K+1
8	CONTINUE
9	H(J)=T
C
C	   CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H.
	DY=0.D0
	HNRM=0.D0
	GNRM=0.D0
C
C	   CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION
C	   VECTOR H AND GRADIENT VECTOR G.
	DO 10 J=1,N
	HNRM=HNRM+DABS(H(J))
	GNRM=GNRM+DABS(G(J))
10	DY=DY+H(J)*G(J)
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL
C	   DERIVATIVE APPEARS TO BE POSITIVE OR ZERO.
	IF(DY)11,51,51
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION
C	   VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G.
11	IF(HNRM/GNRM-EPS)51,51,12
C
C	   SEARCH MINIMUM ALONG DIRECTION H
C
C	   SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
12	FY=F
	ALFA=2.D0*(EST-F)/DY
	AMBDA=1.D0
C
C	   USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
C	   1. OTHERWISE TAKE 1. AS STEPSIZE
	IF(ALFA)15,15,13
13	IF(ALFA-AMBDA)14,15,15
14	AMBDA=ALFA
15	ALFA=0.D0
C
C	   SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
16	FX=FY
	DX=DY
C
C	   STEP ARGUMENT ALONG H
	DO 17 I=1,N
17	X(I)=X(I)+AMBDA*H(I)
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
	CALL FUNCT(N,X,F,G)
	FY=F
C
C	   COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
C	   SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
	DY=0.D0
	DO 18 I=1,N
18	DY=DY+G(I)*H(I)
	IF(DY)19,36,22
C
C	   TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
C	   A MINIMUM HAS BEEN PASSED
19	IF(FY-FX)20,22,22
C
C	   REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
20	AMBDA=AMBDA+ALFA
	ALFA=AMBDA
C	   END OF SEARCH LOOP
C
C	   TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
	IF(HNRM*AMBDA-1.D10)16,16,21
C
C	   LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
21	IER=2
	RETURN
C
C	   INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
C	   ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
C	   POLYNOMIAL IS MINIMIZED
22	T=0.D0
23	IF(AMBDA)24,36,24
24	Z=3.D0*(FX-FY)/AMBDA+DX+DY
	ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY))
	DALFA=Z/ALFA
	DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
	IF(DALFA)51,25,25
25	W=ALFA*DSQRT(DALFA)
	ALFA=DY-DX+W+W
	IF(ALFA) 250,251,250
250	ALFA=(DY-Z+W)/ALFA
	GO TO 252
251	ALFA=(Z+DY-W)/(Z+DX+Z+DY)
252	ALFA=ALFA*AMBDA
	DO 26 I=1,N
26	X(I)=X(I)+(T-ALFA)*H(I)
C
C	   TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
C	   THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
C	   THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
C	   THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
C	   VALUE OF THE FUNCTION AND ITS GRADIENT AT X
C
	CALL FUNCT(N,X,F,G)
	IF(F-FX)27,27,28
27	IF(F-FY)36,36,28
28	DALFA=0.D0
	DO 29 I=1,N
29	DALFA=DALFA+G(I)*H(I)
	IF(DALFA)30,33,33
30	IF(F-FX)32,31,33
31	IF(DX-DALFA)32,36,32
32	FX=F
	DX=DALFA
	T=ALFA
	AMBDA=ALFA
	GO TO 23
33	IF(FY-F)35,34,35
34	IF(DY-DALFA)35,36,35
35	FY=F
	DY=DALFA
	AMBDA=AMBDA-ALFA
	GO TO 22
C
C	   TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
36	IF(OLDF-F+EPS)51,38,38
C
C	   COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM
C	   TWO CONSECUTIVE ITERATIONS
38	DO 37 J=1,N
	K=N+J
	H(K)=G(J)-H(K)
	K=N+K
37	H(K)=X(J)-H(K)
C
C	   TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR
C	   IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF
C	   BOTH ARE LESS THAN  EPS
	IER=0
	IF(KOUNT-N)42,39,39
39	T=0.D0
	Z=0.D0
	DO 40 J=1,N
	K=N+J
	W=H(K)
	K=K+N
	T=T+DABS(H(K))
40	Z=Z+W*H(K)
	IF(HNRM-EPS)41,41,42
41	IF(T-EPS)56,56,42
C
C	   TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
42	IF(KOUNT-LIMIT)43,50,50
C
C	   PREPARE UPDATING OF MATRIX H
43	ALFA=0.D0
	DO 47 J=1,N
	K=J+N3
	W=0.D0
	DO 46 L=1,N
	KL=N+L
	W=W+H(KL)*H(K)
	IF(L-J)44,45,45
44	K=K+N-L
	GO TO 46
45	K=K+1
46	CONTINUE
	K=N+J
	ALFA=ALFA+W*H(K)
47	H(J)=W
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS
C	   ARE NOT SATISFACTORY
	IF(Z*ALFA)48,1,48
C
C	   UPDATE MATRIX H
48	K=N31
	DO 49 L=1,N
	KL=N2+L
	DO 49 J=L,N
	NJ=N2+J
	H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA
49	K=K+1
	GO TO 5
C	   END OF ITERATION LOOP
C
C	   NO CONVERGENCE AFTER  LIMIT  ITERATIONS
50	IER=1
	RETURN
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
51	DO 52 J=1,N
	K=N2+J
52	X(J)=H(K)
	CALL FUNCT(N,X,F,G)
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE
C	   FAILS TO BE SUFFICIENTLY SMALL
	IF(GNRM-EPS)55,55,53
C
C	   TEST FOR REPEATED FAILURE OF ITERATION
53	IF(IER)56,54,54
54	IER=-1
	GOTO 1
55	IER=0
56	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DFRAT
C
C	   PURPOSE
C	      DFRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS
C	      WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF
C	      RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY
C
C	   USAGE
C	      CALL DFRAT(I,N,M,P,DATI,WGT,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      I     - SUBSCRIPT OF CURRENT DATA POINT
C	      N     - NUMBER OF ALL DATA POINTS
C	      M     - NUMBER OF FUNDAMENTAL FUNCTIONS USED
C	      P     - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS
C	              ON RETURN THE VALUES OF THE M FUNDAMENTAL
C	              FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE
C	              P MUST BE OF DOUBLE PRECISION
C	      DATI  - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED
C	              BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY
C	              N WEIGHT VALUES
C	              DATI MUST BE OF DOUBLE PRECISION
C	      WGT   - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM
C	              WGT MUST BE OF DOUBLE PRECISION
C	      IER   - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT
C	              VALUES FOR CONTROL
C	              IER(2) MEANS DIMENSION OF NUMERATOR
C	              IER(3) MEANS DIMENSION OF DENOMINATOR
C	              IER(1) IS USED AS RESULTANT ERROR PARAMETER,
C	              IER(1) = 0 IN CASE OF NO ERRORS
C	              IER(1) = 1 OTHERWISE (ZERO DENOMINATOR)
C
C	   REMARKS
C	      VECTOR IER IS USED FOR COMMUNICATION BETWEEN DARAT AND DFRAT
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DCNP
C
C	   METHOD
C	      CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT
C
C	..................................................................
C
	SUBROUTINE DFRAT(I,N,M,P,DATI,WGT,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION P(1),DATI(1),IER(1)
	DOUBLE PRECISION P,DATI,WGT,T,F,FNUM,FDEN
C
C	   INITIALIZATION
	IP=IER(2)
	IQ=IER(3)
	IQM1=IQ-1
	IPQ=IP+IQ
C
C	   LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT
C	   LOOK UP NUMERATOR AND DENOMINATOR
	T=DATI(I)
	J=I+N
	F=DATI(J)
	FNUM=P(J)
	J=J+N
	WGT=1.D0
	IF(DATI(2*N+1))2,2,1
1	WGT=DATI(J)
2	FDEN=P(J)
C
C	   CALCULATE FUNCTION VALUE USED
	F=F*FDEN-FNUM
C
C	   CHECK FOR ZERO DENOMINATOR
	IF(FDEN)4,3,4
C
C	   ERROR RETURN IN CASE OF ZERO DENOMINATOR
3	IER(1)=1
	RETURN
C
C	   CALCULATE WEIGHT FACTORS USED
4	WGT=WGT/(FDEN*FDEN)
	FNUM=-FNUM/FDEN
C
C	   CALCULATE FUNDAMENTAL FUNCTIONS
	J=IQM1
	IF(IP-IQ)6,6,5
5	J=IP-1
6	CALL DCNP(P(IQ),T,J)
C
C	   STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS
7	IF(IQM1)10,10,8
8	DO 9 II=1,IQM1
	J=II+IQ
9	P(II)=P(J)*FNUM
C
C	   STORE FUNCTION VALUE
10	P(IPQ)=F
C
C	   NORMAL RETURN
	IER(1)=0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DGELB
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A
C	      COEFFICIENT MATRIX OF BAND STRUCTURE.
C
C	   USAGE
C	      CALL DGELB(R,A,M,N,MUD,MLD,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
C	               (DESTROYED). ON RETURN R CONTAINS THE SOLUTION
C	               OF THE EQUATIONS.
C	      A      - DOUBLE PRECISION M BY M COEFFICIENT MATRIX WITH
C	               BAND STRUCTURE (DESTROYED).
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      MUD    - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS
C	               CODIAGONALS ABOVE MAIN DIAGONAL).
C	      MLD    - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS
C	               CODIAGONALS BELOW MAIN DIAGONAL).
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               RELATIVE TOLERANCE FOR TEST ON LOSS OF
C	               SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
C	                        TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT
C	                        AT ANY ELIMINATION STEP EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
C
C	   REMARKS
C	      BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST
C	      ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA
C	      STORAGE LOCATIONS, WHERE
C	        MA=M*MC-ML*(ML+1)/2    AND    ME=MA-MU*(MU+1)/2    WITH
C	        MC=MIN(M,1+MUD+MLD),  ML=MC-1-MLD,  MU=MC-1-MUD.
C	      RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
C	      IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION
C	      MATRIX R IS STORED COLUMNWISE TOO.
C	      INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING
C	      RESTRICTIONS     MUD NOT LESS THAN ZERO
C	                       MLD NOT LESS THAN ZERO
C	                       MUD+MLD NOT GREATER THAN 2*M-2.
C	      NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
C	      RESTRICTIONS ARE NOT SATISFIED.
C	      THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
C	      PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL
C	      ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING
C	      IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE.
C	      IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE
C	      EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K.
C	      NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH
C	      COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE
C	      IN REMAINING COEFFICIENT MATRICES.
C
C	..................................................................
C
	SUBROUTINE DGELB(R,A,M,N,MUD,MLD,EPS,IER)
C
C
	DIMENSION R(1),A(1)
	DOUBLE PRECISION R,A,PIV,TB,TOL
C
C	TEST ON WRONG INPUT PARAMETERS
	IF(MLD)47,1,1
1	IF(MUD)47,2,2
2	MC=1+MLD+MUD
	IF(MC+1-M-M)3,3,47
C
C	PREPARE INTEGER PARAMETERS
C	   MC=NUMBER OF COLUMNS IN MATRIX A
C	   MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A
C	   ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A
C	   MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS
C	   MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A
C	   MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A
C	   NM=NUMBER OF ELEMENTS IN MATRIX R
3	IF(MC-M)5,5,4
4	MC=M
5	MU=MC-MUD-1
	ML=MC-MLD-1
	MR=M-ML
	MZ=(MU*(MU+1))/2
	MA=M*MC-(ML*(ML+1))/2
	NM=N*M
C
C	MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT
C	(NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS)
	IER=0
	PIV=0.D0
	IF(MLD)14,14,6
6	JJ=MA
	J=MA-MZ
	KST=J
	DO 9 K=1,KST
	TB=A(J)
	A(JJ)=TB
	TB=DABS(TB)
	IF(TB-PIV)8,8,7
7	PIV=TB
8	J=J-1
9	JJ=JJ-1
C
C	INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0)
	IF(MZ)14,14,10
10	JJ=1
	J=1+MZ
	IC=1+MUD
	DO 13 I=1,MU
	DO 12 K=1,MC
	A(JJ)=0.D0
	IF(K-IC)11,11,12
11	A(JJ)=A(J)
	J=J+1
12	JJ=JJ+1
13	IC=IC+1
C
C	GENERATE TEST VALUE FOR SINGULARITY
14	TOL=EPS*PIV
C
C
C	START DECOMPOSITION LOOP
	KST=1
	IDST=MC
	IC=MC-1
	DO 38 K=1,M
	IF(K-MR-1)16,16,15
15	IDST=IDST-1
16	ID=IDST
	ILR=K+MLD
	IF(ILR-M)18,18,17
17	ILR=M
18	II=KST
C
C	PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR)
	PIV=0.D0
	DO 22 I=K,ILR
	TB=DABS(A(II))
	IF(TB-PIV)20,20,19
19	PIV=TB
	J=I
	JJ=II
20	IF(I-MR)22,22,21
21	ID=ID-1
22	II=II+ID
C
C	TEST ON SINGULARITY
	IF(PIV)47,47,23
23	IF(IER)26,24,26
24	IF(PIV-TOL)25,25,26
25	IER=K-1
26	PIV=1.D0/A(JJ)
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	ID=J-K
	DO 27 I=K,NM,M
	II=I+ID
	TB=PIV*R(II)
	R(II)=R(I)
27	R(I)=TB
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A
	II=KST
	J=JJ+IC
	DO 28 I=JJ,J
	TB=PIV*A(I)
	A(I)=A(II)
	A(II)=TB
28	II=II+1
C
C	ELEMENT REDUCTION
	IF(K-ILR)29,34,34
29	ID=KST
	II=K+1
	MU=KST+1
	MZ=KST+IC
	DO 33 I=II,ILR
C
C	IN MATRIX A
	ID=ID+MC
	JJ=I-MR-1
	IF(JJ)31,31,30
30	ID=ID-JJ
31	PIV=-A(ID)
	J=ID+1
	DO 32 JJ=MU,MZ
	A(J-1)=A(J)+PIV*A(JJ)
32	J=J+1
	A(J-1)=0.D0
C
C	IN MATRIX R
	J=K
	DO 33 JJ=I,NM,M
	R(JJ)=R(JJ)+PIV*R(J)
33	J=J+M
34	KST=KST+MC
	IF(ILR-MR)36,35,35
35	IC=IC-1
36	ID=K-MR
	IF(ID)38,38,37
37	KST=KST-ID
38	CONTINUE
C	END OF DECOMPOSITION LOOP
C
C
C	BACK SUBSTITUTION
	IF(MC-1)46,46,39
39	IC=2
	KST=MA+ML-MC+2
	II=M
	DO 45 I=2,M
	KST=KST-MC
	II=II-1
	J=II-MR
	IF(J)41,41,40
40	KST=KST+J
41	DO 43 J=II,NM,M
	TB=R(J)
	MZ=KST+IC-2
	ID=J
	DO 42 JJ=KST,MZ
	ID=ID+1
42	TB=TB-A(JJ)*R(ID)
43	R(J)=TB
	IF(IC-MC)44,45,45
44	IC=IC+1
45	CONTINUE
46	RETURN
C
C
C	ERROR RETURN
47	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DGELG
C
C	   PURPOSE
C	      TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS.
C
C	   USAGE
C	      CALL DGELG(R,A,M,N,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
C	               (DESTROYED). ON RETURN R CONTAINS THE SOLUTIONS
C	               OF THE EQUATIONS.
C	      A      - DOUBLE PRECISION M BY M COEFFICIENT MATRIX
C	               (DESTROYED).
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               RELATIVE TOLERANCE FOR TEST ON LOSS OF
C	               SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C	                        PIVOT ELEMENT AT ANY ELIMINATION STEP
C	                        EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
C
C	   REMARKS
C	      INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE
C	      IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN
C	      SOLUTION MATRIX R IS STORED COLUMNWISE TOO.
C	      THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C	      GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C	      ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C	      INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C	      SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C	      INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C	      GIVEN IN CASE M=1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C	      COMPLETE PIVOTING.
C
C	..................................................................
C
	SUBROUTINE DGELG(R,A,M,N,EPS,IER)
C
C
	DIMENSION A(1),R(1)
	DOUBLE PRECISION R,A,PIV,TB,TOL,PIVI
	IF(M)23,23,1
C
C	SEARCH FOR GREATEST ELEMENT IN MATRIX A
1	IER=0
	PIV=0.D0
	MM=M*M
	NM=N*M
	DO 3 L=1,MM
	TB=DABS(A(L))
	IF(TB-PIV)3,3,2
2	PIV=TB
	I=L
3	CONTINUE
	TOL=EPS*PIV
C	A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C	START ELIMINATION LOOP
	LST=1
	DO 17 K=1,M
C
C	TEST ON SINGULARITY
	IF(PIV)23,23,4
4	IF(IER)7,5,7
5	IF(PIV-TOL)6,6,7
6	IER=K-1
7	PIVI=1.D0/A(I)
	J=(I-1)/M
	I=I-J*M-K
	J=J+1-K
C	I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	DO 8 L=K,NM,M
	LL=L+I
	TB=PIVI*R(LL)
	R(LL)=R(L)
8	R(L)=TB
C
C	IS ELIMINATION TERMINATED
	IF(K-M)9,18,18
C
C	COLUMN INTERCHANGE IN MATRIX A
9	LEND=LST+M-K
	IF(J)12,12,10
10	II=J*M
	DO 11 L=LST,LEND
	TB=A(L)
	LL=L+II
	A(L)=A(LL)
11	A(LL)=TB
C
C	ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A
12	DO 13 L=LST,MM,M
	LL=L+I
	TB=PIVI*A(LL)
	A(LL)=A(L)
13	A(L)=TB
C
C	SAVE COLUMN INTERCHANGE INFORMATION
	A(LST)=J
C
C	ELEMENT REDUCTION AND NEXT PIVOT SEARCH
	PIV=0.D0
	LST=LST+1
	J=0
	DO 16 II=LST,LEND
	PIVI=-A(II)
	IST=II+M
	J=J+1
	DO 15 L=IST,MM,M
	LL=L-J
	A(L)=A(L)+PIVI*A(LL)
	TB=DABS(A(L))
	IF(TB-PIV)15,15,14
14	PIV=TB
	I=L
15	CONTINUE
	DO 16 L=K,NM,M
	LL=L+J
16	R(LL)=R(LL)+PIVI*R(L)
17	LST=LST+M
C	END OF ELIMINATION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
18	IF(M-1)23,22,19
19	IST=MM+M
	LST=M+1
	DO 21 I=2,M
	II=LST-I
	IST=IST-LST
	L=IST-M
	L=A(L)+.5D0
	DO 21 J=II,NM,M
	TB=R(J)
	LL=J
	DO 20 K=IST,MM,M
	LL=LL+1
20	TB=TB-A(K)*R(LL)
	K=J+L
	R(J)=R(K)
21	R(K)=TB
22	RETURN
C
C
C	ERROR RETURN
23	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DGELS
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH
C	      SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH
C	      IS ASSUMED TO BE STORED COLUMNWISE.
C
C	   USAGE
C	      CALL DGELS(R,A,M,N,EPS,IER,AUX)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
C	               (DESTROYED). ON RETURN R CONTAINS THE SOLUTION OF
C	               THE EQUATIONS.
C	      A      - UPPER TRIANGULAR PART OF THE SYMMETRIC DOUBLE
C	               PRECISION M BY M COEFFICIENT MATRIX.  (DESTROYED)
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C	               RELATIVE TOLERANCE FOR TEST ON LOSS OF
C	               SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C	                        PIVOT ELEMENT AT ANY ELIMINATION STEP
C	                        EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST MAIN DIAGONAL
C	                        ELEMENT OF MATRIX A.
C	      AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY
C	               WITH DIMENSION M-1.
C
C	   REMARKS
C	      UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED
C	      COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT
C	      HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE
C	      LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE
C	      TOO.
C	      THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C	      GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C	      ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C	      INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C	      SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C	      INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C	      GIVEN IN CASE M=1.
C	      ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT
C	      MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS
C	      ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE DGELG (WHICH
C	      WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C	      PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE
C	      SYMMETRY IN REMAINING COEFFICIENT MATRICES.
C
C	..................................................................
C
	SUBROUTINE DGELS(R,A,M,N,EPS,IER,AUX)
C
C
	DIMENSION A(1),R(1),AUX(1)
	DOUBLE PRECISION R,A,AUX,PIV,TB,TOL,PIVI
	IF(M)24,24,1
C
C	SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT
1	IER=0
	PIV=0.D0
	L=0
	DO 3 K=1,M
	L=L+K
	TB=DABS(A(L))
	IF(TB-PIV)3,3,2
2	PIV=TB
	I=L
	J=K
3	CONTINUE
	TOL=EPS*PIV
C	MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT.
C	PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C	START ELIMINATION LOOP
	LST=0
	NM=N*M
	LEND=M-1
	DO 18 K=1,M
C
C	TEST ON USEFULNESS OF SYMMETRIC ALGORITHM
	IF(PIV)24,24,4
4	IF(IER)7,5,7
5	IF(PIV-TOL)6,6,7
6	IER=K-1
7	LT=J-K
	LST=LST+K
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	PIVI=1.D0/A(I)
	DO 8 L=K,NM,M
	LL=L+LT
	TB=PIVI*R(LL)
	R(LL)=R(L)
8	R(L)=TB
C
C	IS ELIMINATION TERMINATED
	IF(K-M)9,19,19
C
C	ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A.
C	ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX.
9	LR=LST+(LT*(K+J-1))/2
	LL=LR
	L=LST
	DO 14 II=K,LEND
	L=L+II
	LL=LL+1
	IF(L-LR)12,10,11
10	A(LL)=A(LST)
	TB=A(L)
	GO TO 13
11	LL=L+LT
12	TB=A(LL)
	A(LL)=A(L)
13	AUX(II)=TB
14	A(L)=PIVI*TB
C
C	SAVE COLUMN INTERCHANGE INFORMATION
	A(LST)=LT
C
C	ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT
	PIV=0.D0
	LLST=LST
	LT=0
	DO 18 II=K,LEND
	PIVI=-AUX(II)
	LL=LLST
	LT=LT+1
	DO 15 LLD=II,LEND
	LL=LL+LLD
	L=LL+LT
15	A(L)=A(L)+PIVI*A(LL)
	LLST=LLST+II
	LR=LLST+LT
	TB=DABS(A(LR))
	IF(TB-PIV)17,17,16
16	PIV=TB
	I=LR
	J=II+1
17	DO 18 LR=K,NM,M
	LL=LR+LT
18	R(LL)=R(LL)+PIVI*R(LR)
C	END OF ELIMINATION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
19	IF(LEND)24,23,20
20	II=M
	DO 22 I=2,M
	LST=LST-II
	II=II-1
	L=A(LST)+.5D0
	DO 22 J=II,NM,M
	TB=R(J)
	LL=J
	K=LST
	DO 21 LT=II,LEND
	LL=LL+1
	K=K+LT
21	TB=TB-A(K)*R(LL)
	K=J+L
	R(J)=R(K)
22	R(K)=TB
23	RETURN
C
C
C	ERROR RETURN
24	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DGT3
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF
C	      ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES.
C
C	   USAGE
C	      CALL DGT3(X,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -  GIVEN VECTOR OF ARGUMENT VALUES (DIMENSION NDIM)
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES CORRESPONDING TO X
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION
C	               NDIM)
C	      NDIM  -  DIMENSION OF VECTORS X,Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER  = -1  - NDIM IS LESS THAN 3
C	               IER  =  0  - NO ERROR
C	               IER POSITIVE  - X(IER) = X(IER-1) OR X(IER) =
C	                               X(IER-2)
C
C	   REMARKS
C	      (1)   IF IER = -1,2,3, THEN THERE IS NO COMPUTATION.
C	      (2)   IF IER =  4,...,N, THEN THE DERIVATIVE VALUES Z(1)
C	            ,..., Z(IER-1) HAVE BEEN COMPUTED.
C	      (3)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
C	            X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE
C	      DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION
C	      POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS
C	      (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 64-68.)
C
C	..................................................................
C
	SUBROUTINE DGT3(X,Y,Z,NDIM,IER)
C
C
	DIMENSION X(1),Y(1),Z(1)
C
C	   TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3
	IER=-1
	IF(NDIM-3)8,1,1
C
C	   PREPARE DIFFERENTIATION LOOP
1	A=X(1)
	B=Y(1)
	I=2
	DY2=X(2)-A
	IF(DY2)2,9,2
2	DY2=(Y(2)-B)/DY2
C
C	   START DIFFERENTIATION LOOP
	DO 6 I=3,NDIM
	A=X(I)-A
	IF(A)3,9,3
3	A=(Y(I)-B)/A
	B=X(I)-X(I-1)
	IF(B)4,9,4
4	DY1=DY2
	DY2=(Y(I)-Y(I-1))/B
	DY3=A
	A=X(I-1)
	B=Y(I-1)
	IF(I-3)5,5,6
5	Z(1)=DY1+DY3-DY2
6	Z(I-1)=DY1+DY2-DY3
C	   END DIFFERENTIATION LOOP
C
C	   NORMAL EXIT
	IER=0
	I=NDIM
7	Z(I)=DY2+DY3-DY1
8	RETURN
C
C	   ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS
9	IER=I
	I=I-1
	IF(I-2)8,8,7
	END
C
C	..................................................................
C
C	   SUBROUTINE DHARM
C
C	   PURPOSE
C	      PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX
C	      DOUBLE PRECISION,THREE DIMENSIONAL ARRAY
C
C	   USAGE
C	      CALL DHARM(A,M,INV,S,IFSET,IFERR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - A DOUBLE PRECISION VECTOR
C	              AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL
C	              ARRAY TO BE TRANSFORMED.  THE REAL PART OF
C	              A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL
C	              WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE
C	              NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC.
C	              THE IMAGINARY PART IS IN THE CELL IMMEDIATELY
C	              FOLLOWING.  NOTE THAT THE SUBSCRIPT I1 INCREASES
C	              MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY.
C	              AS OUTPUT, A CONTAINS THE COMPLEX FOURIER
C	              TRANSFORM.  THE NUMBER OF CORE LOCATIONS OF
C	              ARRAY A IS 2*(N1*N2*N3)
C	      M     - A THREE CELL VECTOR WHICH DETERMINES THE SIZES
C	              OF THE 3 DIMENSIONS OF THE ARRAY A.   THE SIZE,
C	              NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3
C	      INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION
C	              OF DIMENSION ONE FOURTH OF THE QUANTITY
C	              MAX(N1,N2,N3)
C	              LOCATIONS OF A, VIZ., (1/8)*2*N1*N2*N3
C	      S     - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES
C	              WITH DIMENSION THE SAME AS INV
C	      IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS
C	                 0    SET UP SINE AND INV TABLES ONLY
C	                 1    SET UP SINE AND INV TABLES ONLY AND
C	                      CALCULATE FOURIER TRANSFORM
C	                -1    SET UP SINE AND INV TABLES ONLY AND
C	                      CALCULATE INVERSE FOURIER TRANSFORM (FOR
C	                      THE MEANING OF INVERSE SEE THE EQUATIONS
C	                      UNDER METHOD BELOW)
C	                 2    CALCULATE FOURIER TRANSFORM ONLY (ASSUME
C	                      SINE AND INV TABLES EXIST)
C	                -2    CALCULATE INVERSE FOURIER TRANSFORM ONLY
C	                      (ASSUME SINE AND INV TABLES EXIST)
C	      IFERR - ERROR INDICATOR.   WHEN IFSET IS 0,+1,-1,
C	              IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN
C	              20, I=1,2,3   WHEN IFSET IS 2,-2 , IFERR = 1
C	              MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE
C	              ENOUGH OR HAVE NOT BEEN COMPUTED .
C	              IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE
C	              CONDITIONS ARE PRESENT
C
C	   REMARKS
C	      THIS SUBROUTINE IS TO BE USED FOR COMPLEX, DOUBLE PRECISION,
C	      3-DIMENSIONAL ARRAYS IN WHICH EACH DIMENSION IS A POWER OF
C	      2. THE MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN
C	      20, I = 1,2,3.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX
C	      ARRAY A IS OBTAINED.
C
C	             N1-1   N2-1   N3-1                L1   L2   L3
C	X(J1,J2,J3)=SUM    SUM    SUM    A(K1,K2,K3)*W1  *W2  *W3
C	             K1=0   K2=0   K3=0
C
C	             WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1,
C	                   L2=K2*J2, L3=K3*J3
C
C
C	      FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF
C	      COMPLEX ARRAY X IS OBTAINED.
C
C	A(K1,K2,K3)=
C	          1      N1-1   N2-1   N3-1                -L1  -L2  -L3
C	      -------- *SUM    SUM    SUM    X(J1,J2,J3)*W1  *W2  *W3
C	      N1*N2*N3   J1=0   J2=0   J3=0
C
C
C	      SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE
C	      MACHINE CALCULATION OF COMPLEX FOURIER SERIES',
C	      MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297.
C
C	..................................................................
C
	SUBROUTINE DHARM(A,M,INV,S,IFSET,IFERR)
	DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2)
	DOUBLE PRECISION A,R,W3,AWI,THETA,ROOT2,S,T,W,W2,FN,AWR
	EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3)
10	IF( IABS(IFSET) - 1) 900,900,12
12	MTT=MAX0(M(1),M(2),M(3)) -2
	ROOT2=DSQRT(2.0D0)
	IF (MTT-MT ) 14,14,13
13	IFERR=1
	RETURN
14	IFERR=0
	M1=M(1)
	M2=M(2)
	M3=M(3)
	N1=2**M1
	N2=2**M2
	N3=2**M3
16	IF(IFSET) 18,18,20
18	NX= N1*N2*N3
	FN = NX
	DO 19 I = 1,NX
	A(2*I-1) = A(2*I-1)/FN
19	A(2*I) = -A(2*I)/FN
20	NP(1)=N1*2
	NP(2)= NP(1)*N2
	NP(3)=NP(2)*N3
	DO 250 ID=1,3
	IL = NP(3)-NP(ID)
	IL1 = IL+1
	MI = M(ID)
	IF (MI)250,250,30
30	IDIF=NP(ID)
	KBIT=NP(ID)
	MEV = 2*(MI/2)
	IF (MI - MEV )60,60,40
C
C	M IS ODD. DO L=1 CASE
40	KBIT=KBIT/2
	KL=KBIT-2
	DO 50 I=1,IL1,IDIF
	KLAST=KL+I
	DO 50 K=I,KLAST,2
	KD=K+KBIT
C
C	DO ONE STEP WITH L=1,J=0
C	A(K)=A(K)+A(KD)
C	A(KD)=A(K)-A(KD)
C
	T=A(KD)
	A(KD)=A(K)-T
	A(K)=A(K)+T
	T=A(KD+1)
	A(KD+1)=A(K+1)-T
50	A(K+1)=A(K+1)+T
	IF (MI - 1)250,250,52
52	LFIRST =3
C
C	DEF - JLAST = 2**(L-2) -1
	JLAST=1
	GO TO 70
C
C	M IS EVEN
60	LFIRST = 2
	JLAST=0
70	DO 240 L=LFIRST,MI,2
	JJDIF=KBIT
	KBIT=KBIT/4
	KL=KBIT-2
C
C	DO FOR J=0
	DO 80 I=1,IL1,IDIF
	KLAST=I+KL
	DO 80 K=I,KLAST,2
	K1=K+KBIT
	K2=K1+KBIT
	K3=K2+KBIT
C
C	DO TWO STEPS WITH J=0
C	A(K)=A(K)+A(K2)
C	A(K2)=A(K)-A(K2)
C	A(K1)=A(K1)+A(K3)
C	A(K3)=A(K1)-A(K3)
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	T=A(K2)
	A(K2)=A(K)-T
	A(K)=A(K)+T
	T=A(K2+1)
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	T=A(K3)
	A(K3)=A(K1)-T
	A(K1)=A(K1)+T
	T=A(K3+1)
	A(K3+1)=A(K1+1)-T
	A(K1+1)=A(K1+1)+T
C
	T=A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	R=-A(K3+1)
	T = A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
80	A(K2+1)=A(K2+1)+T
	IF (JLAST) 235,235,82
82	JJ=JJDIF   +1
C
C	DO FOR J=1
	ILAST= IL +JJ
	DO 85 I = JJ,ILAST,IDIF
	KLAST = KL+I
	DO 85 K=I,KLAST,2
	K1 = K+KBIT
	K2 = K1+KBIT
	K3 = K2+KBIT
C
C	LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I,
C	A(K)=A(K)+A(K2)*I
C	A(K2)=A(K)-A(K2)*I
C	A(K1)=A(K1)*W+A(K3)*W3
C	A(K3)=A(K1)*W-A(K3)*W3
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	R =-A(K2+1)
	T = A(K2)
	A(K2) = A(K)-R
	A(K) = A(K)+R
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	AWR=A(K1)-A(K1+1)
	AWI = A(K1+1)+A(K1)
	R=-A(K3)-A(K3+1)
	T=A(K3)-A(K3+1)
	A(K3)=(AWR-R)/ROOT2
	A(K3+1)=(AWI-T)/ROOT2
	A(K1)=(AWR+R)/ROOT2
	A(K1+1)=(AWI+T)/ROOT2
	T= A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
	R=-A(K3+1)
	T=A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
85	A(K2+1)=A(K2+1)+T
	IF(JLAST-1) 235,235,90
90	JJ= JJ + JJDIF
C
C	NOW DO THE REMAINING J'S
	DO 230 J=2,JLAST
C
C	FETCH W'S
C	DEF- W=W**INV(J), W2=W**2, W3=W**3
96	I=INV(J+1)
98	IC=NT-I
	W(1)=S(IC)
	W(2)=S(I)
	I2=2*I
	I2C=NT-I2
	IF(I2C)120,110,100
C
C	2*I IS IN FIRST QUADRANT
100	W2(1)=S(I2C)
	W2(2)=S(I2)
	GO TO 130
110	W2(1)=0.
	W2(2)=1.
	GO TO 130
C
C	2*I IS IN SECOND QUADRANT
120	I2CC = I2C+NT
	I2C=-I2C
	W2(1)=-S(I2C)
	W2(2)=S(I2CC)
130	I3=I+I2
	I3C=NT-I3
	IF(I3C)160,150,140
C
C	I3 IN FIRST QUADRANT
140	W3(1)=S(I3C)
	W3(2)=S(I3)
	GO TO 200
150	W3(1)=0.
	W3(2)=1.
	GO TO 200
C
160	I3CC=I3C+NT
	IF(I3CC)190,180,170
C
C	I3 IN SECOND QUADRANT
170	I3C=-I3C
	W3(1)=-S(I3C)
	W3(2)=S(I3CC)
	GO TO 200
180	W3(1)=-1.
	W3(2)=0.
	GO TO 200
C
C	3*I IN THIRD QUADRANT
190	I3CCC=NT+I3CC
	I3CC = -I3CC
	W3(1)=-S(I3CCC)
	W3(2)=-S(I3CC)
200	ILAST=IL+JJ
	DO 220 I=JJ,ILAST,IDIF
	KLAST=KL+I
	DO 220 K=I,KLAST,2
	K1=K+KBIT
	K2=K1+KBIT
	K3=K2+KBIT
C
C	DO TWO STEPS WITH J NOT 0
C	A(K)=A(K)+A(K2)*W2
C	A(K2)=A(K)-A(K2)*W2
C	A(K1)=A(K1)*W+A(K3)*W3
C	A(K3)=A(K1)*W-A(K3)*W3
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	R=A(K2)*W2(1)-A(K2+1)*W2(2)
	T=A(K2)*W2(2)+A(K2+1)*W2(1)
	A(K2)=A(K)-R
	A(K)=A(K)+R
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	R=A(K3)*W3(1)-A(K3+1)*W3(2)
	T=A(K3)*W3(2)+A(K3+1)*W3(1)
	AWR=A(K1)*W(1)-A(K1+1)*W(2)
	AWI=A(K1)*W(2)+A(K1+1)*W(1)
	A(K3)=AWR-R
	A(K3+1)=AWI-T
	A(K1)=AWR+R
	A(K1+1)=AWI+T
	T=A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
	R=-A(K3+1)
	T=A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
220	A(K2+1)=A(K2+1)+T
C	END OF I AND K LOOPS
C
230	JJ=JJDIF+JJ
C	END OF J-LOOP
C
235	JLAST=4*JLAST+3
240	CONTINUE
C	END OF  L  LOOP
C
250	CONTINUE
C	END OF  ID  LOOP
C
C	WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE
C	BIT-REVERSED.  THE FOLLOWING ROUTINE PUTS THEM IN ORDER
	NTSQ=NT*NT
	M3MT=M3-MT
350	IF(M3MT) 370,360,360
C
C	M3 GR. OR EQ. MT
360	IGO3=1
	N3VNT=N3/NT
	MINN3=NT
	GO TO 380
C
C	M3 LESS THAN MT
370	IGO3=2
	N3VNT=1
	NTVN3=NT/N3
	MINN3=N3
380	JJD3 = NTSQ/N3
	M2MT=M2-MT
450	IF (M2MT)470,460,460
C
C	M2 GR. OR EQ. MT
460	IGO2=1
	N2VNT=N2/NT
	MINN2=NT
	GO TO 480
C
C	M2 LESS THAN MT
470	IGO2 = 2
	N2VNT=1
	NTVN2=NT/N2
	MINN2=N2
480	JJD2=NTSQ/N2
	M1MT=M1-MT
550	IF(M1MT)570,560,560
C
C	M1 GR. OR EQ. MT
560	IGO1=1
	N1VNT=N1/NT
	MINN1=NT
	GO TO 580
C
C	M1 LESS THAN MT
570	IGO1=2
	N1VNT=1
	NTVN1=NT/N1
	MINN1=N1
580	JJD1=NTSQ/N1
600	JJ3=1
	J=1
	DO 880 JPP3=1,N3VNT
	IPP3=INV(JJ3)
	DO 870 JP3=1,MINN3
	GO TO (610,620),IGO3
610	IP3=INV(JP3)*N3VNT
	GO TO 630
620	IP3=INV(JP3)/NTVN3
630	I3=(IPP3+IP3)*N2
700	JJ2=1
	DO 870 JPP2=1,N2VNT
	IPP2=INV(JJ2)+I3
	DO 860 JP2=1,MINN2
	GO TO (710,720),IGO2
710	IP2=INV(JP2)*N2VNT
	GO TO 730
720	IP2=INV(JP2)/NTVN2
730	I2=(IPP2+IP2)*N1
800	JJ1=1
	DO 860 JPP1=1,N1VNT
	IPP1=INV(JJ1)+I2
	DO 850 JP1=1,MINN1
	GO TO (810,820),IGO1
810	IP1=INV(JP1)*N1VNT
	GO TO 830
820	IP1=INV(JP1)/NTVN1
830	I=2*(IPP1+IP1)+1
	IF (J-I) 840,850,850
840	T=A(I)
	A(I)=A(J)
	A(J)=T
	T=A(I+1)
	A(I+1)=A(J+1)
	A(J+1)=T
850	J=J+2
860	JJ1=JJ1+JJD1
C
870	JJ2=JJ2+JJD2
C	END OF JPP2 AND JP3 LOOPS
C
880	JJ3 = JJ3+JJD3
C	END OF JPP3 LOOP
C
890	IF(IFSET)891,895,895
891	DO 892 I = 1,NX
892	A(2*I) = -A(2*I)
895	RETURN
C
C	THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES.
C
900	MT=MAX0(M(1),M(2),M(3)) -2
	MT = MAX0(2,MT)
904	IF (MT-18) 906,906,13
906	IFERR=0
	NT=2**MT
	NTV2=NT/2
C
C	SET UP SIN TABLE
C	THETA=PIE/2**(L+1) FOR L=1
910	THETA=.7853981633974483
C
C	JSTEP=2**(MT-L+1) FOR L=1
	JSTEP=NT
C
C	JDIF=2**(MT-L) FOR L=1
	JDIF=NTV2
	S(JDIF)=DSIN(THETA)
	DO 950 L=2,MT
	THETA=THETA/2.0D0
	JSTEP2=JSTEP
	JSTEP=JDIF
	JDIF=JSTEP/2
	S(JDIF)=DSIN(THETA)
	JC1=NT-JDIF
	S(JC1)=DCOS(THETA)
	JLAST=NT-JSTEP2
	IF(JLAST - JSTEP) 950,920,920
920	DO 940 J=JSTEP,JLAST,JSTEP
	JC=NT-J
	JD=J+JDIF
940	S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC)
950	CONTINUE
C
C	SET UP INV(J) TABLE
C
960	MTLEXP=NTV2
C
C	MTLEXP=2**(MT-L). FOR L=1
	LM1EXP=1
C
C	LM1EXP=2**(L-1). FOR L=1
	INV(1)=0
	DO 980 L=1,MT
	INV(LM1EXP+1) = MTLEXP
	DO 970 J=2,LM1EXP
	JJ=J+LM1EXP
970	INV(JJ)=INV(J)+MTLEXP
	MTLEXP=MTLEXP/2
980	LM1EXP=LM1EXP*2
982	IF(IFSET)12,895,12
	END
C
C	..................................................................
C
C	   SUBROUTINE DHEP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL DHEP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              DOUBLE PRECISION VECTOR.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF HERMITE POLYNOMIAL
C	              DOUBLE PRECISION VARIABLE.
C	      N     - ORDER OF HERMITE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      HERMITE POLYNOMIALS H(N,X)
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X))
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X.
C
C	..................................................................
C
	SUBROUTINE DHEP(Y,X,N)
C
	DIMENSION Y(1)
	DOUBLE PRECISION Y,X,F
C
C	   TEST OF ORDER
	Y(1)=1.D0
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X+X
	IF(N-1)1,1,3
C
3	DO 4 I=2,N
	F=X*Y(I)-DFLOAT(I-1)*Y(I-1)
4	Y(I+1)=F+F
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DHEPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL DHEPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      X     - ARGUMENT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)).
C
C	..................................................................
C
	SUBROUTINE DHEPS(Y,X,C,N)
C
	DIMENSION C(1)
	DOUBLE PRECISION C,Y,X,H0,H1,H2
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.D0
	H1=X+X
C
	DO 4 I=2,N
	H2=X*H1-DFLOAT(I-1)*H0
	H0=H1
	H1=H2+H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DHPCG
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL
C	      DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
C
C	   USAGE
C	      CALL DHPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C	      PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
C	               DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
C	               SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
C	               ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
C	               OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
C	               SUBROUTINE DHPCG. EXCEPT PRMT(5) THE COMPONENTS
C	               ARE NOT DESTROYED BY SUBROUTINE DHPCG AND THEY ARE
C	      PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCG INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE DHPCG AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE DHPCG DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING DHPCG) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
C	               (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
C	               DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
C	               POINTS X.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
C	               (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
C	               EQUAL TO 1. LATERON DERY IS THE VECTOR OF
C	               DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
C	               INTERMEDIATE POINTS X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE DHPCG RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM
C	               TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST
C	               MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT
C	               DESTROY X AND Y.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE DHPCG IS TERMINATED.
C	      AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16
C	               ROWS AND NDIM COLUMNS.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
C	      OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
C	      CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
C	      PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
C	      DEPENDENT VARIABLES.
C	      FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
C	      USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
C	      COMPUTATION OF STARTING VALUES.
C	      SUBROUTINE DHPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING
C	      THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
C	      TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
C	      MUST BE CODED BY THE USER.
C	      FOR REFERENCE, SEE
C	      (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	           COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	           MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C
C	..................................................................
C
	SUBROUTINE DHPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C
C
	DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1)
	DOUBLE PRECISION Y,DERY,AUX,PRMT,X,H,Z,DELT
	N=1
	IHLF=0
	X=PRMT(1)
	H=PRMT(3)
	PRMT(5)=0.D0
	DO 1 I=1,NDIM
	AUX(16,I)=0.D0
	AUX(15,I)=DERY(I)
1	AUX(1,I)=Y(I)
	IF(H*(PRMT(2)-X))3,2,4
C
C	ERROR RETURNS
2	IHLF=12
	GOTO 4
3	IHLF=13
C
C	COMPUTATION OF DERY FOR STARTING VALUES
4	CALL FCT(X,Y,DERY)
C
C	RECORDING OF STARTING VALUES
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))6,5,6
5	IF(IHLF)7,7,6
6	RETURN
7	DO 8 I=1,NDIM
8	AUX(8,I)=DERY(I)
C
C	COMPUTATION OF AUX(2,I)
	ISW=1
	GOTO 100
C
9	X=X+H
	DO 10 I=1,NDIM
10	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
11	IHLF=IHLF+1
	X=X-H
	DO 12 I=1,NDIM
12	AUX(4,I)=AUX(2,I)
	H=.5D0*H
	N=1
	ISW=2
	GOTO 100
C
13	X=X+H
	CALL FCT(X,Y,DERY)
	N=2
	DO 14 I=1,NDIM
	AUX(2,I)=Y(I)
14	AUX(9,I)=DERY(I)
	ISW=3
	GOTO 100
C
C	COMPUTATION OF TEST VALUE DELT
15	DELT=0.D0
	DO 16 I=1,NDIM
16	DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I))
	DELT=.066666666666666667D0*DELT
	IF(DELT-PRMT(4))19,19,17
17	IF(IHLF-10)11,18,18
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
18	IHLF=11
	X=X+H
	GOTO 4
C
C	THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS.
19	X=X+H
	CALL FCT(X,Y,DERY)
	DO 20 I=1,NDIM
	AUX(3,I)=Y(I)
20	AUX(10,I)=DERY(I)
	N=3
	ISW=4
	GOTO 100
C
21	N=1
	X=X+H
	CALL FCT(X,Y,DERY)
	X=PRMT(1)
	DO 22 I=1,NDIM
	AUX(11,I)=DERY(I)
   22	Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
     1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
23	X=X+H
	N=N+1
	CALL FCT(X,Y,DERY)
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))6,24,6
24	IF(N-4)25,200,200
25	DO 26 I=1,NDIM
	AUX(N,I)=Y(I)
26	AUX(N+7,I)=DERY(I)
	IF(N-3)27,29,200
C
27	DO 28 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
28	Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 23
C
29	DO 30 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
30	Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 23
C
C	THE FOLLOWING PART OF SUBROUTINE DHPCG COMPUTES BY MEANS OF
C	RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
C	PREDICTOR-CORRECTOR METHOD.
100	DO 101 I=1,NDIM
	Z=H*AUX(N+7,I)
	AUX(5,I)=Z
101	Y(I)=AUX(N,I)+.4D0*Z
C	Z IS AN AUXILIARY STORAGE LOCATION
C
	Z=X+.4D0*H
	CALL FCT(Z,Y,DERY)
	DO 102 I=1,NDIM
	Z=H*DERY(I)
	AUX(6,I)=Z
102	Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*Z
C
	Z=X+.45573725421878943D0*H
	CALL FCT(Z,Y,DERY)
	DO 103 I=1,NDIM
	Z=H*DERY(I)
	AUX(7,I)=Z
103	Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
     1AUX(6,I)+3.8328647604670103D0*Z
C
	Z=X+H
	CALL FCT(Z,Y,DERY)
	DO 104 I=1,NDIM
  104	Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
     1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
     2H*DERY(I)
	GOTO(9,13,15,21),ISW
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
200	ISTEP=3
201	IF(N-8)204,202,204
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
202	DO 203 N=2,7
	DO 203 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
203	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
204	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 205 I=1,NDIM
	AUX(N-1,I)=Y(I)
205	AUX(N+6,I)=DERY(I)
	X=X+H
206	ISTEP=ISTEP+1
	DO 207 I=1,NDIM
     0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
     1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198347107438D0*AUX(16,I)
207	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
C
	CALL FCT(X,Y,DERY)
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
C
	DO 208 I=1,NDIM
     0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
     1+AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
208	Y(I)=DELT+.07438016528925620D0*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.D0
	DO 209 I=1,NDIM
209	DELT=DELT+AUX(15,I)*DABS(AUX(16,I))
	IF(DELT-PRMT(4))210,222,222
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
210	CALL FCT(X,Y,DERY)
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))212,211,212
211	IF(IHLF-11)213,212,212
212	RETURN
213	IF(H*(X-PRMT(2)))214,212,212
214	IF(DABS(X-PRMT(2))-.1D0*DABS(H))212,215,215
215	IF(DELT-.02D0*PRMT(4))216,216,201
C
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE
216	IF(IHLF)201,201,217
217	IF(N-7)201,218,218
218	IF(ISTEP-4)201,219,219
219	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)201,220,201
220	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 221 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  221	AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
     1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
	GOTO 201
C
C
C	H MUST BE HALVED
222	IHLF=IHLF+1
	IF(IHLF-10)223,223,210
223	H=.5D0*H
	ISTEP=0
	DO 224 I=1,NDIM
     0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
     1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
	AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
     1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
     218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
224	AUX(N+4,I)=AUX(N+5,I)
	X=X-H
	DELT=X-(H+H)
	CALL FCT(DELT,Y,DERY)
	DO 225 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
225	Y(I)=AUX(N-4,I)
	DELT=DELT-(H+H)
	CALL FCT(DELT,Y,DERY)
	DO 226 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
	AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
     1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
226	AUX(N+3,I)=DERY(I)
	GOTO 206
	END
C
C	..................................................................
C
C	   SUBROUTINE DHPCL
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR
C	      DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
C
C	   USAGE
C	      CALL DHPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
C	      PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
C	               DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
C	               SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
C	               ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
C	               OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
C	               SUBROUTINE DHPCL. EXCEPT PRMT(5) THE COMPONENTS
C	               ARE NOT DESTROYED BY SUBROUTINE DHPCL AND THEY ARE
C	      PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCL INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE DHPCL AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE DHPCL DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING DHPCL) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
C	               (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
C	               DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
C	               POINTS X.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
C	               (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
C	               EQUAL TO 1. LATERON DERY IS THE VECTOR OF
C	               DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
C	               INTERMEDIATE POINTS X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE DHPCL RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY.
C	      AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE
C	               RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
C	               ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE
C	               SHOULD NOT DESTROY X.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
C	               RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
C	               ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE
C	               SHOULD NOT DESTROY X.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE DHPCL IS TERMINATED.
C	      AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16
C	               ROWS AND NDIM COLUMNS.
C	      A      - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED
C	               AS AUXILIARY STORAGE ARRAY.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND
C	      OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
C	      CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
C	      PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
C	      DEPENDENT VARIABLES.
C	      FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
C	      USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
C	      COMPUTATION OF STARTING VALUES.
C	      SUBROUTINE DHPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING
C	      THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
C	      TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
C	      MUST BE CODED BY THE USER.
C	      FOR REFERENCE, SEE
C	      (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	           COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	           MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C
C	..................................................................
C
	SUBROUTINE DHPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
C
C
C	THE FOLLOWING FIRST PART OF SUBROUTINE DHPCL (UNTIL FIRST BREAK-
C	POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE
C	COMPUTATION
C
	DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1)
	DOUBLE PRECISION PRMT,Y,DERY,AUX,X,H,Z,DELT,A,HS
	GOTO 100
C
C	THIS PART OF SUBROUTINE DHPCL COMPUTES THE RIGHT HAND SIDE DERY OF
C	THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS.
1	CALL AFCT(X,A)
	CALL FCT(X,DERY)
	DO 3 M=1,NDIM
	LL=M-NDIM
	HS=0.D0
	DO 2 L=1,NDIM
	LL=LL+NDIM
2	HS=HS+A(LL)*Y(L)
3	DERY(M)=HS+DERY(M)
	GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
100	N=1
	IHLF=0
	X=PRMT(1)
	H=PRMT(3)
	PRMT(5)=0.D0
	DO 101 I=1,NDIM
	AUX(16,I)=0.D0
	AUX(15,I)=DERY(I)
101	AUX(1,I)=Y(I)
	IF(H*(PRMT(2)-X))103,102,104
C
C	ERROR RETURNS
102	IHLF=12
	GOTO 104
103	IHLF=13
C
C	COMPUTATION OF DERY FOR STARTING VALUES
104	ISW2=1
	GOTO 1
C
C	RECORDING OF STARTING VALUES
105	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))107,106,107
106	IF(IHLF)108,108,107
107	RETURN
108	DO 109 I=1,NDIM
C
109	AUX(8,I)=DERY(I)
C	COMPUTATION OF AUX(2,I)
	ISW1=1
	GOTO 200
110	X=X+H
	DO 111 I=1,NDIM
111	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
112	IHLF=IHLF+1
	X=X-H
	DO 113 I=1,NDIM
113	AUX(4,I)=AUX(2,I)
	H=.5D0*H
	N=1
	ISW1=2
	GOTO 200
C
114	X=X+H
	ISW2=5
	GOTO 1
115	N=2
	DO 116 I=1,NDIM
	AUX(2,I)=Y(I)
116	AUX(9,I)=DERY(I)
	ISW1=3
	GOTO 200
C
C	COMPUTATION OF TEST VALUE DELT
117	DELT=0.D0
	DO 118 I=1,NDIM
118	DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I))
	DELT=.066666666666666667D0*DELT
	IF(DELT-PRMT(4))121,121,119
119	IF(IHLF-10)112,120,120
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
120	IHLF=11
	X=X+H
	GOTO 104
C
C	SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
121	X=X+H
	ISW2=6
	GOTO 1
122	DO 123 I=1,NDIM
	AUX(3,I)=Y(I)
123	AUX(10,I)=DERY(I)
	N=3
	ISW1=4
	GOTO 200
C
124	N=1
	X=X+H
	ISW2=7
	GOTO 1
125	X=PRMT(1)
	DO 126 I=1,NDIM
	AUX(11,I)=DERY(I)
  126	Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
     1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
127	X=X+H
	N=N+1
	ISW2=12
	GOTO 1
128	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))107,129,107
129	IF(N-4)130,300,300
130	DO 131 I=1,NDIM
	AUX(N,I)=Y(I)
131	AUX(N+7,I)=DERY(I)
	IF(N-3)132,134,300
C
132	DO 133 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
133	Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 127
C
134	DO 135 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
135	Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 127
C
C	THE FOLLOWING PART OF SUBROUTINE DHPCL COMPUTES BY MEANS OF
C	RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
C	PREDICTOR-CORRECTOR METHOD.
200	Z=X
	DO 201 I=1,NDIM
	X=H*AUX(N+7,I)
	AUX(5,I)=X
201	Y(I)=AUX(N,I)+.4D0*X
C	X IS AN AUXILIARY STORAGE LOCATION
C
	X=Z+.4D0*H
	ISW2=2
	GOTO 1
202	DO 203 I=1,NDIM
	X=H*DERY(I)
	AUX(6,I)=X
203	Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X
C
	X=Z+.45573725421878943D0*H
	ISW2=3
	GOTO 1
204	DO 205 I=1,NDIM
	X=H*DERY(I)
	AUX(7,I)=X
205	Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
     1AUX(6,I)+3.8328647604670103D0*X
C
	X=Z+H
	ISW2=4
	GOTO 1
206	DO 207 I=1,NDIM
  207	Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
     1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
     2H*DERY(I)
	X=Z
	GOTO(110,114,117,124),ISW1
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
300	ISTEP=3
301	IF(N-8)304,302,304
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
302	DO 303 N=2,7
	DO 303 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
303	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
304	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 305 I=1,NDIM
	AUX(N-1,I)=Y(I)
305	AUX(N+6,I)=DERY(I)
	X=X+H
306	ISTEP=ISTEP+1
	DO 307 I=1,NDIM
	DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
     1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198347107438D0*AUX(16,I)
307	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
	ISW2=8
	GOTO 1
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
C
308	DO 309 I=1,NDIM
	DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
     1+AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
309	Y(I)=DELT+.07438016528925620D0*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.D0
	DO 310 I=1,NDIM
310	DELT=DELT+AUX(15,I)*DABS(AUX(16,I))
	IF(DELT-PRMT(4))311,324,324
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
311	ISW2=9
	GOTO 1
312	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))314,313,314
313	IF(IHLF-11)315,314,314
314	RETURN
315	IF(H*(X-PRMT(2)))316,314,314
316	IF(DABS(X-PRMT(2))-.1D0*DABS(H))314,317,317
317	IF(DELT-.02D0*PRMT(4))318,318,301
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE
318	IF(IHLF)301,301,319
319	IF(N-7)301,320,320
320	IF(ISTEP-4)301,321,321
321	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)301,322,301
322	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 323 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  323	AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
     1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
	GOTO 301
C
C	H MUST BE HALVED
324	IHLF=IHLF+1
	IF(IHLF-10)325,325,311
325	H=.5D0*H
	ISTEP=0
	DO 326 I=1,NDIM
     	Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
     1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
     	AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
     1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
     218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
326	AUX(N+4,I)=AUX(N+5,I)
	DELT=X-H
	X=DELT-(H+H)
	ISW2=10
	GOTO 1
327	DO 328 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
328	Y(I)=AUX(N-4,I)
	X=X-(H+H)
	ISW2=11
	GOTO 1
329	X=DELT
	DO 330 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
     	AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
     1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
330	AUX(N+3,I)=DERY(I)
	GOTO 306
	END
C
C	..................................................................
C
C	   SUBROUTINE DISCR
C
C	   PURPOSE
C	      COMPUTE A SET OF LINEAR FUNCTIONS WHICH SERVE AS INDICES
C	      FOR CLASSIFYING AN INDIVIDUAL INTO ONE OF SEVERAL GROUPS.
C	      NORMALLY THIS SUBROUTINE IS USED IN THE PERFORMANCE OF
C	      DISCRIMINANT ANALYSIS.
C
C	   USAGE
C	      CALL DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG)
C
C	   DESCRIPTION OF PARAMETERS
C	      K     - NUMBER OF GROUPS. K MUST BE GREATER THAN ONE.
C	      M     - NUMBER OF VARIABLES
C	      N     - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF
C	              GROUPS.
C	      X     - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA-
C	              LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1),
C	              X(2,1,1), X(3,1,1), ETC.  THE FIRST SUBSCRIPT IS
C	              CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER
C	              AND THE THIRD SUBSCRIPT IS GROUP NUMBER.  THE
C	              LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF
C	              DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K).
C	      XBAR  - INPUT MATRIX (M X K) CONTAINING MEANS OF M VARIABLES
C	              IN K GROUPS
C	      D     - INPUT MATRIX (M X M) CONTAINING THE INVERSE OF
C	              POOLED DISPERSION MATRIX.
C	      CMEAN - OUTPUT VECTOR OF LENGTH M CONTAINING COMMON MEANS.
C	      V     - OUTPUT VARIABLE CONTAINING GENERALIZED MAHALANOBIS
C	              D-SQUARE.
C	      C     - OUTPUT MATRIX (M+1 X K) CONTAINING THE COEFFICIENTS
C	              OF DISCRIMINANT FUNCTIONS.  THE FIRST POSITION OF
C	              EACH COLUMN (FUNCTION) CONTAINS THE VALUE OF THE
C	              CONSTANT FOR THAT FUNCTION.
C	      P     - OUTPUT VECTOR CONTAINING THE PROBABILITY ASSOCIATED
C	              WITH THE LARGEST DISCRIMINANT FUNCTIONS OF ALL CASES
C	              IN ALL GROUPS.  CALCULATED RESULTS ARE STORED IN THE
C	              MANNER EQUIVALENT TO A 2-DIMENSIONAL AREA (THE
C	              FIRST SUBSCRIPT IS CASE NUMBER, AND THE SECOND
C	              SUBSCRIPT IS GROUP NUMBER).  VECTOR P HAS LENGTH
C	              EQUAL TO THE TOTAL NUMBER OF CASES, T (T = N(1)+N(2)
C	              +...+N(K)).
C	      LG    - OUTPUT VECTOR CONTAINING THE SUBSCRIPTS OF THE
C	              LARGEST DISCRIMINANT FUNCTIONS STORED IN VECTOR P.
C	              THE LENGTH OF VECTOR LG IS THE SAME AS THE LENGTH
C	              OF VECTOR P.
C
C	   REMARKS
C	      THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO
C	      THE NUMBER OF GROUPS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
C	      DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO
C	      MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS,
C	      1958, SECTION 6.6-6.8.
C
C	..................................................................
C
	SUBROUTINE DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG)
	DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1),C(1),P(1),LG(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION XBAR,D,CMEAN,V,C,SUM,P,PL
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  EXP IN STATEMENT
C	   250 MUST BE CHANGED TO DEXP.
C
C	   ...............................................................
C
C	CALCULATE COMMON MEANS
C
	N1=N(1)
	DO 100 I=2,K
100	N1=N1+N(I)
	FNT=N1
	DO 110 I=1,K
110	P(I)=N(I)
	DO 130 I=1,M
	CMEAN(I)=0
	N1=I-M
	DO 120 J=1,K
	N1=N1+M
120	CMEAN(I)=CMEAN(I)+P(J)*XBAR(N1)
130	CMEAN(I)=CMEAN(I)/FNT
C
C	CALCULATE GENERALIZED MAHALANOBIS D SQUARE
C
	L=0
	DO 140 I=1,K
	DO 140 J=1,M
	L=L+1
140	C(L)=XBAR(L)-CMEAN(J)
	V=0.0
	L=0
	DO 160 J=1,M
	DO 160 I=1,M
	N1=I-M
	N2=J-M
	SUM=0.0
	DO 150 IJ=1,K
	N1=N1+M
	N2=N2+M
150	SUM=SUM+P(IJ)*C(N1)*C(N2)
	L=L+1
160	V=V+D(L)*SUM
C
C	CALCULATE THE COEFFICIENTS OF DISCRIMINANT FUNCTIONS
C
	N2=0
	DO 190 KA=1,K
	DO 170 I=1,M
	N2=N2+1
170	P(I)=XBAR(N2)
	IQ=(M+1)*(KA-1)+1
	SUM=0.0
	DO 180 J=1,M
	N1=J-M
	DO 180 L=1,M
	N1=N1+M
180	SUM=SUM+D(N1)*P(J)*P(L)
	C(IQ)=-(SUM/2.0)
	DO 190 I=1,M
	N1=I-M
	IQ=IQ+1
	C(IQ)=0.0
	DO 190 J=1,M
	N1=N1+M
190	C(IQ)=C(IQ)+D(N1)*P(J)
C
C	FOR EACH CASE IN EACH GROUP, CALCULATE..
C
C	   DISCRIMINANT FUNCTIONS
C
	LBASE=0
	N1=0
	DO 270 KG=1,K
	NN=N(KG)
	DO 260 I=1,NN
	L=I-NN+LBASE
	DO 200 J=1,M
	L=L+NN
200	D(J)=X(L)
	N2=0
	DO 220 KA=1,K
	N2=N2+1
	SUM=C(N2)
	DO 210 J=1,M
	N2=N2+1
210	SUM=SUM+C(N2)*D(J)
220	XBAR(KA)=SUM
C
C	   THE LARGEST DISCRIMINANT FUNCTION
C
	L=1
	SUM=XBAR(1)
	DO 240 J=2,K
	IF(SUM-XBAR(J)) 230, 240, 240
230	L=J
	SUM=XBAR(J)
240	CONTINUE
C
C	   PROBABILITY ASSOCIATED WITH THE LARGEST DISCRIMINANT FUNCTION
C
	PL=0.0
	DO 250 J=1,K
250	PL=PL+ EXP(XBAR(J)-SUM)
	N1=N1+1
	LG(N1)=L
260	P(N1)=1.0/PL
270	LBASE=LBASE+NN*M
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DJELF
C
C	   PURPOSE
C	      COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN.
C
C	   USAGE
C	      CALL DJELF(SN,CN,DN,X,SCK)
C
C	   DESCRIPTION OF PARAMETERS
C	      SN    - RESULT VALUE SN(X) IN DOUBLE PRECISION
C	      CN    - RESULT VALUE CN(X) IN DOUBLE PRECISION
C	      DN    - RESULT VALUE DN(X) IN DOUBLE PRECISION
C	      X     - DOUBLE PRECISION ARGUMENT OF JACOBIAN ELLIPTIC
C	              FUNCTIONS
C	      SCK   - SQUARE OF COMPLEMENTARY MODULUS IN DOUBLE PRECISION
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER
C	      T FROM 0 TO SN), WHERE K=SQRT(1-SCK).
C	      SN*SN + CN*CN = 1
C	      (K*SN)**2 + DN**2 = 1.
C	      EVALUATION
C	      CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC
C	      GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION
C	      BEFORE INVERSION OF THE INTEGRAL TAKES PLACE.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIOMS.
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE DJELF(SN,CN,DN,X,SCK)
C
	DIMENSION ARI(12),GEO(12)
	DOUBLE PRECISION SN,CN,DN,X,SCK,ARI,GEO,CM,Y,A,B,C,D
C
C	   TEST MODULUS
C
	CM=SCK
	Y=X
	IF(SCK)3,1,4
1	D=DEXP(X)
	A=1.D0/D
	B=A+D
	CN=2.D0/B
	DN=CN
	A=(D-A)/2.D0
	SN=A*CN
C	   DEGENERATE CASE SCK=0 GIVES RESULTS
C	      CN X = DN X = 1/COSH X
C	      SN X = TANH X
2	RETURN
C
C	   JACOBIS MODULUS TRANSFORMATION
C
3	D=1.D0-SCK
	CM=-SCK/D
	D=DSQRT(D)
	Y=D*X
4	A=1.D0
	DN=1.D0
	DO 6 I=1,12
	L=I
	ARI(I)=A
	CM=DSQRT(CM)
	GEO(I)=CM
	C=(A+CM)*.5D0
	IF(DABS(A-CM)-1.D-9*A)7,7,5
5	CM=A*CM
6	A=C
C
C	   START BACKWARD RECURSION
C
7	Y=C*Y
	SN=DSIN(Y)
	CN=DCOS(Y)
	IF(SN)8,13,8
8	A=CN/SN
	C=A*C
	DO 9 I=1,L
	K=L-I+1
	B=ARI(K)
	A=C*A
	C=DN*C
	DN=(GEO(K)+A)/(B+A)
9	A=C/B
	A=1.D0/DSQRT(C*C+1.D0)
	IF(SN)10,11,11
10	SN=-A
	GOTO 12
11	SN=A
12	CN=C*SN
13	IF(SCK)14,2,2
14	A=DN
	DN=CN
	CN=A
	SN=SN/D
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLAP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE LAGUERRE POLYNOMIALS L(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL DLAP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF LAGUERRE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              DOUBLE PRECISION VECTOR.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF LAGUERRE POLYNOMIAL
C	              DOUBLE PRECISION VARIABLE.
C	      N     - ORDER OF LAGUERRE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      LAGUERRE POLYNOMIALS L(N,X)
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE L(0,X)=1, L(1,X)=1.-X.
C
C	..................................................................
C
	SUBROUTINE DLAP(Y,X,N)
C
	DIMENSION Y(1)
	DOUBLE PRECISION Y,X,T
C
C	   TEST OF ORDER
	Y(1)=1.D0
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=1.D0-X
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	T=1.D0+X
C
	DO 4 I=2,N
4	Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/DFLOAT(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLAPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LAGUERRE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL DLAPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      X     - ARGUMENT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR LAGUERRE POLYNOMIALS
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1).
C
C	..................................................................
C
	SUBROUTINE DLAPS(Y,X,C,N)
C
	DIMENSION C(1)
	DOUBLE PRECISION C,Y,X,H0,H1,H2,T
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.D0
	H1=1.D0-X
	T=1.D0+X
	DO 4 I=2,N
	H2=H1-H0+H1-(T*H1-H0)/DFLOAT(I)
	H0=H1
	H1=H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLBVP
C
C	   PURPOSE
C	      TO SOLVE A LINEAR BOUNDARY VALUE PROBLEM, WHICH CONSISTS OF
C	      A SYSTEM OF NDIM LINEAR FIRST ORDER DIFFERENTIAL EQUATIONS
C	             DY/DX=A(X)*Y(X)+F(X)
C	      AND NDIM LINEAR BOUNDARY CONDITIONS
C	             B*Y(XL)+C*Y(XU)=R.
C
C	   USAGE
C	      CALL DLBVP (PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
C	                 AUX,A)
C	      PARAMETERS AFCT,FCT,DFCT,OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
C	               DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
C	               SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
C	               ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
C	               OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
C	               SUBROUTINE DLBVP. EXCEPT PRMT(5) THE COMPONENTS
C	               ARE NOT DESTROYED BY SUBROUTINE DLBVP AND THEY ARE
C	      PRMT(1)- LOWER BOUND XL OF THE INTERVAL (INPUT),
C	      PRMT(1)- UPPER BOUND XU OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF RELATIVE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND RELATIVE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DLBVP INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE DLBVP AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE DLBVP DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING DLBVP) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      B      - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX
C	               (DESTROYED). IT IS THE COEFFICIENT MATRIX OF Y(XL)
C	               IN THE BOUNDARY CONDITIONS.
C	      C      - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX
C	               (POSSIBLY DESTROYED). IT IS THE COEFFICIENT MATRIX
C	               OF Y(XU) IN THE BOUNDARY CONDITIONS.
C	      R      - DOUBLE PRECISION INPUT VECTOR WITH DIMENSION NDIM
C	               (DESTROYED). IT SPECIFIES THE RIGHT HAND SIDE OF
C	               THE BOUNDARY CONDITIONS.
C	      Y      - DOUBLE PRECISION AUXILIARY VECTOR WITH
C	               DIMENSION NDIM. IT IS USED AS STORAGE LOCATION
C	               FOR THE RESULTING VALUES OF DEPENDENT VARIABLES
C	               COMPUTED AT INTERMEDIATE POINTS X.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
C	               (DESTROYED). ITS MAXIMAL COMPONENT SHOULD BE
C	               EQUAL TO 1. LATERON DERY IS THE VECTOR OF
C	               DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
C	               INTERMEDIATE POINTS X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               DIFFERENTIAL EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE DLBVP RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY. FINALLY ERROR MESSAGE
C	               IHLF=14 INDICATES, THAT THERE IS NO SOLUTION OR
C	               THAT THERE ARE MORE THAN ONE SOLUTION OF THE
C	               PROBLEM.
C	               A NEGATIVE VALUE OF IHLF HANDED TO SUBROUTINE OUTP
C	               TOGETHER WITH INITIAL VALUES OF FINALLY GENERATED
C	               INITIAL VALUE PROBLEM INDICATES, THAT THERE WAS
C	               POSSIBLE LOSS OF SIGNIFICANCE IN THE SOLUTION OF
C	               THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS FOR
C	               THESE INITIAL VALUES. THE ABSOLUTE VALUE OF IHLF
C	               SHOWS, AFTER WHICH ELIMINATION STEP OF GAUSS
C	               ALGORITHM POSSIBLE LOSS OF SIGNIFICANCE WAS
C	               DETECTED.
C	      AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES THE COEFFICIENT MATRIX A OF VECTOR Y ON
C	               THE RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
C	               EQUATIONS FOR A GIVEN X-VALUE. ITS PARAMETER LIST
C	               MUST BE X,A. SUBROUTINE AFCT SHOULD NOT DESTROY X.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
C	               RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
C	               EQUATIONS) FOR A GIVEN X-VALUE. ITS PARAMETER LIST
C	               MUST BE X,F. SUBROUTINE FCT SHOULD NOT DESTROY X.
C	      DFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR DF (DERIVATIVE OF THE INHOMOGENEOUS
C	               PART ON THE RIGHT HAND SIDE OF THE SYSTEM OF
C	               DIFFERENTIAL EQUATIONS) FOR A GIVEN X-VALUE. ITS
C	               PARAMETER LIST MUST BE X,DF. SUBROUTINE DFCT
C	               SHOULD NOT DESTROY X.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE DLBVP IS TERMINATED.
C	      AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 20
C	               ROWS AND NDIM COLUMNS.
C	      A      - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED
C	               AS AUXILIARY STORAGE ARRAY.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR IF IT HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THERE IS NO OR MORE THAN ONE SOLUTION OF THE PROBLEM
C	          (ERROR MESSAGE IHLF=14),
C	      (4) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (5) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SUBROUTINE DGELG     SYSTEM OF LINEAR EQUATIONS.
C	      THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F), DFCT(X,DF),
C	      AND OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE USING THE METHOD OF ADJOINT EQUATIONS.
C	      HAMMINGS FOURTH ORDER MODIFIED PREDICTOR-CORRECTOR METHOD
C	      IS USED TO SOLVE THE ADJOINT INITIAL VALUE PROBLEMS AND FI-
C	      NALLY TO SOLVE THE GENERATED INITIAL VALUE PROBLEM FOR Y(X).
C	      THE INITIAL INCREMENT PRMT(3) IS AUTOMATICALLY ADJUSTED.
C	      FOR COMPUTATION OF INTEGRAL SUM, A FOURTH ORDER HERMITEAN
C	      INTEGRATION FORMULA IS USED.
C	      FOR REFERENCE, SEE
C	      (1) LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
C	          ILIFFE, LONDON, 1960, PP.64-67.
C	      (2) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	          COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (3) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	          MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C	      (4) ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-232.
C
C	..................................................................
C
	SUBROUTINE DLBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
     1AUX,A)
C
C
	DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1)
	DOUBLE PRECISION PRMT,B,C,R,Y,DERY,AUX,A,H,X,Z,GL,HS,GU,SUM,
     1DGL,DGU,XST,XEND,DELT
C
C	ERROR TEST
	IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3
1	IHLF=12
	RETURN
2	IHLF=13
	RETURN
C
C	SEARCH FOR ZERO-COLUMNS IN MATRICES B AND C
3	KK=-NDIM
	IB=0
	IC=0
	DO 7 K=1,NDIM
	AUX(15,K)=DERY(K)
	AUX(1,K)=1.D0
	AUX(17,K)=1.D0
	KK=KK+NDIM
	DO 4 I=1,NDIM
	II=KK+I
	IF(B(II))5,4,5
4	CONTINUE
	IB=IB+1
	AUX(1,K)=0.D0
5	DO 6 I=1,NDIM
	II=KK+I
	IF(C(II))7,6,7
6	CONTINUE
	IC=IC+1
	AUX(17,K)=0.D0
7	CONTINUE
C
C	DETERMINATION OF LOWER AND UPPER BOUND
	IF(IC-IB)8,11,11
8	H=PRMT(2)
	PRMT(2)=PRMT(1)
	PRMT(1)=H
	PRMT(3)=-PRMT(3)
	DO 9 I=1,NDIM
9	AUX(17,I)=AUX(1,I)
	II=NDIM*NDIM
	DO 10 I=1,II
	H=B(I)
	B(I)=C(I)
10	C(I)=H
C
C	PREPARATIONS FOR CONSTRUCTION OF ADJOINT INITIAL VALUE PROBLEMS
11	X=PRMT(2)
	CALL FCT(X,Y)
	CALL DFCT(X,DERY)
	DO 12 I=1,NDIM
	AUX(18,I)=Y(I)
12	AUX(19,I)=DERY(I)
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	THE FOLLOWING PART OF SUBROUTINE DLBVP UNTIL NEXT BREAK-POINT FOR
C	LINKAGE HAS TO REMAIN IN CORE DURING THE WHOLE REST OF THE
C	COMPUTATIONS
C
C	START LOOP FOR GENERATING ADJOINT INITIAL VALUE PROBLEMS
	K=0
	KK=0
100	K=K+1
	IF(AUX(17,K))108,108,101
C
C	INITIALIZATION OF ADJOINT INITIAL VALUE PROBLEM
101	X=PRMT(2)
	CALL AFCT(X,A)
	SUM=0.D0
	GL=AUX(18,K)
	DGL=AUX(19,K)
	II=K
	DO 104 I=1,NDIM
	H=-A(II)
	DERY(I)=H
	AUX(20,I)=R(I)
	Y(I)=0.D0
	IF(I-K)103,102,103
102	Y(I)=1.D0
103	DGL=DGL+H*AUX(18,I)
104	II=II+NDIM
	XEND=PRMT(1)
	H=.0625D0*(XEND-X)
	ISW=0
	GOTO 400
C	THIS IS BRANCH TO ADJOINT LINEAR INITIAL VALUE PROBLEM
C
C	THIS IS RETURN FROM ADJOINT LINEAR INITIAL VALUE PROBLEM
105	IF(IHLF-10)106,106,117
C
C	UPDATING OF COEFFICIENT MATRIX B AND VECTOR R
106	DO 107 I=1,NDIM
	KK=KK+1
	H=C(KK)
	R(I)=AUX(20,I)+H*SUM
	II=I
	DO 107 J=1,NDIM
	B(II)=B(II)+H*Y(J)
107	II=II+NDIM
	GOTO 109
108	KK=KK+NDIM
109	IF(K-NDIM)100,110,110
C
C
C	GENERATION OF LAST INITIAL VALUE PROBLEM
110	EPS=PRMT(4)
	CALL DGELG(R,B,NDIM,1,EPS,I)
	IF(I)111,112,112
111	IHLF=14
	RETURN
C
112	PRMT(5)=0.D0
	IHLF=-I
	X=PRMT(1)
	XEND=PRMT(2)
	H=PRMT(3)
	DO 113 I=1,NDIM
113	Y(I)=R(I)
	ISW=1
114	ISW2=12
	GOTO 200
115	ISW3=-1
	GOTO 300
116	IF(IHLF)400,400,117
C	THIS WAS BRANCH INTO INITIAL VALUE PROBLEM
C
C	THIS IS RETURN FROM INITIAL VALUE PROBLEM
117	RETURN
C
C	THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE RIGHT
C	HAND SIDE DERY OF THE SYSTEM OF ADJOINT LINEAR DIFFERENTIAL
C	EQUATIONS (IN CASE ISW=0) OR OF THE GIVEN SYSTEM (IN CASE ISW=1).
200	CALL AFCT(X,A)
	IF(ISW)201,201,205
C
C	ADJOINT SYSTEM
201	LL=0
	DO 203 M=1,NDIM
	HS=0.D0
	DO 202 L=1,NDIM
	LL=LL+1
202	HS=HS-A(LL)*Y(L)
203	DERY(M)=HS
204	GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2
C
C	GIVEN SYSTEM
205	CALL FCT(X,DERY)
	DO 207 M=1,NDIM
	LL=M-NDIM
	HS=0.D0
	DO 206 L=1,NDIM
	LL=LL+NDIM
206	HS=HS+A(LL)*Y(L)
207	DERY(M)=HS+DERY(M)
	GOTO 204
C
C	THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE VALUE OF
C	INTEGRAL SUM, WHICH IS A PART OF THE OUTPUT OF ADJOINT INITIAL
C	VALUE PROBLEM (IN CASE ISW=0) OR RECORDS RESULT VALUES OF THE
C	FINAL INITIAL VALUE PROBLEM (IN CASE ISW=1).
300	IF(ISW)301,301,305
C
C	ADJOINT PROBLEM
301	CALL FCT(X,R)
	GU=0.D0
	DGU=0.D0
	DO 302 L=1,NDIM
	GU=GU+Y(L)*R(L)
302	DGU=DGU+DERY(L)*R(L)
	CALL DFCT(X,R)
	DO 303 L=1,NDIM
303	DGU=DGU+Y(L)*R(L)
	SUM=SUM+.5D0*H*((GL+GU)+.16666666666666667D0*H*(DGL-DGU))
	GL=GU
	DGL=DGU
304	IF(ISW3)116,422,618
C
C	GIVEN PROBLEM
305	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))117,304,117
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	THE FOLLOWING PART OF SUBROUTINE DLBVP SOLVES IN CASE ISW=0 THE
C	ADJOINT INITIAL VALUE PROBLEM. IT COMPUTES INTEGRAL SUM AND
C	THE VECTOR Y OF DEPENDENT VARIABLES AT THE LOWER BOUND PRMT(1).
C	IN CASE ISW=1 IT SOLVES FINALLY GENERATED INITIAL VALUE PROBLEM.
400	N=1
	XST=X
	IHLF=0
	DO 401 I=1,NDIM
	AUX(16,I)=0.D0
	AUX(1,I)=Y(I)
401	AUX(8,I)=DERY(I)
	ISW1=1
	GOTO 500
C
402	X=X+H
	DO 403 I=1,NDIM
403	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
404	IHLF=IHLF+1
	X=X-H
	DO 405 I=1,NDIM
405	AUX(4,I)=AUX(2,I)
	H=.5D0*H
	N=1
	ISW1=2
	GOTO 500
C
406	X=X+H
	ISW2=4
	GOTO 200
407	N=2
	DO 408 I=1,NDIM
	AUX(2,I)=Y(I)
408	AUX(9,I)=DERY(I)
	ISW1=3
	GOTO 500
C
C	TEST ON SATISFACTORY ACCURACY
409	DO 414 I=1,NDIM
	Z=DABS(Y(I))
	IF(Z-1.D0)410,411,411
410	Z=1.D0
411	DELT=.066666666666666667D0*DABS(Y(I)-AUX(4,I))
	IF(ISW)413,413,412
412	DELT=AUX(15,I)*DELT
413	IF(DELT-Z*PRMT(4))414,414,429
414	CONTINUE
C
C	SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
	X=X+H
	ISW2=5
	GOTO 200
415	DO 416 I=1,NDIM
	AUX(3,I)=Y(I)
416	AUX(10,I)=DERY(I)
	N=3
	ISW1=4
	GOTO 500
C
417	N=1
	X=X+H
	ISW2=6
	GOTO 200
418	X=XST
	DO 419 I=1,NDIM
	AUX(11,I)=DERY(I)
  419	Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I)
     1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I))
420	X=X+H
	N=N+1
	ISW2=11
	GOTO 200
421	ISW3=0
	GOTO 300
422	IF(N-4)423,600,600
423	DO 424 I=1,NDIM
	AUX(N,I)=Y(I)
424	AUX(N+7,I)=DERY(I)
	IF(N-3)425,427,600
C
425	DO 426 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
426	Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 420
C
427	DO 428 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
428	Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 420
C
C	NO SATISFACTORY ACCURACY. H MUST BE HALVED.
429	IF(IHLF-10)404,430,430
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
430	IHLF=11
	X=X+H
	IF(ISW)105,105,114
C
C	THIS PART OF LINEAR INITIAL VALUE PROBLEM COMPUTES
C	STARTING VALUES BY MEANS OF RUNGE-KUTTA METHOD.
500	Z=X
	DO 501 I=1,NDIM
	X=H*AUX(N+7,I)
	AUX(5,I)=X
501	Y(I)=AUX(N,I)+.4D0*X
C
	X=Z+.4D0*H
	ISW2=1
	GOTO 200
502	DO 503 I=1,NDIM
	X=H*DERY(I)
	AUX(6,I)=X
503	Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X
C
	X=Z+.45573725421878943D0*H
	ISW2=2
	GOTO 200
504	DO 505 I=1,NDIM
	X=H*DERY(I)
	AUX(7,I)=X
505	Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0*
     1AUX(6,I)+3.8328647604670103D0*X
C
	X=Z+H
	ISW2=3
	GOTO 200
506	DO 507 I=1,NDIM
  507	Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0*
     1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0*
     2H*DERY(I)
	X=Z
	GOTO(402,406,409,417),ISW1
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
600	ISTEP=3
601	IF(N-8)604,602,604
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
602	DO 603 N=2,7
	DO 603 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
603	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
604	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 605 I=1,NDIM
	AUX(N-1,I)=Y(I)
605	AUX(N+6,I)=DERY(I)
	X=X+H
606	ISTEP=ISTEP+1
	DO 607 I=1,NDIM
	DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)-
     1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198347107438D0*AUX(16,I)
607	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
C
	ISW2=7
	GOTO 200
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY.
C
608	DO 609 I=1,NDIM
	DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I)
     1+AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
609	Y(I)=DELT+.07438016528925620D0*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.D0
	DO 616 I=1,NDIM
	Z=DABS(Y(I))
	IF(Z-1.D0)610,611,611
610	Z=1.D0
611	Z=DABS(AUX(16,I))/Z
	IF(ISW)613,613,612
612	Z=AUX(15,I)*Z
613	IF(Z-PRMT(4))614,614,628
614	IF(DELT-Z)615,616,616
615	DELT=Z
616	CONTINUE
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
	ISW2=8
	GOTO 200
617	ISW3=1
	GOTO 300
618	IF(H*(X-XEND))619,621,621
619	IF(DABS(X-XEND)-.1D0*DABS(H))621,620,620
620	IF(DELT-.02D0*PRMT(4))622,622,601
621	IF(ISW)105,105,117
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE.
622	IF(IHLF)601,601,623
623	IF(N-7)601,624,624
624	IF(ISTEP-4)601,625,625
625	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)601,626,601
626	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 627 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  627	AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I))
     1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I))
	GOTO 601
C
C	H MUST BE HALVED
628	IHLF=IHLF+1
	IF(IHLF-10)630,630,629
629	IF(ISW)105,105,114
630	H=.5D0*H
	ISTEP=0
	DO 631 I=1,NDIM
	Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I)
     1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H
     	AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+
     1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+
     218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
631	AUX(N+4,I)=AUX(N+5,I)
	DELT=X-H
	X=DELT-(H+H)
	ISW2=9
	GOTO 200
632	DO 633 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
633	Y(I)=AUX(N-4,I)
	X=X-(H+H)
	ISW2=10
	GOTO 200
634	X=DELT
	DO 635 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
     	AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I))
     1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I))
635	AUX(N+3,I)=DERY(I)
	GOTO 606
C	END OF INITIAL VALUE PROBLEM
	END
C
C	..................................................................
C
C	   SUBROUTINE DLEP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE LEGENDRE POLYNOMIALS P(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL DLEP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF LEGENDRE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              DOUBLE PRECISION VECTOR.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF LEGENDRE POLYNOMIAL
C	              DOUBLE PRECISION VARIABLE.
C	      N     - ORDER OF LEGENDRE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      LEGENDRE POLYNOMIALS P(N,X)
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
C
C	..................................................................
C
	SUBROUTINE DLEP(Y,X,N)
C
	DIMENSION Y(1)
	DOUBLE PRECISION Y,X,G
C
C	   TEST OF ORDER
	Y(1)=1.D0
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X
	IF(N-1)1,1,3
C
3	DO 4 I=2,N
	G=X*Y(I)
4	Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/DFLOAT(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLEPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LEGENDRE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL DLEPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      X     - ARGUMENT VALUE
C	              DOUBLE PRECISION VARIABLE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR LEGENDRE POLYNOMIALS
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1).
C
C	..................................................................
C
	SUBROUTINE DLEPS(Y,X,C,N)
C
	DIMENSION C(1)
	DOUBLE PRECISION C,Y,X,H0,H1,H2
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.D0
	H1=X
C
	DO 4 I=2,N
	H2=X*H1
	H2=H2-H0+H2-(H2-H0)/DFLOAT(I)
	H0=H1
	H1=H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLGAM
C
C	   PURPOSE
C	      COMPUTES THE DOUBLE PRECISION NATURAL LOGARITHM OF THE
C	      GAMMA FUNCTION OF A GIVEN DOUBLE PRECISION ARGUMENT.
C
C	   USAGE
C	      CALL DLGAM(XX,DLNG,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      XX   - THE DOUBLE PRECISION ARGUMENT FOR THE LOG GAMMA
C	             FUNCTION.
C	      DLNG - THE RESULTANT DOUBLE PRECISION LOG GAMMA FUNCTION
C	             VALUE.
C	      IER  - RESULTANT ERROR CODE WHERE
C	             IER= 0----NO ERROR.
C	             IER=-1----XX IS WITHIN 10**(-9) OF BEING ZERO OR XX
C	                       IS NEGATIVE.  DLNG IS SET TO -1.OD75.
C	             IER=+1----XX IS GREATER THAN 10**70. DLNG IS SET TO
C	                       +1.OD75.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE EULER-MCLAURIN EXPANSION TO THE SEVENTH DERIVATIVE TERM
C	      IS USED, AS GIVEN BY M. ABRAMOWITZ AND I.A. STEGUN,
C	      'HANDBOOK OF MATHEMATICAL FUNCTIONS', U. S. DEPARTMENT OF
C	      COMMERCE, NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C	      SERIES, 1966, EQUATION 6.1.41.
C
C	..................................................................
C
	SUBROUTINE DLGAM(XX,DLNG,IER)
	DOUBLE PRECISION XX,ZZ,TERM,RZ2,DLNG
	IER=0
	ZZ=XX
	IF(XX-1.D10) 2,2,1
1	IF(XX-1.7D33) 8,9,9                                                       0
C
C	   SEE IF XX IS NEAR ZERO OR NEGATIVE
C
2	IF(XX-1.D-9) 3,3,4
3	IER=-1
	DLNG=-1.7D38                                                              0
	GO TO 10
C
C	   XX GREATER THAN ZERO AND LESS THAN OR EQUAL TO 1.D+10
C
4	TERM=1.D0
5	IF(ZZ-18.D0) 6,6,7
6	TERM=TERM*ZZ
	ZZ=ZZ+1.D0
	GO TO 5
7	RZ2=1.D0/ZZ**2
	DLNG =(ZZ-0.5D0)*DLOG(ZZ)-ZZ +0.9189385332046727 -DLOG(TERM)+
     1(1.D0/ZZ)*(.8333333333333333D-1 -(RZ2*(.2777777777777777D-2 +(RZ2*
     2(.7936507936507936D-3 -(RZ2*(.5952380952380952D-3)))))))
	GO TO 10
C
C	   XX GREATER THAN 1.D+10 AND LESS THAN 1.D+70
C
8	DLNG=ZZ*(DLOG(ZZ)-1.D0)
	GO TO 10
C
C	   XX GREATER THAN OR EQUAL TO 1.D+70
C
9	IER=+1
	DLNG=1.7D38                                                               0
10	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DLLSQ
C
C	   PURPOSE
C	      TO SOLVE LINEAR LEAST SQUARES PROBLEMS, I.E. TO MINIMIZE
C	      THE EUCLIDEAN NORM OF B-A*X, WHERE A IS A M BY N MATRIX
C	      WITH M NOT LESS THAN N. IN THE SPECIAL CASE M=N SYSTEMS OF
C	      LINEAR EQUATIONS MAY BE SOLVED.
C
C	   USAGE
C	      CALL DLLSQ (A,B,M,N,L,X,IPIV,EPS,IER,AUX)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - DOUBLE PRECISION M BY N COEFFICIENT MATRIX
C	               (DESTROYED).
C	      B      - DOUBLE PRECISION M BY L RIGHT HAND SIDE MATRIX
C	               (DESTROYED).
C	      M      - ROW NUMBER OF MATRICES A AND B.
C	      N      - COLUMN NUMBER OF MATRIX A, ROW NUMBER OF MATRIX X.
C	      L      - COLUMN NUMBER OF MATRICES B AND X.
C	      X      - DOUBLE PRECISION N BY L SOLUTION MATRIX.
C	      IPIV   - INTEGER OUTPUT VECTOR OF DIMENSION N WHICH
C	               CONTAINS INFORMATIONS ON COLUMN INTERCHANGES
C	               IN MATRIX A. (SEE REMARK NO.3).
C	      EPS    - SINGLE PRECISION INPUT PARAMETER WHICH SPECIFIES
C	               A RELATIVE TOLERANCE FOR DETERMINATION OF RANK OF
C	               MATRIX A.
C	      IER    - A RESULTING ERROR PARAMETER.
C	      AUX    - A DOUBLE PRECISION AUXILIARY STORAGE ARRAY OF
C	               DIMENSION MAX(2*N,L). ON RETURN FIRST L LOCATIONS
C	               OF AUX CONTAIN THE RESULTING LEAST SQUARES.
C
C	   REMARKS
C	      (1) NO ACTION BESIDES ERROR MESSAGE IER=-2 IN CASE
C	          M LESS THAN N.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IER=-1 IN CASE
C	          OF A ZERO-MATRIX A.
C	      (3) IF RANK K OF MATRIX A IS FOUND TO BE LESS THAN N BUT
C	          GREATER THAN 0, THE PROCEDURE RETURNS WITH ERROR CODE
C	          IER=K INTO CALLING PROGRAM. THE LAST N-K ELEMENTS OF
C	          VECTOR IPIV DENOTE THE USELESS COLUMNS IN MATRIX A.
C	          THE REMAINING USEFUL COLUMNS FORM A BASE OF MATRIX A.
C	      (4) IF THE PROCEDURE WAS SUCCESSFUL, ERROR PARAMETER IER
C	          IS SET TO 0.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      HOUSEHOLDER TRANSFORMATIONS ARE USED TO TRANSFORM MATRIX A
C	      TO UPPER TRIANGULAR FORM. AFTER HAVING APPLIED THE SAME
C	      TRANSFORMATION TO THE RIGHT HAND SIDE MATRIX B, AN
C	      APPROXIMATE SOLUTION OF THE PROBLEM IS COMPUTED BY
C	      BACK SUBSTITUTION. FOR REFERENCE, SEE
C	      G. GOLUB, NUMERICAL METHODS FOR SOLVING LINEAR LEAST
C	      SQUARES PROBLEMS, NUMERISCHE MATHEMATIK, VOL.7,
C	      ISS.3 (1965), PP.206-216.
C
C	..................................................................
C
	SUBROUTINE DLLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX)
C
	DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1)
	DOUBLE PRECISION A,B,X,AUX,PIV,H,SIG,BETA,TOL
C
C	ERROR TEST
	IF(M-N)30,1,1
C
C	GENERATION OF INITIAL VECTOR S(K) (K=1,2,...,N) IN STORAGE
C	LOCATIONS AUX(K) (K=1,2,...,N)
1	PIV=0.D0
	IEND=0
	DO 4 K=1,N
	IPIV(K)=K
	H=0.D0
	IST=IEND+1
	IEND=IEND+M
	DO 2 I=IST,IEND
2	H=H+A(I)*A(I)
	AUX(K)=H
	IF(H-PIV)4,4,3
3	PIV=H
	KPIV=K
4	CONTINUE
C
C	ERROR TEST
	IF(PIV)31,31,5
C
C	DEFINE TOLERANCE FOR CHECKING RANK OF A
5	SIG=DSQRT(PIV)
	TOL=SIG*ABS(EPS)
C
C
C	DECOMPOSITION LOOP
	LM=L*M
	IST=-M
	DO 21 K=1,N
	IST=IST+M+1
	IEND=IST+M-K
	I=KPIV-K
	IF(I)8,8,6
C
C	INTERCHANGE K-TH COLUMN OF A WITH KPIV-TH IN CASE KPIV.GT.K
6	H=AUX(K)
	AUX(K)=AUX(KPIV)
	AUX(KPIV)=H
	ID=I*M
	DO 7 I=IST,IEND
	J=I+ID
	H=A(I)
	A(I)=A(J)
7	A(J)=H
C
C	COMPUTATION OF PARAMETER SIG
8	IF(K-1)11,11,9
9	SIG=0.D0
	DO 10 I=IST,IEND
10	SIG=SIG+A(I)*A(I)
	SIG=DSQRT(SIG)
C
C	TEST ON SINGULARITY
	IF(SIG-TOL)32,32,11
C
C	GENERATE CORRECT SIGN OF PARAMETER SIG
11	H=A(IST)
	IF(H)12,13,13
12	SIG=-SIG
C
C	SAVE INTERCHANGE INFORMATION
13	IPIV(KPIV)=IPIV(K)
	IPIV(K)=KPIV
C
C	GENERATION OF VECTOR UK IN K-TH COLUMN OF MATRIX A AND OF
C	PARAMETER BETA
	BETA=H+SIG
	A(IST)=BETA
	BETA=1.D0/(SIG*BETA)
	J=N+K
	AUX(J)=-SIG
	IF(K-N)14,19,19
C
C	TRANSFORMATION OF MATRIX A
14	PIV=0.D0
	ID=0
	JST=K+1
	KPIV=JST
	DO 18 J=JST,N
	ID=ID+M
	H=0.D0
	DO 15 I=IST,IEND
	II=I+ID
15	H=H+A(I)*A(II)
	H=BETA*H
	DO 16 I=IST,IEND
	II=I+ID
16	A(II)=A(II)-A(I)*H
C
C	UPDATING OF ELEMENT S(J) STORED IN LOCATION AUX(J)
	II=IST+ID
	H=AUX(J)-A(II)*A(II)
	AUX(J)=H
	IF(H-PIV)18,18,17
17	PIV=H
	KPIV=J
18	CONTINUE
C
C	TRANSFORMATION OF RIGHT HAND SIDE MATRIX B
19	DO 21 J=K,LM,M
	H=0.D0
	IEND=J+M-K
	II=IST
	DO 20 I=J,IEND
	H=H+A(II)*B(I)
20	II=II+1
	H=BETA*H
	II=IST
	DO 21 I=J,IEND
	B(I)=B(I)-A(II)*H
21	II=II+1
C	END OF DECOMPOSITION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
	IER=0
	I=N
	LN=L*N
	PIV=1.D0/AUX(2*N)
	DO 22 K=N,LN,N
	X(K)=PIV*B(I)
22	I=I+M
	IF(N-1)26,26,23
23	JST=(N-1)*M+N
	DO 25 J=2,N
	JST=JST-M-1
	K=N+N+1-J
	PIV=1.D0/AUX(K)
	KST=K-N
	ID=IPIV(KST)-KST
	IST=2-J
	DO 25 K=1,L
	H=B(KST)
	IST=IST+N
	IEND=IST+J-2
	II=JST
	DO 24 I=IST,IEND
	II=II+M
24	H=H-A(II)*X(I)
	I=IST-1
	II=I+ID
	X(I)=X(II)
	X(II)=PIV*H
25	KST=KST+M
C
C
C	COMPUTATION OF LEAST SQUARES
26	IST=N+1
	IEND=0
	DO 29 J=1,L
	IEND=IEND+M
	H=0.D0
	IF(M-N)29,29,27
27	DO 28 I=IST,IEND
28	H=H+B(I)*B(I)
	IST=IST+M
29	AUX(J)=H
	RETURN
C
C	ERROR RETURN IN CASE M LESS THAN N
30	IER=-2
	RETURN
C
C	ERROR RETURN IN CASE OF ZERO-MATRIX A
31	IER=-1
	RETURN
C
C	ERROR RETURN IN CASE OF RANK OF MATRIX A LESS THAN N
32	IER=K-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMATX
C
C	   PURPOSE
C	      COMPUTE MEANS OF VARIABLES IN EACH GROUP AND A POOLED
C	      DISPERSION MATRIX FOR ALL THE GROUPS. NORMALLY THIS SUB-
C	      ROUTINE IS USED IN THE PERFORMANCE OF DISCRIMINANT ANALYSIS.
C
C	   USAGE
C	      CALL DMATX (K,M,N,X,XBAR,D,CMEAN)
C
C	   DESCRIPTION OF PARAMETERS
C	      K     - NUMBER OF GROUPS
C	      M     - NUMBER OF VARIABLES (MUST BE THE SAME FOR ALL
C	              GROUPS).
C	      N     - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF
C	              GROUPS.
C	      X     - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA-
C	              LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1),
C	              X(2,1,1), X(3,1,1), ETC.  THE FIRST SUBSCRIPT IS
C	              CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER
C	              AND THE THIRD SUBSCRIPT IS GROUP NUMBER.  THE
C	              LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF
C	              DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K).
C	      XBAR  - OUTPUT MATRIX (M X K) CONTAINING MEANS OF VARIABLES
C	              IN K GROUPS.
C	      D     - OUTPUT MATRIX (M X M) CONTAINING POOLED DISPERSION.
C	      CMEAN - WORKING VECTOR OF LENGTH M.
C
C	   REMARKS
C	      THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO
C	      THE NUMBER OF GROUPS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
C	      DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO
C	      MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS,
C	      1958, SECTION 6.6-6.8.
C
C	..................................................................
C
	SUBROUTINE DMATX (K,M,N,X,XBAR,D,CMEAN)
	DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION XBAR,D,CMEAN
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	INITIALIZATION
C
	MM=M*M
	DO 100 I=1,MM
100	D(I)=0.0
C
C	CALCULATE MEANS
C
	N4=0
	L=0
	LM=0
	DO 160 NG=1,K
	N1=N(NG)
	FN=N1
	DO 130 J=1,M
	LM=LM+1
	XBAR(LM)=0.0
	DO 120 I=1,N1
	L=L+1
120	XBAR(LM)=XBAR(LM)+X(L)
130	XBAR(LM)=XBAR(LM)/FN
C
C	CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C
	LMEAN=LM-M
	DO 150 I=1,N1
	LL=N4+I-N1
	DO 140 J=1,M
	LL=LL+N1
	N2=LMEAN+J
140	CMEAN(J)=X(LL)-XBAR(N2)
	LL=0
	DO 150 J=1,M
	DO 150 JJ=1,M
	LL=LL+1
150	D(LL)=D(LL)+CMEAN(J)*CMEAN(JJ)
160	N4=N4+N1*M
C
C	CALCULATE THE POOLED DISPERSION MATRIX
C
	LL=-K
	DO 170 I=1,K
170	LL=LL+N(I)
	FN=LL
	DO 180 I=1,MM
180	D(I)=D(I)/FN
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMCHB
C
C	   PURPOSE
C	      FOR A GIVEN POSITIVE-DEFINITE M BY M MATRIX A WITH SYMMETRIC
C	      BAND STRUCTURE AND - IF NECESSARY - A GIVEN GENERAL M BY N
C	      MATRIX R, THE FOLLOWING CALCULATIONS (DEPENDENT ON THE
C	      VALUE OF THE DECISION PARAMETER IOP) ARE PERFORMED
C	      (1) MATRIX A IS FACTORIZED (IF IOP IS NOT NEGATIVE), THAT
C	          MEANS BAND MATRIX TU WITH UPPER CODIAGONALS ONLY IS
C	          GENERATED ON THE LOCATIONS OF A SUCH THAT
C	          TRANSPOSE(TU)*TU=A.
C	      (2) MATRIX R IS MULTIPLIED ON THE LEFT BY INVERSE(TU)
C	          AND/OR INVERSE(TRANSPOSE(TU)) AND THE RESULT IS STORED
C	          IN THE LOCATIONS OF R.
C	      THIS SUBROUTINE ESPECIALLY CAN BE USED TO SOLVE THE SYSTEM
C	      OF SIMULTANEOUS LINEAR EQUATIONS A*X=R WITH POSITIVE-
C	      DEFINITE COEFFICIENT MATRIX A OF SYMMETRIC BAND STRUCTURE.
C
C	   USAGE
C	      CALL DMCHB (R,A,M,N,MUD,IOP,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - INPUT IN CASES IOP=-3,-2,-1,1,2,3  DOUBLE PRECISION
C	                     M BY N RIGHT HAND SIDE MATRIX,
C	                     IN CASE IOP=0  IRRELEVANT.
C	               OUTPUT IN CASES IOP=1,-1  INVERSE(A)*R,
C	                      IN CASES IOP=2,-2  INVERSE(TU)*R,
C	                      IN CASES IOP=3,-3  INVERSE(TRANSPOSE(TU))*R,
C	                      IN CASE  IOP=0     UNCHANGED.
C	      A      - INPUT IN CASES IOP=0,1,2,3  DOUBLE PRECISION M BY M
C	                     POSITIVE-DEFINITE COEFFICIENT MATRIX OF
C	                     SYMMETRIC BAND STRUCTURE STORED IN
C	                     COMPRESSED FORM (SEE REMARKS),
C	                     IN CASES IOP=-1,-2,-3 DOUBLE PRECISION M BY M
C	                     BAND MATRIX TU WITH UPPER CODIAGONALS ONLY,
C	                     STORED IN COMPRESSED FORM (SEE REMARKS).
C	               OUTPUT IN ALL CASES  BAND MATRIX TU WITH UPPER
C	                      CODIAGONALS ONLY, STORED IN COMPRESSED FORM
C	                      (THAT MEANS UNCHANGED IF IOP=-1,-2,-3).
C	      M      - INPUT VALUE SPECIFYING THE NUMBER OF ROWS AND
C	               COLUMNS OF A AND THE NUMBER OF ROWS OF R.
C	      N      - INPUT VALUE SPECIFYING THE NUMBER OF COLUMNS OF R
C	               (IRRELEVANT IN CASE IOP=0).
C	      MUD    - INPUT VALUE SPECIFYING THE NUMBER OF UPPER
C	               CODIAGONALS OF A.
C	      IOP    - ONE OF THE VALUES -3,-2,-1,0,1,2,3 GIVEN AS INPUT
C	               AND USED AS DECISION PARAMETER.
C	      EPS    - SINGLE PRECISION INPUT VALUE USED AS RELATIVE
C	               TOLERANCE FOR TEST ON LOSS OF SIGNIFICANT DIGITS.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0  - NO ERROR,
C	                IER=-1 - NO RESULT BECAUSE OF WRONG INPUT
C	                         PARAMETERS M,MUD,IOP (SEE REMARKS),
C	                         OR BECAUSE OF A NONPOSITIVE RADICAND AT
C	                         SOME FACTORIZATION STEP,
C	                         OR BECAUSE OF A ZERO DIAGONAL ELEMENT
C	                         AT SOME DIVISION STEP.
C	                IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                         CANCE INDICATED AT FACTORIZATION STEP K+1
C	                         WHERE RADICAND WAS NO LONGER GREATER
C	                         THAN EPS*A(K+1,K+1).
C
C	   REMARKS
C	      UPPER PART OF SYMMETRIC BAND MATRIX A CONSISTING OF MAIN
C	      DIAGONAL AND MUD UPPER CODIAGONALS (RESP. BAND MATRIX TU
C	      CONSISTING OF MAIN DIAGONAL AND MUD UPPER CODIAGONALS)
C	      IS ASSUMED TO BE STORED IN COMPRESSED FORM, I.E. ROWWISE
C	      IN TOTALLY NEEDED M+MUD*(2M-MUD-1)/2 SUCCESSIVE STORAGE
C	      LOCATIONS. ON RETURN UPPER BAND FACTOR TU (ON THE LOCATIONS
C	      OF A) IS STORED IN THE SAME WAY.
C	      RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
C	      IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN RESULT MATRIX
C	      INVERSE(A)*R OR INVERSE(TU)*R OR INVERSE(TRANSPOSE(TU))*R
C	      IS STORED COLUMNWISE TOO ON THE LOCATIONS OF R.
C	      INPUT PARAMETERS M, MUD, IOP SHOULD SATISFY THE FOLLOWING
C	      RESTRICTIONS     MUD NOT LESS THAN ZERO,
C	                       1+MUD NOT GREATER THAN M,
C	                       ABS(IOP) NOT GREATER THAN 3.
C	      NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
C	      RESTRICTIONS ARE NOT SATISFIED.
C	      THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
C	      PARAMETERS ARE SATISFIED, IF RADICANDS AT ALL FACTORIZATION
C	      STEPS ARE POSITIVE AND/OR IF ALL DIAGONAL ELEMENTS OF
C	      UPPER BAND FACTOR TU ARE NONZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      FACTORIZATION IS DONE USING CHOLESKY-S SQUARE-ROOT METHOD,
C	      WHICH GENERATES THE UPPER BAND MATRIX TU SUCH THAT
C	      TRANSPOSE(TU)*TU=A. TU IS RETURNED AS RESULT ON THE
C	      LOCATIONS OF A. FURTHER, DEPENDENT ON THE ACTUAL VALUE OF
C	      IOP, DIVISION OF R BY TRANSPOSE(TU) AND/OR TU IS PERFORMED
C	      AND THE RESULT IS RETURNED ON THE LOCATIONS OF R.
C	      FOR REFERENCE, SEE H. RUTISHAUSER, ALGORITHMUS 1 - LINEARES
C	      GLEICHUNGSSYSTEM MIT SYMMETRISCHER POSITIV-DEFINITER
C	      BANDMATRIX NACH CHOLESKY - , COMPUTING (ARCHIVES FOR
C	      ELECTRONIC COMPUTING), VOL.1, ISS.1 (1966), PP.77-78.
C
C	..................................................................
C
c	SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER)
cC
cC
c	DIMENSION R(1),A(1)
c	DOUBLE PRECISION TOL,SUM,PIV,R,A
cC
cC	   TEST ON WRONG INPUT PARAMETERS
c	IF(IABS(IOP)-3)1,1,43
c1	IF(MUD)43,2,2
c2	MC=MUD+1
c	IF(M-MC)43,3,3
c3	MR=M-MUD
c	IER=0
cC
cC	   MC IS THE MAXIMUM NUMBER OF ELEMENTS IN THE ROWS OF ARRAY A
cC	   MR IS THE INDEX OF THE LAST ROW IN ARRAY A WITH MC ELEMENTS
cC
cC	******************************************************************
cC
cC	   START FACTORIZATION OF MATRIX A
c	IF(IOP)24,4,4
c4	IEND=0
c	LLDST=MUD
c	DO 23 K=1,M
c	IST=IEND+1
c	IEND=IST+MUD
c	J=K-MR
c	IF(J)6,6,5
c5	IEND=IEND-J
c6	IF(J-1)8,8,7
c7	LLDST=LLDST-1
c8	LMAX=MUD
c	J=MC-K
c	IF(J)10,10,9
c9	LMAX=LMAX-J
c10	ID=0
c	TOL=A(IST)*EPS
cC
cC	   START FACTORIZATION-LOOP OVER K-TH ROW
c	DO 23 I=IST,IEND
c	SUM=0.D0
c	IF(LMAX)14,14,11
cC
cC	   PREPARE INNER LOOP
c11	LL=IST
c	LLD=LLDST
cC
cC	   START INNER LOOP
c	DO 13 L=1,LMAX
c	LL=LL-LLD
c	LLL=LL+ID
c	SUM=SUM+A(LL)*A(LLL)
c	IF(LLD-MUD)12,13,13
c12	LLD=LLD+1
c13	CONTINUE
      SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER)
      DIMENSION R(1),A(1)
      DOUBLE PRECISION TOL,SUM,PIV,R,A
      IF(IABS(IOP)-3)1,1,43
    1 IF(MUD)43,2,2
    2 MC=MUD+1
      IF(M-MC)43,3,3
    3 MR=M-MUD
      IER=0
      IF(IOP)24,4,4
    4 IEND=0
      LLDST=MUD
      DO 23 K=1,M
      IST=IEND+1
      IEND=IST+MUD
      J=K-MR
      IF(J)6,6,5
    5 IEND=IEND-J
    6 IF(J-1)8,8,7
    7 LLDST=LLDST-1
    8 LMAX=MUD
      J=MC-K
      IF(J)10,10,9
    9 LMAX=LMAX-J
   10 ID=0
      TOL=A(IST)*EPS
      DO 23 I=IST,IEND
      SUM=0.D0
      IF(LMAX)14,14,11
   11 LL=IST
      LLD=LLDST
      DO 13 L=1,LMAX
      LL=LL-LLD
      LLL=LL+ID
      SUM=SUM+A(LL)*A(LLL)
      IF(LLD-MUD)12,13,13
   12 LLD=LLD+1
   13 CONTINUE
   14 SUM=A(I)-SUM
      IF(I-IST)15,15,20
   15 IF(SUM)43,43,16
   16 IF(SUM-TOL)17,17,19
   17 IF(IER)18,18,19
   18 IER=K-1
   19 PIV=DSQRT(SUM)
      A(I)=PIV
      PIV=1.D0/PIV
      GO TO 21
   20 A(I)=SUM*PIV
   21 ID=ID+1
      IF(ID-J)23,23,22
   22 LMAX=LMAX-1
   23 CONTINUE
      IF(IOP)24,44,24
   24 ID=N*M
      IEND=IABS(IOP)-2
      IF(IEND)25,35,25
   25 IST=1
      LMAX=0
      J=-MR
      LLDST=MUD
      DO 34 K=1,M
      PIV=A(IST)
      IF(PIV)26,43,26
   26 PIV=1.D0/PIV
      DO 30 I=K,ID,M
      SUM=0.D0
      IF(LMAX)30,30,27
   27 LL=IST
      LLL=I
      LLD=LLDST
      DO 29 L=1,LMAX
      LL=LL-LLD
      LLL=LLL-1
      SUM=SUM+A(LL)*R(LLL)
      IF(LLD-MUD)28,29,29
   28 LLD=LLD+1
   29 CONTINUE
   30 R(I)=PIV*(R(I)-SUM)
      IF(MC-K)32,32,31
   31 LMAX=K
   32 IST=IST+MC
      J=J+1
      IF(J)34,34,33
   33 IST=IST-J
      LLDST=LLDST-1
   34 CONTINUE
      IF(IEND)35,35,44
   35 IST=M+(MUD*(M+M-MC))/2+1
      LMAX=0
      K=M
   36 IEND=IST-1
      IST=IEND-LMAX
      PIV=A(IST)
      IF(PIV)37,43,37
   37 PIV=1.D0/PIV
      L=IST+1
      DO 40 I=K,ID,M
      SUM=0.D0
      IF(LMAX)40,40,38
   38 LLL=I
      DO 39 LL=L,IEND
      LLL=LLL+1
   39 SUM=SUM+A(LL)*R(LLL)
   40 R(I)=PIV*(R(I)-SUM)
      IF(K-MR)42,42,41
   41 LMAX=LMAX+1
   42 K=K-1
      IF(K)44,44,36
   43 IER=-1
   44 RETURN
      END
C
C	..................................................................
C
C	   SUBROUTINE DMFGR
C
C	   PURPOSE
C	      FOR A GIVEN M BY N MATRIX THE FOLLOWING CALCULATIONS
C	      ARE PERFORMED
C	      (1) DETERMINE RANK AND LINEARLY INDEPENDENT ROWS AND
C	          COLUMNS (BASIS).
C	      (2) FACTORIZE A SUBMATRIX OF MAXIMAL RANK.
C	      (3) EXPRESS NON-BASIC ROWS IN TERMS OF BASIC ONES.
C	      (4) EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES.
C
C	   USAGE
C	      CALL DMFGR(A,M,N,EPS,IRANK,IROW,ICOL)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - DOUBLE PRECISION GIVEN MATRIX WITH M ROWS
C	               AND N COLUMNS.
C	               ON RETURN A CONTAINS THE TRIANGULAR FACTORS
C	               OF A SUBMATRIX OF MAXIMAL RANK.
C	      M      - NUMBER OF ROWS OF MATRIX A.
C	      N      - NUMBER OF COLUMNS OF MATRIX A.
C	      EPS    - SINGLE PRECISION TESTVALUE FOR ZERO AFFECTED BY
C	               ROUNDOFF NOISE.
C	      IRANK  - RESULTANT RANK OF GIVEN MATRIX.
C	      IROW   - INTEGER VECTOR OF DIMENSION M CONTAINING THE
C	               SUBSCRIPTS OF BASIC ROWS IN IROW(1),...,IROW(IRANK)
C	      ICOL   - INTEGER VECTOR OF DIMENSION N CONTAINING THE
C	               SUBSCRIPTS OF BASIC COLUMNS IN ICOL(1) UP TO
C	               ICOL(IRANK).
C
C	   REMARKS
C	      THE LEFT HAND TRIANGULAR FACTOR IS NORMALIZED SUCH THAT
C	      THE DIAGONAL CONTAINS ALL ONES THUS ALLOWING TO STORE ONLY
C	      THE SUBDIAGONAL PART.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      GAUSSIAN ELIMINATION TECHNIQUE IS USED FOR CALCULATION
C	      OF THE TRIANGULAR FACTORS OF A GIVEN MATRIX.
C	      COMPLETE PIVOTING IS BUILT IN.
C	      IN CASE OF A SINGULAR MATRIX ONLY THE TRIANGULAR FACTORS
C	      OF A SUBMATRIX OF MAXIMAL RANK ARE RETAINED.
C	      THE REMAINING PARTS OF THE RESULTANT MATRIX GIVE THE
C	      DEPENDENCIES OF ROWS AND THE SOLUTION OF THE HOMOGENEOUS
C	      MATRIX EQUATION A*X=0.
C
C	..................................................................
C
	SUBROUTINE DMFGR(A,M,N,EPS,IRANK,IROW,ICOL)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),IROW(1),ICOL(1)
	DOUBLE PRECISION A,PIV,HOLD,SAVE
C
C	   TEST OF SPECIFIED DIMENSIONS
	IF(M)2,2,1
1	IF(N)2,2,4
2	IRANK=-1
3	RETURN
C	   RETURN IN CASE OF FORMAL ERRORS
C
C
C	   INITIALIZE COLUMN INDEX VECTOR
C	   SEARCH FIRST PIVOT ELEMENT
4	IRANK=0
	PIV=0.D0
	JJ=0
	DO 6 J=1,N
	ICOL(J)=J
	DO 6 I=1,M
	JJ=JJ+1
	HOLD=A(JJ)
	IF(DABS(PIV)-DABS(HOLD))5,6,6
5	PIV=HOLD
	IR=I
	IC=J
6	CONTINUE
C
C	   INITIALIZE ROW INDEX VECTOR
	DO 7 I=1,M
7	IROW(I)=I
C
C	   SET UP INTERNAL TOLERANCE
	TOL=ABS(EPS*SNGL(PIV))
C
C	   INITIALIZE ELIMINATION LOOP
	NM=N*M
	DO 19 NCOL=M,NM,M
C
C	   TEST FOR FEASIBILITY OF PIVOT ELEMENT
8	IF(ABS(SNGL(PIV))-TOL)20,20,9
C
C	   UPDATE RANK
9	IRANK=IRANK+1
C
C	   INTERCHANGE ROWS IF NECESSARY
	JJ=IR-IRANK
	IF(JJ)12,12,10
10	DO 11 J=IRANK,NM,M
	I=J+JJ
	SAVE=A(J)
	A(J)=A(I)
11	A(I)=SAVE
C
C	   UPDATE ROW INDEX VECTOR
	JJ=IROW(IR)
	IROW(IR)=IROW(IRANK)
	IROW(IRANK)=JJ
C
C	   INTERCHANGE COLUMNS IF NECESSARY
12	JJ=(IC-IRANK)*M
	IF(JJ)15,15,13
13	KK=NCOL
	DO 14 J=1,M
	I=KK+JJ
	SAVE=A(KK)
	A(KK)=A(I)
	KK=KK-1
14	A(I)=SAVE
C
C	   UPDATE COLUMN INDEX VECTOR
	JJ=ICOL(IC)
	ICOL(IC)=ICOL(IRANK)
	ICOL(IRANK)=JJ
15	KK=IRANK+1
	MM=IRANK-M
	LL=NCOL+MM
C
C	   TEST FOR LAST ROW
	IF(MM)16,25,25
C
C	   TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT
16	JJ=LL
	SAVE=PIV
	PIV=0.D0
	DO 19 J=KK,M
	JJ=JJ+1
	HOLD=A(JJ)/SAVE
	A(JJ)=HOLD
	L=J-IRANK
C
C	   TEST FOR LAST COLUMN
	IF(IRANK-N)17,19,19
17	II=JJ
	DO 19 I=KK,N
	II=II+M
	MM=II-L
	A(II)=A(II)-HOLD*A(MM)
	IF(DABS(A(II))-DABS(PIV))19,19,18
18	PIV=A(II)
	IR=J
	IC=I
19	CONTINUE
C
C	   SET UP MATRIX EXPRESSING ROW DEPENDENCIES
20	IF(IRANK-1)3,25,21
21	IR=LL
	DO 24 J=2,IRANK
	II=J-1
	IR=IR-M
	JJ=LL
	DO 23 I=KK,M
	HOLD=0.D0
	JJ=JJ+1
	MM=JJ
	IC=IR
	DO 22 L=1,II
	HOLD=HOLD+A(MM)*A(IC)
	IC=IC-1
22	MM=MM-M
23	A(MM)=A(MM)-HOLD
24	CONTINUE
C
C	   TEST FOR COLUMN REGULARITY
25	IF(N-IRANK)3,3,26
C
C	   SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE
C	   PARAMETERS (HOMOGENEOUS SOLUTION).
26	IR=LL
	KK=LL+M
	DO 30 J=1,IRANK
	DO 29 I=KK,NM,M
	JJ=IR
	LL=I
	HOLD=0.D0
	II=J
27	II=II-1
	IF(II)29,29,28
28	HOLD=HOLD-A(JJ)*A(LL)
	JJ=JJ-M
	LL=LL-1
	GOTO 27
29	A(LL)=(HOLD-A(LL))/A(JJ)
30	IR=IR-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMFSD
C
C	   PURPOSE
C	      FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX
C
C	   USAGE
C	      CALL DMFSD(A,N,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN
C	               SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT
C	               MATRIX.
C	               ON RETURN A CONTAINS THE RESULTANT UPPER
C	               TRIANGULAR MATRIX IN DOUBLE PRECISION.
C	      N      - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX.
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED
C	               AS RELATIVE TOLERANCE FOR TEST ON LOSS OF
C	               SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR
C	               IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
C	                        TER N OR BECAUSE SOME RADICAND IS NON-
C	                        POSITIVE (MATRIX A IS NOT POSITIVE
C	                        DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI-
C	                        FICANCE)
C	               IER=K  - WARNING WHICH INDICATES LOSS OF SIGNIFI-
C	                        CANCE. THE RADICAND FORMED AT FACTORIZA-
C	                        TION STEP K+1 WAS STILL POSITIVE BUT NO
C	                        LONGER GREATER THAN ABS(EPS*A(K+1,K+1)).
C
C	   REMARKS
C	      THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE
C	      STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS.
C	      IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU-
C	      LAR MATRIX IS STORED COLUMNWISE TOO.
C	      THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL
C	      CALCULATED RADICANDS ARE POSITIVE.
C	      THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE
C	      SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY.
C	      THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR
C	      MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF
C	      THE RETURNED RIGHT HAND FACTOR.
C
C	..................................................................
C
	SUBROUTINE DMFSD(A,N,EPS,IER)
C
C
	DIMENSION A(1)
	DOUBLE PRECISION DPIV,DSUM,A
C
C	   TEST ON WRONG INPUT PARAMETER N
	IF(N-1) 12,1,1
1	IER=0
C
C	   INITIALIZE DIAGONAL-LOOP
	KPIV=0
	DO 11 K=1,N
	KPIV=KPIV+K
	IND=KPIV
	LEND=K-1
C
C	   CALCULATE TOLERANCE
	TOL=ABS(EPS*SNGL(A(KPIV)))
C
C	   START FACTORIZATION-LOOP OVER K-TH ROW
	DO 11 I=K,N
	DSUM=0.D0
	IF(LEND) 2,4,2
C
C	   START INNER LOOP
2	DO 3 L=1,LEND
	LANF=KPIV-L
	LIND=IND-L
3	DSUM=DSUM+A(LANF)*A(LIND)
C	   END OF INNER LOOP
C
C	   TRANSFORM ELEMENT A(IND)
4	DSUM=A(IND)-DSUM
	IF(I-K) 10,5,10
C
C	   TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE
5	IF(SNGL(DSUM)-TOL) 6,6,9
6	IF(DSUM) 12,12,7
7	IF(IER) 8,8,9
8	IER=K-1
C
C	   COMPUTE PIVOT ELEMENT
9	DPIV=DSQRT(DSUM)
	A(KPIV)=DPIV
	DPIV=1.D0/DPIV
	GO TO 11
C
C	   CALCULATE TERMS IN ROW
10	A(IND)=DSUM*DPIV
11	IND=IND+I
C	   END OF DIAGONAL-LOOP
C
	RETURN
12	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMFSS
C
C	   PURPOSE
C	      GIVEN A SYMMETRIC POSITIVE SEMI DEFINITE MATRIX ,DMFSS WILL
C	      (1) DETERMINE THE RANK AND LINEARLY INDEPENDENT ROWS AND
C	          COLUMNS
C	      (2) FACTOR A SYMMETRIC SUBMATRIX OF MAXIMAL RANK
C	      (3) EXPRESS NONBASIC ROWS IN TERMS OF BASIC ONES,
C	          EXPRESS NONBASIC COLUMNS IN TERMS OF BASIC ONES
C	          EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES
C	      SUBROUTINE DMFSS MAY BE USED AS A PREPARATORY STEP FOR THE
C	      CALCULATION OF THE LEAST SQUARES SOLUTION OF MINIMAL
C	      LENGTH OF A SYSTEM OF LINEAR EQUATIONS WITH SYMMETRIC
C	      POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX
C
C	   USAGE
C	      CALL DMFSS(A,N,EPS,IRANK,TRAC)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - UPPER TRIANGULAR PART OF GIVEN SYMMETRIC SEMI-
C	              DEFINITE MATRIX STORED COLUMNWISE IN COMPRESSED FORM
C	              ON RETURN A CONTAINS THE MATRIX T AND, IF IRANK IS
C	              LESS THAN N, THE MATRICES U AND TU
C	              A MUST BE OF DOUBLE PRECISION
C	      N     - DIMENSION OF GIVEN MATRIX A
C	      EPS   - TESTVALUE FOR ZERO AFFECTED BY ROUND-OFF NOISE
C	      IRANK - RESULTANT VARIABLE, CONTAINING THE RANK OF GIVEN
C	              MATRIX A IF A IS SEMI-DEFINITE
C	              IRANK = 0 MEANS A HAS NO POSITIVE DIAGONAL ELEMENT
C	                        AND/OR EPS IS NOT ABSOLUTELY LESS THAN ONE
C	              IRANK =-1 MEANS DIMENSION N IS NOT POSITIVE
C	              IRANK =-2 MEANS COMPLETE FAILURE, POSSIBLY DUE TO
C	                        INADEQUATE RELATIVE TOLERANCE EPS
C	      TRAC  - VECTOR OF DIMENSION N CONTAINING THE
C	              SOURCE INDEX OF THE I-TH PIVOT ROW IN ITS I-TH
C	              LOCATION, THIS MEANS THAT TRAC CONTAINS THE
C	              PRODUCT REPRESENTATION OF THE PERMUTATION WHICH
C	              IS APPLIED TO ROWS AND COLUMNS OF A IN TERMS OF
C	              TRANSPOSITIONS
C	              TRAC MUST BE OF DOUBLE PRECISION
C
C	   REMARKS
C	      EPS MUST BE ABSOLUTELY LESS THAN ONE. A SENSIBLE VALUE IS
C	      SOMEWHERE IN BETWEEN 10**(-4) AND 10**(-6)
C	      THE ABSOLUTE VALUE OF INPUT PARAMETER EPS IS USED AS
C	      RELATIVE TOLERANCE.
C	      IN ORDER TO PRESERVE SYMMETRY ONLY PIVOTING ALONG THE
C	      DIAGONAL IS BUILT IN.
C	      ALL PIVOTELEMENTS MUST BE GREATER THAN THE ABSOLUTE VALUE
C	      OF EPS TIMES ORIGINAL DIAGONAL ELEMENT
C	      OTHERWISE THEY ARE TREATED AS IF THEY WERE ZERO
C	      MATRIX A REMAINS UNCHANGED IF THE RESULTANT VALUE IRANK
C	      EQUALS ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE SQUARE ROOT METHOD WITH DIAGONAL PIVOTING IS USED FOR
C	      CALCULATION OF THE RIGHT HAND TRIANGULAR FACTOR.
C	      IN CASE OF AN ONLY SEMI-DEFINITE MATRIX THE SUBROUTINE
C	      RETURNS THE IRANK X IRANK UPPER TRIANGULAR FACTOR T OF A
C	      SUBMATRIX OF MAXIMAL RANK, THE IRANK X (N-IRANK) MATRIX U
C	      AND THE (N-IRANK) X (N-IRANK) UPPER TRIANGULAR TU SUCH
C	      THAT TRANSPOSE(TU)*TU=I+TRANSPOSE(U)*U
C
C	..................................................................
C
	SUBROUTINE DMFSS(A,N,EPS,IRANK,TRAC)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),TRAC(1)
	DOUBLE PRECISION SUM,A,TRAC,PIV,HOLD
C
C	   TEST OF SPECIFIED DIMENSION
	IF(N)36,36,1
C
C	   INITIALIZE TRIANGULAR FACTORIZATION
1	IRANK=0
	ISUB=0
	KPIV=0
	J=0
	PIV=0.D0
C
C	   SEARCH FIRST PIVOT ELEMENT
	DO 3 K=1,N
	J=J+K
	TRAC(K)=A(J)
	IF(A(J)-PIV)3,3,2
2	PIV=A(J)
	KSUB=J
	KPIV=K
3	CONTINUE
C
C	   START LOOP OVER ALL ROWS OF A
	DO 32 I=1,N
	ISUB=ISUB+I
	IM1=I-1
4	KMI=KPIV-I
	IF(KMI)35,9,5
C
C	   PERFORM PARTIAL COLUMN INTERCHANGE
5	JI=KSUB-KMI
	IDC=JI-ISUB
	JJ=ISUB-IM1
	DO 6 K=JJ,ISUB
	KK=K+IDC
	HOLD=A(K)
	A(K)=A(KK)
6	A(KK)=HOLD
C
C	   PERFORM PARTIAL ROW INTERCHANGE
	KK=KSUB
	DO 7 K=KPIV,N
	II=KK-KMI
	HOLD=A(KK)
	A(KK)=A(II)
	A(II)=HOLD
7	KK=KK+K
C
C	   PERFORM REMAINING INTERCHANGE
	JJ=KPIV-1
	II=ISUB
	DO 8 K=I,JJ
	HOLD=A(II)
	A(II)=A(JI)
	A(JI)=HOLD
	II=II+K
8	JI=JI+1
9	IF(IRANK)22,10,10
C
C	   RECORD INTERCHANGE IN TRANSPOSITION VECTOR
10	TRAC(KPIV)=TRAC(I)
	TRAC(I)=KPIV
C
C	   MODIFY CURRENT PIVOT ROW
	KK=IM1-IRANK
	KMI=ISUB-KK
	PIV=0.D0
	IDC=IRANK+1
	JI=ISUB-1
	JK=KMI
	JJ=ISUB-I
	DO 19 K=I,N
	SUM=0.D0
C
C	   BUILD UP SCALAR PRODUCT IF NECESSARY
	IF(KK)13,13,11
11	DO 12 J=KMI,JI
	SUM=SUM-A(J)*A(JK)
12	JK=JK+1
13	JJ=JJ+K
	IF(K-I)14,14,16
14	SUM=A(ISUB)+SUM
C
C	   TEST RADICAND FOR LOSS OF SIGNIFICANCE
	IF(SUM-DABS(A(ISUB)*DBLE(EPS)))20,20,15
15	A(ISUB)=DSQRT(SUM)
	KPIV=I+1
	GOTO 19
16	SUM=(A(JK)+SUM)/A(ISUB)
	A(JK)=SUM
C
C	   SEARCH FOR NEXT PIVOT ROW
	IF(A(JJ))19,19,17
17	TRAC(K)=TRAC(K)-SUM*SUM
	HOLD=TRAC(K)/A(JJ)
	IF(PIV-HOLD)18,19,19
18	PIV=HOLD
	KPIV=K
	KSUB=JJ
19	JK=JJ+IDC
	GOTO 32
C
C	   CALCULATE MATRIX OF DEPENDENCIES U
20	IF(IRANK)21,21,37
21	IRANK=-1
	GOTO 4
22	IRANK=IM1
	II=ISUB-IRANK
	JI=II
	DO 26 K=1,IRANK
	JI=JI-1
	JK=ISUB-1
	JJ=K-1
	DO 26 J=I,N
	IDC=IRANK
	SUM=0.D0
	KMI=JI
	KK=JK
	IF(JJ)25,25,23
23	DO 24 L=1,JJ
	IDC=IDC-1
	SUM=SUM-A(KMI)*A(KK)
	KMI=KMI-IDC
24	KK=KK-1
25	A(KK)=(SUM+A(KK))/A(KMI)
26	JK=JK+J
C
C	   CALCULATE I+TRANSPOSE(U)*U
	JJ=ISUB-I
	PIV=0.D0
	KK=ISUB-1
	DO 31 K=I,N
	JJ=JJ+K
	IDC=0
	DO 28 J=K,N
	SUM=0.D0
	KMI=JJ+IDC
	DO 27 L=II,KK
	JK=L+IDC
27	SUM=SUM+A(L)*A(JK)
	A(KMI)=SUM
28	IDC=IDC+J
	A(JJ)=A(JJ)+1.D0
	TRAC(K)=A(JJ)
C
C	   SEARCH NEXT DIAGONAL ELEMENT
	IF(PIV-A(JJ))29,30,30
29	KPIV=K
	KSUB=JJ
	PIV=A(JJ)
30	II=II+K
	KK=KK+K
31	CONTINUE
	GOTO 4
32	CONTINUE
33	IF(IRANK)35,34,35
34	IRANK=N
35	RETURN
C
C	   ERROR RETURNS
C
C	   RETURN IN CASE OF ILLEGAL DIMENSION
36	IRANK=-1
	RETURN
C
C	   INSTABLE FACTORIZATION OF I+TRANSPOSE(U)*U
37	IRANK=-2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMLSS
C
C	   PURPOSE
C	      SUBROUTINE DMLSS IS THE SECOND STEP IN THE PROCEDURE FOR
C	      CALCULATING THE LEAST SQUARES SOLUTION OF MINIMAL LENGTH
C	      OF A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH SYMMETRIC
C	      POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX.
C
C	   USAGE
C	      CALL DMLSS(A,N,IRANK,TRAC,INC,RHS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - COEFFICIENT MATRIX IN FACTORED FORM AS GENERATED
C	              BY SUBROUTINE MFSS FROM INITIALLY GIVEN SYMMETRIC
C	              COEFFICIENT MATRIX A STORED IN N*(N+1)/2 LOCATIONS
C	              A REMAINS UNCHANGED
C	              A MUST BE OF DOUBLE PRECISION
C	      N     - DIMENSION OF COEFFICIENT MATRIX
C	      IRANK - RANK OF COEFFICIENT MATRIX, CALCULATED BY MEANS OF
C	              SUBROUTINE DMFSS
C	      TRAC  - VECTOR OF DIMENSION N CONTAINING THE
C	              SUBSCRIPTS OF PIVOT ROWS AND COLUMNS, I.E. THE
C	              PRODUCT REPRESENTATION IN TRANSPOSITIONS OF THE
C	              PERMUTATION WHICH WAS APPLIED TO ROWS AND COLUMNS
C	              OF A IN THE FACTORIZATION PROCESS
C	              TRAC IS A RESULTANT ARRAY OF SUBROUTINE MFSS
C	              TRAC MUST BE OF DOUBLE PRECISION
C	      INC   - INPUT VARIABLE WHICH SHOULD CONTAIN THE VALUE ZERO
C	              IF THE SYSTEM OF SIMULTANEOUS EQUATIONS IS KNOWN
C	              TO BE COMPATIBLE AND A NONZERO VALUE OTHERWISE
C	      RHS   - VECTOR OF DIMENSION N CONTAINING THE RIGHT HAND SIDE
C	              ON RETURN RHS CONTAINS THE MINIMAL LENGTH SOLUTION
C	              RHS MUST BE OF DOUBLE PRECISION
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER = 0 MEANS NO ERRORS
C	              IER =-1 MEANS N AND/OR IRANK IS NOT POSITIVE AND/OR
C	                      IRANK IS GREATER THAN N
C	              IER = 1 MEANS THE FACTORIZATION CONTAINED IN A HAS
C	                      ZERO DIVISORS AND/OR TRAC CONTAINS
C	                      VALUES OUTSIDE THE FEASIBLE RANGE 1 UP TO N
C
C	   REMARKS
C	      THE MINIMAL LENGTH SOLUTION IS PRODUCED IN THE STORAGE
C	      LOCATIONS OCCUPIED BY THE RIGHT HAND SIDE.
C	      SUBROUTINE DMLSS DOES TAKE CARE OF THE PERMUTATION
C	      WHICH WAS APPLIED TO ROWS AND COLUMNS OF A.
C	      OPERATION IS BYPASSED IN CASE OF A NON POSITIVE VALUE
C	      OF IRANK
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      LET T, U, TU BE THE COMPONENTS OF THE FACTORIZATION OF A,
C	      AND LET THE RIGHT HAND SIDE BE PARTITIONED INTO A FIRST
C	      PART X1 OF DIMENSION IRANK AND A SECOND PART X2 OF DIMENSION
C	      N-IRANK. THEN THE FOLLOWING OPERATIONS ARE APPLIED IN
C	      SEQUENCE
C	      (1) INTERCHANGE RIGHT HAND SIDE
C	      (2) X1 = X1 + U * X2
C	      (3) X2 =-TRANSPOSE(U) * X1
C	      (4) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
C	      (5) X1 = X1 + U * X2
C	      (6) X1 = INVERSE(T) * INVERSE(TRANSPOSE(T)) * X1
C	      (7) X2 =-TRANSPOSE(U) * X1
C	      (8) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
C	      (9) X1 = X1 + U * X2
C	      (10)X2 = TRANSPOSE(U) * X1
C	      (11) REINTERCHANGE CALCULATED SOLUTION
C	      IF THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS IS SPECIFIED
C	      TO BE COMPATIBLE THEN STEPS (2), (3), (4) AND (5) ARE
C	      CANCELLED.
C	      IF THE COEFFICIENT MATRIX HAS RANK N, THEN THE ONLY STEPS
C	      PERFORMED ARE (1), (6) AND (11).
C
C	..................................................................
C
	SUBROUTINE DMLSS(A,N,IRANK,TRAC,INC,RHS,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),TRAC(1),RHS(1)
	DOUBLE PRECISION SUM,A,RHS,TRAC,HOLD
C
C	   TEST OF SPECIFIED DIMENSIONS
	IDEF=N-IRANK
	IF(N)33,33,1
1	IF(IRANK)33,33,2
2	IF(IDEF)33,3,3
C
C	   CALCULATE AUXILIARY VALUES
3	ITE=IRANK*(IRANK+1)/2
	IX2=IRANK+1
	NP1=N+1
	IER=0
C
C	   INTERCHANGE RIGHT HAND SIDE
	JJ=1
	II=1
4	DO 6 I=1,N
	J=TRAC(II)
	IF(J)31,31,5
5	HOLD=RHS(II)
	RHS(II)=RHS(J)
	RHS(J)=HOLD
6	II=II+JJ
	IF(JJ)32,7,7
C
C	   PERFORM STEP 2 IF NECESSARY
7	ISW=1
	IF(INC*IDEF)8,28,8
C
C	   CALCULATE X1 = X1 + U * X2
8	ISTA=ITE
	DO 10 I=1,IRANK
	ISTA=ISTA+1
	JJ=ISTA
	SUM=0.D0
	DO 9 J=IX2,N
	SUM=SUM+A(JJ)*RHS(J)
9	JJ=JJ+J
10	RHS(I)=RHS(I)+SUM
	GOTO(11,28,11),ISW
C
C	   CALCULATE X2 = TRANSPOSE(U) * X1
11	ISTA=ITE
	DO 15 I=IX2,N
	JJ=ISTA
	SUM=0.D0
	DO 12 J=1,IRANK
	JJ=JJ+1
12	SUM=SUM+A(JJ)*RHS(J)
	GOTO(13,13,14),ISW
13	SUM=-SUM
14	RHS(I)=SUM
15	ISTA=ISTA+I
	GOTO(16,29,30),ISW
C
C	   INITIALIZE STEP (4) OR STEP (8)
16	ISTA=IX2
	IEND=N
	JJ=ITE+ISTA
C
C	   DIVISION OF X1 BY TRANSPOSE OF TRIANGULAR MATRIX
17	SUM=0.D0
	DO 20 I=ISTA,IEND
	IF(A(JJ))18,31,18
18	RHS(I)=(RHS(I)-SUM)/A(JJ)
	IF(I-IEND)19,21,21
19	JJ=JJ+ISTA
	SUM=0.D0
	DO 20 J=ISTA,I
	SUM=SUM+A(JJ)*RHS(J)
20	JJ=JJ+1
C
C	   DIVISION OF X1 BY TRIANGULAR MATRIX
21	SUM=0.D0
	II=IEND
	DO 24 I=ISTA,IEND
	RHS(II)=(RHS(II)-SUM)/A(JJ)
	IF(II-ISTA)25,25,22
22	KK=JJ-1
	SUM=0.D0
	DO 23 J=II,IEND
	SUM=SUM+A(KK)*RHS(J)
23	KK=KK+J
	JJ=JJ-II
24	II=II-1
25	IF(IDEF)26,30,26
26	GOTO(27,11,8),ISW
C
C	   PERFORM STEP (5)
27	ISW=2
	GOTO 8
C
C	   PERFORM STEP (6)
28	ISTA=1
	IEND=IRANK
	JJ=1
	ISW=2
	GOTO 17
C
C	   PERFORM STEP (8)
29	ISW=3
	GOTO 16
C
C	   REINTERCHANGE CALCULATED SOLUTION
30	II=N
	JJ=-1
	GOTO 4
C
C	   ERROR RETURN IN CASE OF ZERO DIVISOR
31	IER=1
32	RETURN
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSION
33	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMPRC
C
C	   PURPOSE
C	      TO PERMUTE THE ROWS OR COLUMNS OF A GIVEN MATRIX ACCORDING
C	      TO A GIVEN TRANSPOSITION VECTOR OR ITS INVERSE.  (SEE THE
C	      DISCUSSION ON PERMUTATIONS FOR DEFINITIONS AND NOTATION.)
C
C	   USAGE
C	      CALL DMPRC(A,M,N,ITRA,INV,IROCO,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - GIVEN DOUBLE PRECISION M BY N MATRIX AND RESULTING
C	              PERMUTED MATRIX
C	      M     - NUMBER OF ROWS OF A
C	      N     - NUMBER OF COLUMNS OF A
C	      ITRA  - GIVEN TRANSPOSITION VECTOR (DIMENSION M IF ROWS ARE
C	              PERMUTED, N IF COLUMNS ARE PERMUTED)
C	      INV   - INPUT PARAMETER
C	              INV NON-ZERO  -  PERMUTE ACCORDING TO ITRA
C	              INV    =   0  -  PERMUTE ACCORDING TO ITRA INVERSE
C	      IROCO - INPUT PARAMETER
C	              IROCO NON-ZERO  -  PERMUTE THE COLUMNS OF A
C	              IROCO    =   0  -  PERMUTE THE ROWS OF A
C	      IER   - RESULTING ERROR PARAMETER
C	              IER = -1  -  M AND N ARE NOT BOTH POSITIVE
C	              IER =  0  -  NO ERROR
C	              IER =  1  -  ITRA IS NOT A TRANSPOSITION VECTOR ON
C	                           1,...,M IF ROWS ARE PERMUTED, 1,...,N
C	                           IF COLUMNS ARE PERMUTED
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE IS NO COMPUTATION.
C	      (2)  IF IER= 1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE
C	           TO ERROR, BUT THE MATRIX A WILL REFLECT THE ROW OR
C	           COLUMN INTERCHANGES PERFORMED BEFORE THE ERROR WAS
C	           DETECTED.
C	      (3)  THE MATRIX A IS ASSUMED TO BE STORED COLUMNWISE.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE ROWS OR COLUMNS ARE PERMUTED ELEMENTWISE, INTERCHANGING
C	      ROW OR COLUMN 1 AND ITRA(1),...,ROW OR COLUMN K AND ITRA(K)
C	      IN THAT ORDER IF INV=0, AND OTHERWISE INTERCHANGING ROW OR
C	      COLUMN K AND ITRA(K),...,ROW OR COLUMN 1 AND ITRA(1), WHERE
C	      K IS M OR N DEPENDING ON WHETHER WE PERMUTE ROWS OR COLUMNS.
C
C	..................................................................
C
	SUBROUTINE DMPRC(A,M,N,ITRA,INV,IROCO,IER)
C
C
	DIMENSION A(1),ITRA(1)
	DOUBLE PRECISION A,SAVE
C
C	   TEST OF DIMENSIONS
	IF(M)14,14,1
1	IF(N)14,14,2
C
C	   DETERMINE WHICH ARE TO BE PERMUTED-THE ROWS OR THE COLUMNS
2	IF(IROCO)3,4,3
C
C	   INITIALIZE FOR COLUMN INTERCHANGES
3	MM=M
	MMM=-1
	L=M
	LL=N
	GO TO 5
C
C	   INITIALIZE FOR ROW INTERCHANGES
4	MM=1
	MMM=M
	L=N
	LL=M
C
C	   INITIALIZE LOOP OVER ALL ROWS OR COLUMNS
5	IA=1
	ID=1
C
C	   TEST FOR INVERSE OPERATION
	IF(INV)6,7,6
6	IA=LL
	ID=-1
7	DO 12 I=1,LL
	K=ITRA(IA)
	IF(K-IA)8,12,9
8	IF(K)13,13,10
9	IF(LL-K)13,10,10
C
C	   INITIALIZE ROW OR COLUMN INTERCHANGE
10	IL=IA*MM
	K=K*MM
C
C	   PERFORM ROW OR COLUMN INTERCHANGE
	DO 11 J=1,L
	SAVE=A(IL)
	A(IL)=A(K)
	A(K)=SAVE
	K=K+MMM
11	IL=IL+MMM
C
C	   ADDRESS NEXT INTERCHANGE STEP
12	IA=IA+ID
C
C	   NORMAL EXIT
	IER=0
	RETURN
C
C	   ERROR RETURN IN CASE ITRA IS NOT A TRANSPOSITION VECTOR
13	IER=1
	RETURN
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
14	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DMTDS
C
C	   PURPOSE
C	      MULTIPLY A GENERAL MATRIX A ON THE LEFT OR RIGHT BY
C	      INVERSE(T),INVERSE(TRANSPOSE(T)) OR INVERSE(TRANSPOSE(T*T))
C	      THE TRIANGULAR MATRIX T IS STORED COLUMNWISE IN COMPRESSED
C	      FORM, I.E. UPPER TRIANGULAR PART ONLY.
C
C	   USAGE
C	      CALL DMTDS(A,M,N,T,IOP,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - GIVEN GENERAL MATRIX WITH  M ROWS AND N COLUMNS.
C	              A MUST BE OF DOUBLE PRECISION
C	      M     - NUMBER OF ROWS OF MATRIX A
C	      N     - NUMBER OF COLUMNS OF MATRIX A
C	      T     - GIVEN TRIANGULAR MATRIX STORED COLUMNWISE UPPER
C	              TRIANGULAR PART ONLY. ITS NUMBER OF ROWS AND
C	              COLUMNS K IS IMPLIED BY COMPATIBILITY.
C	              K = M IF IOP IS POSITIVE,
C	              K = N IF IOP IS NEGATIVE.
C	              T OCCUPIES K*(K+1)/2 STORAGE POSITIONS.
C	              T MUST BE OF DOUBLE PRECISION
C	      IOP   - INPUT VARIABLE FOR SELECTION OF OPERATION
C	              IOP = 1 - A IS REPLACED BY INVERSE(T)*A
C	              IOP =-1 - A IS REPLACED BY A*INVERSE(T)
C	              IOP = 2 - A IS REPLACED BY INVERSE(TRANSPOSE(T))*A
C	              IOP =-2 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T))
C	              IOP = 3 - A IS REPLACED BY INVERSE(TRANSPOSE(T)*T)*A
C	              IOP =-3 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)*T)
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS M AND N ARE NOT BOTH POSITIVE
C	                            AND/OR IOP IS ILLEGAL
C	              IER = 0 MEANS OPERATION WAS SUCCESSFUL
C	              IER = 1 MEANS TRIANGULAR MATRIX T IS SINGULAR
C
C	   REMARKS
C	      SUBROUTINE DMTDS MAY BE USED TO CALCULATE THE SOLUTION OF
C	      A SYSTEM OF EQUATIONS WITH SYMMETRIC POSITIVE DEFINITE
C	      COEFFICIENT MATRIX. THE FIRST STEP TOWARDS THE SOLUTION
C	      IS TRIANGULAR FACTORIZATION BY MEANS OF DMFSD, THE SECOND
C	      STEP IS APPLICATION OF DMTDS.
C	      SUBROUTINES DMFSD AND DMTDS MAY BE USED IN ORDER TO
C	      CACULATE THE PRODUCT TRANSPOSE(A)*INVERSE(B)*A WITH GIVEN
C	      SYMMETRIC POSITIVE DEFINITE B AND GIVEN A IN THREE STEPS
C	      1) TRIANGULAR FACTORIZATION OF B (B=TRANSPOSE(T)*T)
C	      2) MULTIPLICATION OF A ON THE LEFT BY INVERSE(TRANSPOSE(T))
C	         A IS REPLACED BY C=INVERSE(TRANSPOSE(T))*A
C	      3) CALCULATION OF THE RESULT FORMING TRANSPOSE(C)*C
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      CALCULATION OF X = INVERSE(T)*A IS DONE USING BACKWARD
C	      SUBSTITUTION TO OBTAIN X FROM T*X = A.
C	      CALCULATION OF Y = INVERSE(TRANSPOSE(T))*A IS DONE USING
C	      FORWARD SUBSTITUTION TO OBTAIN Y FROM TRANSPOSE(T)*Y = A.
C	      CALCULATION OF Z = INVERSE(TRANSPOSE(T)*T)*A IS DONE
C	      SOLVING FIRST TRANSPOSE(T)*Y = A AND THEN T*Z = Y, IE.
C	      USING THE ABOVE TWO STEPS IN REVERSE ORDER
C
C	..................................................................
C
	SUBROUTINE DMTDS(A,M,N,T,IOP,IER)
C
C
	DIMENSION A(1),T(1)
	DOUBLE PRECISION DSUM,A,T
C
C	   TEST OF DIMENSION
	IF(M)2,2,1
1	IF(N)2,2,4
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
2	IER=-1
	RETURN
C
C	   ERROR RETURN IN CASE OF SINGULAR MATRIX T
3	IER=1
	RETURN
C
C	   INITIALIZE DIVISION PROCESS
4	MN=M*N
	MM=M*(M+1)/2
	MM1=M-1
	IER=0
	ICS=M
	IRS=1
	IMEND=M
C
C	   TEST SPECIFIED OPERATION
	IF(IOP)5,2,6
5	MM=N*(N+1)/2
	MM1=N-1
	IRS=M
	ICS=1
	IMEND=MN-M+1
	MN=M
6	IOPE=MOD(IOP+3,3)
	IF(IABS(IOP)-3)7,7,2
7	IF(IOPE-1)8,18,8
C
C	   INITIALIZE SOLUTION OF TRANSPOSE(T)*X = A
8	MEND=1
	LLD=IRS
	MSTA=1
	MDEL=1
	MX=1
	LD=1
	LX=0
C
C	   TEST FOR NONZERO DIAGONAL TERM IN T
9	IF(T(MSTA))10,3,10
10	DO 11 I=MEND,MN,ICS
11	A(I)=A(I)/T(MSTA)
C
C	   IS M EQUAL 1
	IF(MM1)2,15,12
12	DO 14 J=1,MM1
	MSTA=MSTA+MDEL
	MDEL=MDEL+MX
	DO 14 I=MEND,MN,ICS
	DSUM=0.D0
	L=MSTA
	LDX=LD
	LL=I
	DO 13 K=1,J
	DSUM=DSUM-T(L)*A(LL)
	LL=LL+LLD
	L=L+LDX
13	LDX=LDX+LX
	IF(T(L))14,3,14
14	A(LL)=(DSUM+A(LL))/T(L)
C
C	   TEST END OF OPERATION
15	IF(IER)16,17,16
16	IER=0
	RETURN
17	IF(IOPE)18,18,16
C
C	   INITIALIZE SOLUTION OF T*X = A
18	IER=1
	MEND=IMEND
	MN=M*N
	LLD=-IRS
	MSTA=MM
	MDEL=-1
	MX=0
	LD=-MM1
	LX=1
	GOTO 9
	END
C
C	..................................................................
C
C	   SUBROUTINE DPECN
C
C	   PURPOSE
C	      ECONOMIZE A POLYNOMIAL FOR SYMMETRIC RANGE
C
C	   USAGE
C	      CALL DPECN(P,N,BOUND,EPS,TOL,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      P     - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN
C	              POLYNOMIAL
C	              ON RETURN P CONTAINS THE ECONOMIZED POLYNOMIAL
C	      N     - DIMENSION OF COEFFICIENT VECTOR P
C	              ON RETURN N CONTAINS DIMENSION OF ECONOMIZED
C	              POLYNOMIAL
C	      BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF RANGE
C	      EPS   - SINGLE PRECISION INITIAL ERROR BOUND
C	              ON RETURN EPS CONTAINS AN ERROR BOUND FOR THE
C	              ECONOMIZED POLYNOMIAL
C	      TOL   - SINGLE PRECISION TOLERANCE FOR ERROR
C	              FINAL VALUE OF EPS MUST BE LESS THAN TOL
C	      WORK  - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N
C	              (STARTING VALUE OF N RATHER THAN FINAL VALUE)
C
C	   REMARKS
C	      THE OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
C	      IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
C	      FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
C	      WITH ARGUMENT X IN POWERS OF T = (X-(XR-XL)/2).
C	      THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SUBROUTINE DPECN TAKES AN (N-1)ST DEGREE POLYNOMIAL
C	      APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
C	      EPS OVER THE INTERVAL (-BOUND,BOUND) AND REDUCES IT IF
C	      POSSIBLE TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN
C	      THE GIVEN TOLERANCE TOL.
C	      THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE FINAL
C	      VECTOR. THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
C	      ERROR BOUND.
C	      N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
C	      THE COEFFICIENT VECTOR OF THE N-TH CHEBYSHEV POLYNOMIAL
C	      IS CALCULATED FROM THE RECURSION FORMULA
C	      A(K-1)=-A(K+1)*K*L*L*(K-1)/((N+K-2)*(N-K+2))
C	      REFERENCE
C	      K. A. BRONS, ALGORITHM 38, TELESCOPE 2, CACM VOL. 4, 1961,
C	      NO. 3, PP. 151-152.
C
C	..................................................................
C
	SUBROUTINE DPECN(P,N,BOUND,EPS,TOL,WORK)
C
	DIMENSION P(1),WORK(1)
	DOUBLE PRECISION P,WORK
C
	FL=BOUND*BOUND
C
C	   TEST OF DIMENSION
C
1	IF(N-1)2,3,6
2	RETURN
C
3	IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5
4	N=0
	EPS=EPS+ABS(SNGL(P(1)))
5	RETURN
C
C	   CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
C
6	NEND=N-2
	WORK(N)=-P(N)
	DO 7 J=1,NEND,2
	K=N-J
	FN=(NEND-1+K)*(NEND+3-K)
	FK=K*(K-1)
7	WORK(K-1)=-WORK(K+1)*DBLE(FK*FL/FN)
C
C	   TEST FOR FEASIBILITY OF REDUCTION
C
	IF(K-2)8,8,9
8	FN=DABS(WORK(1))
	GOTO 10
9	FN=N-1
	FN=ABS(SNGL(WORK(2))/FN)
10	IF(EPS+FN-TOL)11,11,5
C
C	   REDUCE POLYNOMIAL
C
11	EPS=EPS+FN
	N=N-1
	DO 12 J=K,N,2
12	P(J-1)=P(J-1)+WORK(J-1)
	GOTO 1
	END
C
C	..................................................................
C
C	   SUBROUTINE DPECS
C
C	   PURPOSE
C	      ECONOMIZATION OF A POLYNOMIAL FOR UNSYMMETRIC RANGE
C
C	   USAGE
C	      CALL DPECS(P,N,BOUND,EPS,TOL,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      P     - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN
C	              POLYNOMIAL
C	      N     - DIMENSION OF COEFFICIENT VECTOR P
C	      BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF INTERVAL
C	      EPS   - SINGLE PRECISION INITIAL ERROR BOUND
C	      TOL   - SINGLE PRECISION TOLERANCE FOR ERROR
C	      WORK  - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N
C
C	   REMARKS
C	      THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE
C	      ECONOMIZED VECTOR.
C	      THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
C	      ERROR BOUND.
C	      N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
C	      IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
C	      FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
C	      WITH ARGUMENT X IN POWERS OF T = (X-XL).
C	      THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD.
C	      OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SUBROUTINE DPECS TAKES AN (N-1)ST DEGREE POLYNOMIAL
C	      APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
C	      EPS OVER THE INTERVAL (0,BOUND) AND REDUCES IT IF POSSIBLE
C	      TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN TOLERANCE
C	      TOL.
C	      THE COEFFICIENT VECTOR OF THE N-TH SHIFTED CHEBYSHEV
C	      POLYNOMIAL IS CALCULATED FROM THE RECURSION FORMULA
C	      A(K) = -A(K+1)*K*L*(2*K-1)/(2*(N+K-1)*(N-K+1)).
C	      REFERENCE
C	      K. A. BRONS, ALGORITHM 37, TELESCOPE 1, CACM VOL. 4, 1961,
C	      NO. 3, PP. 151.
C
C	..................................................................
C
	SUBROUTINE DPECS(P,N,BOUND,EPS,TOL,WORK)
C
	DIMENSION P(1),WORK(1)
	DOUBLE PRECISION P,WORK
C
	FL=BOUND*0.5
C
C	   TEST OF DIMENSION
C
1	IF(N-1)2,3,6
2	RETURN
C
3	IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5
4	N=0
	EPS=EPS+ABS(SNGL(P(1)))
5	RETURN
C
C	   CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
C
6	NEND=N-1
	WORK(N)=-P(N)
	DO 7 J=1,NEND
	K=N-J
	FN=(NEND-1+K)*(N-K)
	FK=K*(K+K-1)
7	WORK(K)=-WORK(K+1)*DBLE(FK)*DBLE(FL)/DBLE(FN)
C
C	   TEST FOR FEASIBILITY OF REDUCTION
C
	FN=DABS(WORK(1))
	IF(EPS+FN-TOL)8,8,5
C
C	   REDUCE POLYNOMIAL
C
8	EPS=EPS+FN
	N=NEND
	DO 9 J=1,NEND
9	P(J)=P(J)+WORK(J)
	GOTO 1
	END
C
C	..................................................................
C
C	   SUBROUTINE DPQFB
C
C	   PURPOSE
C	      TO FIND AN APPROXIMATION Q(X)=Q1+Q2*X+X*X TO A QUADRATIC
C	      FACTOR OF A GIVEN POLYNOMIAL P(X) WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL DPQFB(C,IC,Q,LIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C   - DOUBLE PRECISION INPUT VECTOR CONTAINING THE
C	            COEFFICIENTS OF P(X) - C(1) IS THE CONSTANT TERM
C	            (DIMENSION IC)
C	      IC  - DIMENSION OF C
C	      Q   - DOUBLE PRECISION VECTOR OF DIMENSION 4 - ON INPUT Q(1)
C	            AND Q(2) CONTAIN INITIAL GUESSES FOR Q1 AND Q2 - ON
C	            RETURN Q(1) AND Q(2) CONTAIN THE REFINED COEFFICIENTS
C	            Q1 AND Q2 OF Q(X), WHILE Q(3) AND Q(4) CONTAIN THE
C	            COEFFICIENTS A AND B OF A+B*X, WHICH IS THE REMAINDER
C	            OF THE QUOTIENT OF P(X) BY Q(X)
C	      LIM - INPUT VALUE SPECIFYING THE MAXIMUM NUMBER OF
C	            ITERATIONS TO BE PERFORMED
C	      IER - RESULTING ERROR PARAMETER (SEE REMARKS)
C	            IER= 0 - NO ERROR
C	            IER= 1 - NO CONVERGENCE WITHIN LIM ITERATIONS
C	            IER=-1 - THE POLYNOMIAL P(X) IS CONSTANT OR UNDEFINED
C	                     - OR OVERFLOW OCCURRED IN NORMALIZING P(X)
C	            IER=-2 - THE POLYNOMIAL P(X) IS OF DEGREE 1
C	            IER=-3 - NO FURTHER REFINEMENT OF THE APPROXIMATION TO
C	                     A QUADRATIC FACTOR IS FEASIBLE, DUE TO EITHER
C	                     DIVISION BY 0, OVERFLOW OR AN INITIAL GUESS
C	                     THAT IS NOT SUFFICIENTLY CLOSE TO A FACTOR OF
C	                     P(X)
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE IS NO COMPUTATION OTHER THAN THE
C	           POSSIBLE NORMALIZATION OF C.
C	      (2)  IF IER=-2 THERE IS NO COMPUTATION OTHER THAN THE
C	           NORMALIZATION OF C.
C	      (3)  IF IER =-3  IT IS SUGGESTED THAT A NEW INITIAL GUESS BE
C	           MADE FOR A QUADRATIC FACTOR.  Q, HOWEVER, WILL CONTAIN
C	           THE VALUES ASSOCIATED WITH THE ITERATION THAT YIELDED
C	           THE SMALLEST NORM OF THE MODIFIED LINEAR REMAINDER.
C	      (4)  IF IER=1, THEN, ALTHOUGH THE NUMBER OF ITERATIONS LIM
C	           WAS TOO SMALL TO INDICATE CONVERGENCE, NO OTHER PROB-
C	           LEMS HAVE BEEN DETECTED, AND Q WILL CONTAIN THE VALUES
C	           ASSOCIATED WITH THE ITERATION THAT YIELDED THE SMALLEST
C	           NORM OF THE MODIFIED LINEAR REMAINDER.
C	      (5)  FOR COMPLETE DETAIL SEE THE DOCUMENTATION FOR
C	           SUBROUTINES PQFB AND DPQFB.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      COMPUTATION IS BASED ON BAIRSTOW'S ITERATIVE METHOD.  (SEE
C	      WILKINSON, J.H., THE EVALUATION OF THE ZEROS OF ILL-CON-
C	      DITIONED POLYNOMIALS (PART ONE AND TWO), NUMERISCHE MATHE-
C	      MATIK, VOL.1 (1959), PP. 150-180, OR HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 472-476.)
C
C	..................................................................
C
	SUBROUTINE DPQFB(C,IC,Q,LIM,IER)
C
C
	DIMENSION C(1),Q(1)
	DOUBLE PRECISION A,B,AA,BB,CA,CB,CC,CD,A1,B1,C1,H,HH,Q1,Q2,QQ1,
     1                 QQ2,QQQ1,QQQ2,DQ1,DQ2,EPS,EPS1,C,Q
C
C	   TEST ON LEADING ZERO COEFFICIENTS
	IER=0
	J=IC+1
1	J=J-1
	IF(J-1)40,40,2
2	IF(C(J))3,1,3
C
C	   NORMALIZATION OF REMAINING COEFFICIENTS
3	A=C(J)
	IF(A-1.D0)4,6,4
4	DO 5 I=1,J
	C(I)=C(I)/A
	CALL OVERFL(N)
	IF(N-2)40,5,5
5	CONTINUE
C
C	   TEST ON NECESSITY OF BAIRSTOW ITERATION
6	IF(J-3)41,38,7
C
C	   PREPARE BAIRSTOW ITERATION
7	EPS=1.D-14
	EPS1=1.D-6
	L=0
	LL=0
	Q1=Q(1)
	Q2=Q(2)
	QQ1=0.D0
	QQ2=0.D0
	AA=C(1)
	BB=C(2)
	CB=DABS(AA)
	CA=DABS(BB)
	IF(CB-CA)8,9,10
8	CC=CB+CB
	CB=CB/CA
	CA=1.D0
	GO TO 11
9	CC=CA+CA
	CA=1.D0
	CB=1.D0
	GO TO 11
10	CC=CA+CA
	CA=CA/CB
	CB=1.D0
11	CD=CC*.1D0
C
C	   START BAIRSTOW ITERATION
C	   PREPARE NESTED MULTIPLICATION
12	A=0.D0
	B=A
	A1=A
	B1=A
	I=J
	QQQ1=Q1
	QQQ2=Q2
	DQ1=HH
	DQ2=H
C
C	   START NESTED MULTIPLICATION
13	H=-Q1*B-Q2*A+C(I)
	CALL OVERFL(N)
	IF(N-2)42,14,14
14	B=A
	A=H
	I=I-1
	IF(I-1)18,15,16
15	H=0.D0
16	H=-Q1*B1-Q2*A1+H
	CALL OVERFL(N)
	IF(N-2)42,17,17
17	C1=B1
	B1=A1
	A1=H
	GO TO 13
C	   END OF NESTED MULTIPLICATION
C
C	   TEST ON SATISFACTORY ACCURACY
18	H=CA*DABS(A)+CB*DABS(B)
	IF(LL)19,19,39
19	L=L+1
	IF(DABS(A)-EPS*DABS(C(1)))20,20,21
20	IF(DABS(B)-EPS*DABS(C(2)))39,39,21
C
C	   TEST ON LINEAR REMAINDER OF MINIMUM NORM
21	IF(H-CC)22,22,23
22	AA=A
	BB=B
	CC=H
	QQ1=Q1
	QQ2=Q2
C
C	   TEST ON LAST ITERATION STEP
23	IF(L-LIM)28,28,24
C
C	   TEST ON RESTART OF BAIRSTOW ITERATION WITH ZERO INITIAL GUESS
24	IF(H-CD)43,43,25
25	IF(Q(1))27,26,27
26	IF(Q(2))27,42,27
27	Q(1)=0.D0
	Q(2)=0.D0
	GO TO 7
C
C	   PERFORM ITERATION STEP
28	HH=DMAX1(DABS(A1),DABS(B1),DABS(C1))
	IF(HH)42,42,29
29	A1=A1/HH
	B1=B1/HH
	C1=C1/HH
	H=A1*C1-B1*B1
	IF(H)30,42,30
30	A=A/HH
	B=B/HH
	HH=(B*A1-A*B1)/H
	H=(A*C1-B*B1)/H
	Q1=Q1+HH
	Q2=Q2+H
C	   END OF ITERATION STEP
C
C	   TEST ON SATISFACTORY RELATIVE ERROR OF ITERATED VALUES
	IF(DABS(HH)-EPS*DABS(Q1))31,31,33
31	IF(DABS(H)-EPS*DABS(Q2))32,32,33
32	LL=1
	GO TO 12
C
C	   TEST ON DECREASING RELATIVE ERRORS
33	IF(L-1)12,12,34
34	IF(DABS(HH)-EPS1*DABS(Q1))35,35,12
35	IF(DABS(H)-EPS1*DABS(Q2))36,36,12
36	IF(DABS(QQQ1*HH)-DABS(Q1*DQ1))37,44,44
37	IF(DABS(QQQ2*H)-DABS(Q2*DQ2))12,44,44
C	   END OF BAIRSTOW ITERATION
C
C	   EXIT IN CASE OF QUADRATIC POLYNOMIAL
38	Q(1)=C(1)
	Q(2)=C(2)
	Q(3)=0.D0
	Q(4)=0.D0
	RETURN
C
C	   EXIT IN CASE OF SUFFICIENT ACCURACY
39	Q(1)=Q1
	Q(2)=Q2
	Q(3)=A
	Q(4)=B
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO OR CONSTANT POLYNOMIAL
40	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF LINEAR POLYNOMIAL
41	IER=-2
	RETURN
C
C	   ERROR EXIT IN CASE OF NONREFINED QUADRATIC FACTOR
42	IER=-3
	GO TO 44
C
C	   ERROR EXIT IN CASE OF UNSATISFACTORY ACCURACY
43	IER=1
44	Q(1)=QQ1
	Q(2)=QQ2
	Q(3)=AA
	Q(4)=BB
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DPRBM
C
C	   PURPOSE
C	      TO CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN
C	      POLYNOMIAL WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL DPRBM (C,IC,RR,RC,POL,IR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C      - DOUBLE PRECISION INPUT VECTOR CONTAINING THE
C	               COEFFICIENTS OF THE GIVEN POLYNOMIAL. COEFFICIENTS
C	               ARE ORDERED FROM LOW TO HIGH. ON RETURN COEFFI-
C	               CIENTS ARE DIVIDED BY THE LAST NONZERO TERM.
C	      IC     - DIMENSION OF VECTORS C, RR, RC, AND POL.
C	      RR     - RESULTANT DOUBLE PRECISION VECTOR OF REAL PARTS
C	               OF THE ROOTS.
C	      RC     - RESULTANT DOUBLE PRECISION VECTOR OF COMPLEX PARTS
C	               OF THE ROOTS.
C	      POL    - RESULTANT DOUBLE PRECISION VECTOR OF COEFFICIENTS
C	               OF THE POLYNOMIAL WITH CALCULATED ROOTS.
C	               COEFFICIENTS ARE ORDERED FROM LOW TO HIGH (SEE
C	               REMARK 4).
C	      IR     - OUTPUT VALUE SPECIFYING THE NUMBER OF CALCULATED
C	               ROOTS. NORMALLY IR IS EQUAL TO IC-1.
C	      IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0  - NO ERROR,
C	                IER=1  - SUBROUTINE DPQFB RECORDS POOR CONVERGENCE
C	                         AT SOME QUADRATIC FACTORIZATION WITHIN
C	                         100 ITERATION STEPS,
C	                IER=2  - POLYNOMIAL IS DEGENERATE, I.E. ZERO OR
C	                         CONSTANT,
C	                         OR OVERFLOW IN NORMALIZATION OF GIVEN
C	                         POLYNOMIAL,
C	                IER=3  - THE SUBROUTINE IS BYPASSED DUE TO
C	                         SUCCESSIVE ZERO DIVISORS OR OVERFLOWS
C	                         IN QUADRATIC FACTORIZATION OR DUE TO
C	                         COMPLETELY UNSATISFACTORY ACCURACY,
C	                IER=-1 - CALCULATED COEFFICIENT VECTOR HAS LESS
C	                         THAN SIX CORRECT SIGNIFICANT DIGITS.
C	                         THIS REVEALS POOR ACCURACY OF CALCULATED
C	                         ROOTS.
C
C	   REMARKS
C	      (1) REAL PARTS OF THE ROOTS ARE STORED IN RR(1) UP TO RR(IR)
C	          AND CORRESPONDING COMPLEX PARTS IN RC(1) UP TO RC(IR).
C	      (2) ERROR MESSAGE IER=1 INDICATES POOR CONVERGENCE WITHIN
C	          100 ITERATION STEPS AT SOME QUADRATIC FACTORIZATION
C	          PERFORMED BY SUBROUTINE DPQFB.
C	      (3) NO ACTION BESIDES ERROR MESSAGE IER=2 IN CASE OF A ZERO
C	          OR CONSTANT POLYNOMIAL. THE SAME ERROR MESSAGE IS GIVEN
C	          IN CASE OF AN OVERFLOW IN NORMALIZATION OF GIVEN
C	          POLYNOMIAL.
C	      (4) ERROR MESSAGE IER=3 INDICATES SUCCESSIVE ZERO DIVISORS
C	          OR OVERFLOWS OR COMPLETELY UNSATISFACTORY ACCURACY AT
C	          ANY QUADRATIC FACTORIZATION PERFORMED BY
C	          SUBROUTINE DPQFB. IN THIS CASE CALCULATION IS BYPASSED.
C	          IR RECORDS THE NUMBER OF CALCULATED ROOTS.
C	          POL(1),...,POL(J-IR) ARE THE COEFFICIENTS OF THE
C	          REMAINING POLYNOMIAL, WHERE J IS THE ACTUAL NUMBER OF
C	          COEFFICIENTS IN VECTOR C (NORMALLY J=IC).
C	      (5) IF CALCULATED COEFFICIENT VECTOR HAS LESS THAN SIX
C	          CORRECT SIGNIFICANT DIGITS THOUGH ALL QUADRATIC
C	          FACTORIZATIONS SHOWED SATISFACTORY ACCURACY, THE ERROR
C	          MESSAGE IER=-1 IS GIVEN.
C	      (6) THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
C	          COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE
C	          BEEN CALCULATED. IN THIS CASE THE NUMBER OF ROOTS IR IS
C	          EQUAL TO THE ACTUAL DEGREE OF THE POLYNOMIAL (NORMALLY
C	          IR=IC-1). THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT
C	          VECTOR IS RECORDED IN RR(IR+1).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SUBROUTINE DPQFB    QUADRATIC FACTORIZATION OF A POLYNOMIAL
C	                          BY BAIRSTOW ITERATION.
C
C	   METHOD
C	      THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
C	      SUCCESSIVE QUADRATIC FACTORIZATION PERFORMED BY BAIRSTOW
C	      ITERATION. X**2 IS USED AS INITIAL GUESS FOR THE FIRST
C	      QUADRATIC FACTOR, AND FURTHER EACH CALCULATED QUADRATIC
C	      FACTOR IS USED AS INITIAL GUESS FOR THE NEXT ONE. AFTER
C	      COMPUTATION OF ALL ROOTS THE COEFFICIENT VECTOR IS
C	      CALCULATED AND COMPARED WITH THE GIVEN ONE.
C	      FOR REFERENCE, SEE J. H. WILKINSON, THE EVALUATION OF THE
C	      ZEROS OF ILL-CONDITIONED POLYNOMIALS (PART ONE AND TWO),
C	      NUMERISCHE MATHEMATIK, VOL.1 (1959), PP.150-180.
C
C	..................................................................
C
	SUBROUTINE DPRBM(C,IC,RR,RC,POL,IR,IER)
C
C
	DIMENSION C(1),RR(1),RC(1),POL(1),Q(4)
	DOUBLE PRECISION C,RR,RC,POL,Q,EPS,A,B,H,Q1,Q2
C
C	   TEST ON LEADING ZERO COEFFICIENTS
	EPS=1.D-6
	LIM=100
	IR=IC+1
1	IR=IR-1
	IF(IR-1)42,42,2
2	IF(C(IR))3,1,3
C
C	   WORK UP ZERO ROOTS AND NORMALIZE REMAINING POLYNOMIAL
3	IER=0
	J=IR
	L=0
	A=C(IR)
	DO 8 I=1,IR
	IF(L)4,4,7
4	IF(C(I))6,5,6
5	RR(I)=0.D0
	RC(I)=0.D0
	POL(J)=0.D0
	J=J-1
	GO TO 8
6	L=1
	IST=I
	J=0
7	J=J+1
	C(I)=C(I)/A
	POL(J)=C(I)
	CALL OVERFL(N)
	IF(N-2)42,8,8
8	CONTINUE
C
C	   START BAIRSTOW ITERATION
	Q1=0.D0
	Q2=0.D0
9	IF(J-2)33,10,14
C
C	   DEGREE OF RESTPOLYNOMIAL IS EQUAL TO ONE
10	A=POL(1)
	RR(IST)=-A
	RC(IST)=0.D0
	IR=IR-1
	Q2=0.D0
	IF(IR-1)13,13,11
11	DO 12 I=2,IR
	Q1=Q2
	Q2=POL(I+1)
12	POL(I)=A*Q2+Q1
13	POL(IR+1)=A+Q2
	GO TO 34
C	   THIS IS BRANCH TO COMPARISON OF COEFFICIENT VECTORS C AND POL
C
C	   DEGREE OF RESTPOLYNOMIAL IS GREATER THAN ONE
14	DO 22 L=1,10
	N=1
15	Q(1)=Q1
	Q(2)=Q2
	CALL DPQFB(POL,J,Q,LIM,I)
	IF(I)16,24,23
16	IF(Q1)18,17,18
17	IF(Q2)18,21,18
18	GO TO (19,20,19,21),N
19	Q1=-Q1
	N=N+1
	GO TO 15
20	Q2=-Q2
	N=N+1
	GO TO 15
21	Q1=1.D0+Q1
22	Q2=1.D0-Q2
C
C	   ERROR EXIT DUE TO UNSATISFACTORY RESULTS OF FACTORIZATION
	IER=3
	IR=IR-J
	RETURN
C
C	   WORK UP RESULTS OF QUADRATIC FACTORIZATION
23	IER=1
24	Q1=Q(1)
	Q2=Q(2)
C
C	   PERFORM DIVISION OF FACTORIZED POLYNOMIAL BY QUADRATIC FACTOR
	B=0.D0
	A=0.D0
	I=J
25	H=-Q1*B-Q2*A+POL(I)
	POL(I)=B
	B=A
	A=H
	I=I-1
	IF(I-2)26,26,25
26	POL(2)=B
	POL(1)=A
C
C	   MULTIPLY POLYNOMIAL WITH CALCULATED ROOTS BY QUADRATIC FACTOR
	L=IR-1
	IF(J-L)27,27,29
27	DO 28 I=J,L
28	POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1
29	POL(L)=POL(L)+POL(L+1)*Q2+Q1
	POL(IR)=POL(IR)+Q2
C
C	   CALCULATE ROOT-PAIR FROM QUADRATIC FACTOR X*X+Q2*X+Q1
	H=-.5D0*Q2
	A=H*H-Q1
	B=DSQRT(DABS(A))
	IF(A)30,30,31
30	RR(IST)=H
	RC(IST)=B
	IST=IST+1
	RR(IST)=H
	RC(IST)=-B
	GO TO 32
31	B=H+DSIGN(B,H)
	RR(IST)=Q1/B
	RC(IST)=0.D0
	IST=IST+1
	RR(IST)=B
	RC(IST)=0.D0
32	IST=IST+1
	J=J-2
	GO TO 9
C
C	   SHIFT BACK ELEMENTS OF POL BY 1 AND COMPARE VECTORS POL AND C
33	IR=IR-1
34	A=0.D0
	DO 38 I=1,IR
	Q1=C(I)
	Q2=POL(I+1)
	POL(I)=Q2
	IF(Q1)35,36,35
35	Q2=(Q1-Q2)/Q1
36	Q2=DABS(Q2)
	IF(Q2-A)38,38,37
37	A=Q2
38	CONTINUE
	I=IR+1
	POL(I)=1.D0
	RR(I)=A
	RC(I)=0.D0
	IF(IER)39,39,41
39	IF(A-EPS)41,41,40
C
C	   WARNING DUE TO POOR ACCURACY OF CALCULATED COEFFICIENT VECTOR
40	IER=-1
41	RETURN
C
C	   ERROR EXIT DUE TO DEGENERATE POLYNOMIAL OR OVERFLOW IN
C	   NORMALIZATION
42	IER=2
	IR=0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DPRQD
C
C	   PURPOSE
C	      CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN POLYNOMIAL
C	      WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL DPRQD(C,IC,Q,E,POL,IR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C     - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              THE GIVEN COEFFICIENT VECTOR GETS DIVIDED BY THE
C	              LAST NONZERO TERM
C	              DOUBLE PRECISION ARRAY
C	      IC    - DIMENSION OF VECTOR C
C	      Q     - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN Q CONTAINS REAL PARTS OF ROOTS
C	              DOUBLE PRECISION ARRAY
C	      E     - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN E CONTAINS COMPLEX PARTS OF ROOTS
C	              DOUBLE PRECISION ARRAY
C	      POL   - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN POL CONTAINS THE COEFFICIENTS OF THE
C	              POLYNOMIAL WITH CALCULATED ROOTS
C	              THIS RESULTING COEFFICIENT VECTOR HAS DIMENSION IR+1
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION ARRAY
C	      IR    - NUMBER OF CALCULATED ROOTS
C	              NORMALLY IR IS EQUAL TO DIMENSION IC MINUS ONE
C	      IER   - RESULTING ERROR PARAMETER. SEE REMARKS
C
C	   REMARKS
C	      THE REAL PART OF THE ROOTS IS STORED IN Q(1) UP TO Q(IR)
C	      CORRESPONDING COMPLEX PARTS ARE STORED IN E(1) UP TO E(IR).
C	      IER = 0 MEANS NO ERRORS
C	      IER = 1 MEANS NO CONVERGENCE WITH FEASIBLE TOLERANCE
C	      IER = 2 MEANS POLYNOMIAL IS DEGENERATE (CONSTANT OR ZERO)
C	      IER = 3 MEANS SUBROUTINE WAS ABANDONED DUE TO ZERO DIVISOR
C	      IER = 4 MEANS THERE EXISTS NO S-FRACTION
C	      IER =-1 MEANS CALCULATED COEFFICIENT VECTOR REVEALS POOR
C	              ACCURACY OF THE CALCULATED ROOTS.
C	              THE CALCULATED COEFFICIENT VECTOR HAS LESS THAN
C	              6 CORRECT DIGITS.
C	      THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
C	      COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE BEEN
C	      CALCULATED.
C	      THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT VECTOR IS
C	      RECORDED IN Q(IR+1).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
C	      THE QUOTIENT-DIFFERENCE ALGORITHM WITH DISPLACEMENT.
C	      REFERENCE
C	      H.RUTISHAUSER, DER QUOTIENTEN-DIFFERENZEN-ALGORITHMUS,
C	      BIRKHAEUSER, BASEL/STUTTGART, 1957.
C
C	..................................................................
C
	SUBROUTINE DPRQD(C,IC,Q,E,POL,IR,IER)
C
C	 DIMENSIONED DUMMY VARIABLES
	DIMENSION E(1),Q(1),C(1),POL(1)
	DOUBLE PRECISION Q,E,O,P,T,EXPT,ESAV,U,V,W,C,POL,EPS
C
C	   NORMALIZATION OF GIVEN POLYNOMIAL
C	      TEST OF DIMENSION
C	   IR CONTAINS INDEX OF HIGHEST COEFFICIENT
	IR=IC
	IER=0
	EPS=1.D-16
	TOL=1.E-6
	LIMIT=10*IC
	KOUNT=0
1	IF(IR-1)79,79,2
C
C	   DROP TRAILING ZERO COEFFICIENTS
2	IF(C(IR))4,3,4
3	IR=IR-1
	GOTO 1
C
C	      REARRANGEMENT OF GIVEN POLYNOMIAL
C	   EXTRACTION OF ZERO ROOTS
4	O=1.0D0/C(IR)
	IEND=IR-1
	ISTA=1
	NSAV=IR+1
	JBEG=1
C
C	   Q(J)=1.
C	   Q(J+I)=C(IR-I)/C(IR)
C	   Q(IR)=C(J)/C(IR)
C	   WHERE J IS THE INDEX OF THE LOWEST NONZERO COEFFICIENT
	DO 9 I=1,IR
	J=NSAV-I
	IF(C(I))7,5,7
5	GOTO(6,8),JBEG
6	NSAV=NSAV+1
	Q(ISTA)=0.D0
	E(ISTA)=0.D0
	ISTA=ISTA+1
	GOTO 9
7	JBEG=2
8	Q(J)=C(I)*O
	C(I)=Q(J)
9	CONTINUE
C
C	      INITIALIZATION
	ESAV=0.D0
	Q(ISTA)=0.D0
10	NSAV=IR
C
C	   COMPUTATION OF DERIVATIVE
	EXPT=IR-ISTA
	E(ISTA)=EXPT
	DO 11 I=ISTA,IEND
	EXPT=EXPT-1.0D0
	POL(I+1)=EPS*DABS(Q(I+1))+EPS
11	E(I+1)=Q(I+1)*EXPT
C
C	   TEST OF REMAINING DIMENSION
	IF(ISTA-IEND)12,20,60
12	JEND=IEND-1
C
C	   COMPUTATION OF S-FRACTION
	DO 19 I=ISTA,JEND
	IF(I-ISTA)13,16,13
13	IF(DABS(E(I))-POL(I+1))14,14,16
C
C	   THE GIVEN POLYNOMIAL HAS MULTIPLE ROOTS, THE COEFFICIENTS OF
C	   THE COMMON FACTOR ARE STORED FROM Q(NSAV) UP TO Q(IR)
14	NSAV=I
	DO 15 K=I,JEND
	IF(DABS(E(K))-POL(K+1))15,15,80
15	CONTINUE
	GOTO 21
C
C	      EUCLIDEAN ALGORITHM
16	DO 19 K=I,IEND
	E(K+1)=E(K+1)/E(I)
	Q(K+1)=E(K+1)-Q(K+1)
	IF(K-I)18,17,18
C
C	   TEST FOR SMALL DIVISOR
17	IF(DABS(Q(I+1))-POL(I+1))80,80,19
18	Q(K+1)=Q(K+1)/Q(I+1)
	POL(K+1)=POL(K+1)/DABS(Q(I+1))
	E(K)=Q(K+1)-E(K)
19	CONTINUE
20	Q(IR)=-Q(IR)
C
C	      THE DISPLACEMENT EXPT IS SET TO 0 AUTOMATICALLY.
C	      E(ISTA)=0.,Q(ISTA+1),...,E(NSAV-1),Q(NSAV),E(NSAV)=0.,
C	      FORM A DIAGONAL OF THE QD-ARRAY.
C	   INITIALIZATION OF BOUNDARY VALUES
21	E(ISTA)=0.D0
	NRAN=NSAV-1
22	E(NRAN+1)=0.D0
C
C	      TEST FOR LINEAR OR CONSTANT FACTOR
C	   NRAN-ISTA IS DEGREE-1
	IF(NRAN-ISTA)24,23,31
C
C	   LINEAR FACTOR
23	Q(ISTA+1)=Q(ISTA+1)+EXPT
	E(ISTA+1)=0.D0
C
C	   TEST FOR UNFACTORED COMMON DIVISOR
24	E(ISTA)=ESAV
	IF(IR-NSAV)60,60,25
C
C	   INITIALIZE QD-ALGORITHM FOR COMMON DIVISOR
25	ISTA=NSAV
	ESAV=E(ISTA)
	GOTO 10
C
C	   COMPUTATION OF ROOT PAIR
26	P=P+EXPT
C
C	   TEST FOR REALITY
	IF(O)27,28,28
C
C	   COMPLEX ROOT PAIR
27	Q(NRAN)=P
	Q(NRAN+1)=P
	E(NRAN)=T
	E(NRAN+1)=-T
	GOTO 29
C
C	   REAL ROOT PAIR
28	Q(NRAN)=P-T
	Q(NRAN+1)=P+T
	E(NRAN)=0.D0
C
C	      REDUCTION OF DEGREE BY 2 (DEFLATION)
29	NRAN=NRAN-2
	GOTO 22
C
C	   COMPUTATION OF REAL ROOT
30	Q(NRAN+1)=EXPT+P
C
C	      REDUCTION OF DEGREE BY 1 (DEFLATION)
	NRAN=NRAN-1
	GOTO 22
C
C	   START QD-ITERATION
31	JBEG=ISTA+1
	JEND=NRAN-1
	TEPS=EPS
	TDELT=1.E-2
32	KOUNT=KOUNT+1
	P=Q(NRAN+1)
	R=ABS(SNGL(E(NRAN)))
C
C	      TEST FOR CONVERGENCE
	IF(R-TEPS)30,30,33
33	S=ABS(SNGL(E(JEND)))
C
C	   IS THERE A REAL ROOT NEXT
	IF(S-R)38,38,34
C
C	   IS DISPLACEMENT SMALL ENOUGH
34	IF(R-TDELT)36,35,35
35	P=0.D0
36	O=P
	DO 37 J=JBEG,NRAN
	Q(J)=Q(J)+E(J)-E(J-1)-O
C
C	      TEST FOR SMALL DIVISOR
	IF(DABS(Q(J))-POL(J))81,81,37
37	E(J)=Q(J+1)*E(J)/Q(J)
	Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O
	GOTO 54
C
C	   CALCULATE DISPLACEMENT FOR DOUBLE ROOTS
C	      QUADRATIC EQUATION FOR DOUBLE ROOTS
C	      X**2-(Q(NRAN)+Q(NRAN+1)+E(NRAN))*X+Q(NRAN)*Q(NRAN+1)=0
38	P=0.5D0*(Q(NRAN)+E(NRAN)+Q(NRAN+1))
	O=P*P-Q(NRAN)*Q(NRAN+1)
	T=DSQRT(DABS(O))
C
C	   TEST FOR CONVERGENCE
	IF(S-TEPS)26,26,39
C
C	   ARE THERE COMPLEX ROOTS
39	IF(O)43,40,40
40	IF(P)42,41,41
41	T=-T
42	P=P+T
	R=S
	GOTO 34
C
C	   MODIFICATION FOR COMPLEX ROOTS
C	   IS DISPLACEMENT SMALL ENOUGH
43	IF(S-TDELT)44,35,35
C
C	      INITIALIZATION
44	O=Q(JBEG)+E(JBEG)-P
C
C	      TEST FOR SMALL DIVISOR
	IF(DABS(O)-POL(JBEG))81,81,45
45	T=(T/O)**2
	U=E(JBEG)*Q(JBEG+1)/(O*(1.0D0+T))
	V=O+U
C
C	   THREEFOLD LOOP FOR COMPLEX DISPLACEMENT
	KOUNT=KOUNT+2
	DO 53 J=JBEG,NRAN
	O=Q(J+1)+E(J+1)-U-P
C
C	      TEST FOR SMALL DIVISOR
	IF(DABS(V)-POL(J))46,46,49
46	IF(J-NRAN)81,47,81
47	EXPT=EXPT+P
	IF(ABS(SNGL(E(JEND)))-TOL)48,48,81
48	P=0.5D0*(V+O-E(JEND))
	O=P*P-(V-U)*(O-U*T-O*W*(1.D0+T)/Q(JEND))
	T=DSQRT(DABS(O))
	GOTO 26
C
C	      TEST FOR SMALL DIVISOR
49	IF(DABS(O)-POL(J+1))46,46,50
50	W=U*O/V
	T=T*(V/O)**2
	Q(J)=V+W-E(J-1)
	U=0.D0
	IF(J-NRAN)51,52,52
51	U=Q(J+2)*E(J+1)/(O*(1.D0+T))
52	V=O+U-W
C
C	      TEST FOR SMALL DIVISOR
	IF(DABS(Q(J))-POL(J))81,81,53
53	E(J)=W*V*(1.0D0+T)/Q(J)
	Q(NRAN+1)=V-E(NRAN)
54	EXPT=EXPT+P
	TEPS=TEPS*1.1
	TDELT=TDELT*1.1
	IF(KOUNT-LIMIT)32,55,55
C
C	   NO CONVERGENCE WITH FEASIBLE TOLERANCE
C	      ERROR RETURN IN CASE OF UNSATISFACTORY CONVERGENCE
55	IER=1
C
C	   REARRANGE CALCULATED ROOTS
56	IEND=NSAV-NRAN-1
	E(ISTA)=ESAV
	IF(IEND)59,59,57
57	DO 58 I=1,IEND
	J=ISTA+I
	K=NRAN+1+I
	E(J)=E(K)
58	Q(J)=Q(K)
59	IR=ISTA+IEND
C
C	   NORMAL RETURN
60	IR=IR-1
	IF(IR)78,78,61
C
C	   REARRANGE CALCULATED ROOTS
61	DO 62 I=1,IR
	Q(I)=Q(I+1)
62	E(I)=E(I+1)
C
C	   CALCULATE COEFFICIENT VECTOR FROM ROOTS
	POL(IR+1)=1.D0
	IEND=IR-1
	JBEG=1
	DO 69 J=1,IR
	ISTA=IR+1-J
	O=0.D0
	P=Q(ISTA)
	T=E(ISTA)
	IF(T)65,63,65
C
C	   MULTIPLY WITH LINEAR FACTOR
63	DO 64 I=ISTA,IR
	POL(I)=O-P*POL(I+1)
64	O=POL(I+1)
	GOTO 69
65	GOTO(66,67),JBEG
66	JBEG=2
	POL(ISTA)=0.D0
	GOTO 69
C
C	   MULTIPLY WITH QUADRATIC FACTOR
67	JBEG=1
	U=P*P+T*T
	P=P+P
	DO 68 I=ISTA,IEND
	POL(I)=O-P*POL(I+1)+U*POL(I+2)
68	O=POL(I+1)
	POL(IR)=O-P
69	CONTINUE
	IF(IER)78,70,78
C
C	   COMPARISON OF COEFFICIENT VECTORS, IE. TEST OF ACCURACY
70	P=0.D0
	DO 75 I=1,IR
	IF(C(I))72,71,72
71	O=DABS(POL(I))
	GOTO 73
72	O=DABS((POL(I)-C(I))/C(I))
73	IF(P-O)74,75,75
74	P=O
75	CONTINUE
	IF(SNGL(P)-TOL)77,76,76
76	IER=-1
77	Q(IR+1)=P
	E(IR+1)=0.D0
78	RETURN
C
C	   ERROR RETURNS
C	      ERROR RETURN FOR POLYNOMIALS OF DEGREE LESS THAN 1
79	IER=2
	IR=0
	RETURN
C
C	      ERROR RETURN IF THERE EXISTS NO S-FRACTION
80	IER=4
	IR=ISTA
	GOTO 60
C
C	      ERROR RETURN IN CASE OF INSTABLE QD-ALGORITHM
81	IER=3
	GOTO 56
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA12
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA12 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 12-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA12(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.36191360360615602D2
	Y=.33287369929782177D-15*FCT(X)
	X=.27661108779846090D2
	Y=Y+.13169240486156340D-11*FCT(X)
	X=.21396755936166109D2
	Y=Y+.60925085399751278D-9*FCT(X)
	X=.16432195087675313D2
	Y=Y+.8037942349882859D-7*FCT(X)
	X=.12390447963809471D2
	Y=Y+.43164914098046673D-5*FCT(X)
	X=.9075434230961203D1
	Y=Y+.11377383272808760D-3*FCT(X)
	X=.63699753880306349D1
	Y=Y+.16473849653768349D-2*FCT(X)
	X=.41984156448784132D1
	Y=Y+.14096711620145342D-1*FCT(X)
	X=.25098480972321280D1
	Y=Y+.7489094100646149D-1*FCT(X)
	X=.12695899401039615D1
	Y=Y+.25547924356911832D0*FCT(X)
	X=.45450668156378028D0
	Y=Y+.57235907069288604D0*FCT(X)
	X=.50361889117293951D-1
	Y=Y+.8538623277373985D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA16
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA16 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 16-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA16(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.50777223877537080D2
	Y=.14621352854768325D-21*FCT(X)
	X=.41081666525491202D2
	Y=Y+.18463473073036584D-17*FCT(X)
	X=.33781970488226166D2
	Y=Y+.23946880341856973D-14*FCT(X)
	X=.27831438211328676D2
	Y=Y+.8430020422652895D-12*FCT(X)
	X=.22821300693525208D2
	Y=Y+.11866582926793277D-9*FCT(X)
	X=.18537743178606694D2
	Y=Y+.8197664329541793D-8*FCT(X)
	X=.14851431341801250D2
	Y=Y+.31483355850911881D-6*FCT(X)
	X=.11677033673975957D2
	Y=Y+.7301170259124752D-5*FCT(X)
	X=.8955001337723390D1
	Y=Y+.10833168123639965D-3*FCT(X)
	X=.66422151797414440D1
	Y=Y+.10725367310559441D-2*FCT(X)
	X=.47067267076675872D1
	Y=Y+.7309780653308856D-2*FCT(X)
	X=.31246010507021443D1
	Y=Y+.35106857663146861D-1*FCT(X)
	X=.18779315076960743D1
	Y=Y+.12091626191182523D0*FCT(X)
	X=.9535531553908655D0
	Y=Y+.30253946815328497D0*FCT(X)
	X=.34220015601094768D0
	Y=Y+.55491628460505980D0*FCT(X)
	X=.37962914575313455D-1
	Y=Y+.7504767051856048D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA24
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA24 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 24-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA24(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.8055628081995041D2
	Y=.15871102921547994D-34*FCT(X)
	X=.69068601975304369D2
	Y=Y+.11969225386627757D-29*FCT(X)
	X=.60206666963057223D2
	Y=Y+.7370072160301340D-26*FCT(X)
	X=.52795432527283630D2
	Y=Y+.11129154937804570D-22*FCT(X)
	X=.46376979557540133D2
	Y=Y+.63767746470102769D-20*FCT(X)
	X=.40711598185543107D2
	Y=Y+.17460319202373353D-17*FCT(X)
	X=.35653703516328212D2
	Y=Y+.26303192453168170D-15*FCT(X)
	X=.31106464709046565D2
	Y=Y+.23951797309583587D-13*FCT(X)
	X=.27001406056472356D2
	Y=Y+.14093865163091778D-11*FCT(X)
	X=.23287932824879917D2
	Y=Y+.56305930756763382D-10*FCT(X)
	X=.19927425875242462D2
	Y=Y+.15860934990330765D-8*FCT(X)
	X=.16889671928527108D2
	Y=Y+.32450282717915397D-7*FCT(X)
	X=.14150586187285759D2
	Y=Y+.49373179873395010D-6*FCT(X)
	X=.11690695926056073D2
	Y=Y+.56945173834696962D-5*FCT(X)
	X=.9494095330026488D1
	Y=Y+.50571980554969778D-4*FCT(X)
	X=.7547704680023454D1
	Y=Y+.35030086360234566D-3*FCT(X)
	X=.58407332713236080D1
	Y=Y+.19127846396388306D-2*FCT(X)
	X=.43642830769353062D1
	Y=Y+.8306009823955105D-2*FCT(X)
	X=.31110524551477130D1
	Y=Y+.28889923149962199D-1*FCT(X)
	X=.20751129098523806D1
	Y=Y+.8095935396920770D-1*FCT(X)
	X=.12517406323627464D1
	Y=Y+.18364459415857036D0*FCT(X)
	X=.63729027873266879D0
	Y=Y+.33840894389128221D0*FCT(X)
	X=.22910231649262433D0
	Y=Y+.50792308532951820D0*FCT(X)
	X=.25437996585689359D-1
	Y=Y+.62200206075592616D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA32
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA32 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 32-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA32(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.11079926894707576D3
	Y=.11071413071713886D-27*FCT(X)
	X=.9791671642606276D2
	Y=Y+.33594959802163184D-22*FCT(X)
	X=.8785611994313352D22
	Y=Y+.68422760225114810D-18*FCT(X)
	X=.7933908652882320D2
	Y=Y+.31147812492595276D-14*FCT(X)
	X=.71868499359551422D2
	Y=Y+.50993217982259985D-11*FCT(X)
	X=.65184426376135782D2
	Y=Y+.38582071909299337D-8*FCT(X)
	X=.59129027934391951D2
	Y=Y+.15723595577851821D-5*FCT(X)
	X=.53597231826148512D2
	Y=Y+.38234137666012857D-3*FCT(X)
	X=.48514583867416048D2
	Y=Y+.59657255685597023D-1*FCT(X)
	X=.43825886369903902D2
	Y=Y+.63045091330075628D1*FCT(X)
	X=.39488797123368127D2
	Y=Y+.47037694213516382D3*FCT(X)
	X=.35469961396173283D2
	Y=Y+.25601867826448761D5*FCT(X)
	X=.31742543790616606D2
	Y=Y+.10437247453181695D7*FCT(X)
	X=.28284583194970531D2
	Y=Y+.32566814614194407D8*FCT(X)
	X=.25077856544198053D2
	Y=Y+.7918355533895448D9*FCT(X)
	X=.22107070382206007D2
	Y=Y+.15230434500290903D11*FCT(X)
	X=.19359271087268714D2
	Y=Y+.23472334846430987D12*FCT(X)
	X=.16823405362953694D2
	Y=Y+.29302506329522187D13*FCT(X)
	X=.14489986690780274D2
	Y=Y+.29910658734544941D14*FCT(X)
	X=.12350838217714770D2
	Y=Y+.25166805020623692D15*FCT(X)
	X=.10398891905552624D2
	Y=Y+.17576998461700718D16*FCT(X)
	X=.8628029857405929D1
	Y=Y+.10251858271572549D17*FCT(X)
	X=.70329577982838936D1
	Y=Y+.50196739702612497D17*FCT(X)
	X=.56091034574961513D1
	Y=Y+.20726581990151553D18*FCT(X)
	X=.43525345293301410D1
	Y=Y+.7245173957068918D18*FCT(X)
	X=.32598922564569419D1
	Y=Y+.21512081019758274D19*FCT(X)
	X=.23283376682103970D1
	Y=Y+.54406257907377837D19*FCT(X)
	X=.15555082314789380D1
	Y=Y+.11747996392819887D20*FCT(X)
	X=.9394832145007343D0
	Y=Y+.21699669861237368D20*FCT(X)
	X=.47875647727748885D0
	Y=Y+.34337168469816740D20*FCT(X)
	X=.17221572414539558D0
	Y=Y+.46598957212535609D20*FCT(X)
	X=.19127510968446856D-1
	Y=Y+.54275484988260796D20*FCT(X)
	Y=Y*1.D-20
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA4 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA4(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.8588635689012034D1
	Y=.39920814442273524D-3*FCT(X)
	X=.39269635013582872D1
	Y=Y+.34155966014826951D-1*FCT(X)
	X=.13390972881263614D1
	Y=Y+.41560465162978376D0*FCT(X)
	X=.14530352150331709D0
	Y=Y+.13222940251164826D1*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQA8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQA8 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.15-16.
C
C	..................................................................
C
	SUBROUTINE DQA8(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.21984272840962651D2
	Y=.53096149480223645D-9*FCT(X)
	X=.14972627088426393D2
	Y=Y+.46419616897304213D-6*FCT(X)
	X=.10093323675221343D2
	Y=Y+.54237201850757630D-4*FCT(X)
	X=.64831454286271704D1
	Y=Y+.18645680172483611D-2*FCT(X)
	X=.38094763614849071D1
	Y=Y+.25760623071019947D-1*FCT(X)
	X=.19051136350314284D1
	Y=Y+.16762008279797166D0*FCT(X)
	X=.67724908764928915D0
	Y=Y+.56129491705706735D0*FCT(X)
	X=.7479188259681827D-1
	Y=Y+.10158589580332275D1*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQATR
C
C
C	   PURPOSE
C	      TO COMPUTE AN APPROXIMATION FOR INTEGRAL(FCT(X), SUMMED
C	      OVER X FROM XL TO XU).
C
C	   USAGE
C	      CALL DQATR (XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      EPS    - SINGLE PRECISION UPPER BOUND OF THE ABSOLUTE ERROR.
C	      NDIM   - THE DIMENSION OF THE AUXILIARY STORAGE ARRAY AUX.
C	               NDIM-1 IS THE MAXIMAL NUMBER OF BISECTIONS OF
C	               THE INTERVAL (XL,XU).
C	      FCT    - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - RESULTING DOUBLE PRECISION APPROXIMATION FOR THE
C	               INTEGRAL VALUE.
C	      IER    - A RESULTING ERROR PARAMETER.
C	      AUX    - AUXILIARY DOUBLE PRECISION STORAGE ARRAY WITH
C	               DIMENSION NDIM.
C
C	   REMARKS
C	      ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	      IER=0  - IT WAS POSSIBLE TO REACH THE REQUIRED ACCURACY.
C	               NO ERROR.
C	      IER=1  - IT IS IMPOSSIBLE TO REACH THE REQUIRED ACCURACY
C	               BECAUSE OF ROUNDING ERRORS.
C	      IER=2  - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE NDIM
C	               IS LESS THAN 5, OR THE REQUIRED ACCURACY COULD NOT
C	               BE REACHED WITHIN NDIM-1 STEPS. NDIM SHOULD BE
C	               INCREASED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE CODED BY THE USER. ITS DOUBLE PRECISION ARGUMENT X
C	      SHOULD NOT BE DESTROYED.
C
C	   METHOD
C	      EVALUATION OF Y IS DONE BY MEANS OF TRAPEZOIDAL RULE IN
C	      CONNECTION WITH ROMBERGS PRINCIPLE. ON RETURN Y CONTAINS
C	      THE BEST POSSIBLE APPROXIMATION OF THE INTEGRAL VALUE AND
C	      VECTOR AUX THE UPWARD DIAGONAL OF ROMBERG SCHEME.
C	      COMPONENTS AUX(I) (I=1,2,...,IEND, WITH IEND LESS THAN OR
C	      EQUAL TO NDIM) BECOME APPROXIMATIONS TO INTEGRAL VALUE WITH
C	      DECREASING ACCURACY BY MULTIPLICATION WITH (XU-XL).
C	      FOR REFERENCE, SEE
C	      (1) FILIPPI, DAS VERFAHREN VON ROMBERG-STIEFEL-BAUER ALS
C	          SPEZIALFALL DES ALLGEMEINEN PRINZIPS VON RICHARDSON,
C	          MATHEMATIK-TECHNIK-WIRTSCHAFT, VOL.11, ISS.2 (1964),
C	          PP.49-54.
C	      (2) BAUER, ALGORITHM 60, CACM, VOL.4, ISS.6 (1961), PP.255.
C
C	..................................................................
C
	SUBROUTINE DQATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
C
C
	DIMENSION AUX(1)
	DOUBLE PRECISION AUX,XL,XU,X,Y,H,HH,HD,P,Q,SM,FCT
C
C	PREPARATIONS OF ROMBERG-LOOP
	AUX(1)=.5D0*(FCT(XL)+FCT(XU))
	H=XU-XL
	IF(NDIM-1)8,8,1
1	IF(H)2,10,2
C
C	NDIM IS GREATER THAN 1 AND H IS NOT EQUAL TO 0.
2	HH=H
	E=EPS/DABS(H)
	DELT2=0.
	P=1.D0
	JJ=1
	DO 7 I=2,NDIM
	Y=AUX(1)
	DELT1=DELT2
	HD=HH
	HH=.5D0*HH
	P=.5D0*P
	X=XL+HH
	SM=0.D0
	DO 3 J=1,JJ
	SM=SM+FCT(X)
3	X=X+HD
	AUX(I)=.5D0*AUX(I-1)+P*SM
C	A NEW APPROXIMATION OF INTEGRAL VALUE IS COMPUTED BY MEANS OF
C	TRAPEZOIDAL RULE.
C
C	START OF ROMBERGS EXTRAPOLATION METHOD.
	Q=1.D0
	JI=I-1
	DO 4 J=1,JI
	II=I-J
	Q=Q+Q
	Q=Q+Q
4	AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.D0)
C	END OF ROMBERG-STEP
C
	DELT2=DABS(Y-AUX(1))
	IF(I-5)7,5,5
5	IF(DELT2-E)10,10,6
6	IF(DELT2-DELT1)7,11,11
7	JJ=JJ+JJ
8	IER=2
9	Y=H*AUX(1)
	RETURN
10	IER=0
	GO TO 9
11	IER=1
	Y=H*Y
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG12
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG12 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 12-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 23
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG12(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.49078031712335963D0*B
	Y=.23587668193255914D-1*(FCT(A+C)+FCT(A-C))
	C=.45205862818523743D0*B
	Y=Y+.53469662997659215D-1*(FCT(A+C)+FCT(A-C))
	C=.38495133709715234D0*B
	Y=Y+.8003916427167311D-1*(FCT(A+C)+FCT(A-C))
	C=.29365897714330872D0*B
	Y=Y+.10158371336153296D0*(FCT(A+C)+FCT(A-C))
	C=.18391574949909010D0*B
	Y=Y+.11674626826917740D0*(FCT(A+C)+FCT(A-C))
	C=.62616704255734458D-1*B
	Y=B*(Y+.12457352290670139D0*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG16
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG16 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 16-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 31
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG16(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.49470046749582497D0*B
	Y=.13576229705877047D-1*(FCT(A+C)+FCT(A-C))
	C=.47228751153661629D0*B
	Y=Y+.31126761969323946D-1*(FCT(A+C)+FCT(A-C))
	C=.43281560119391587D0*B
	Y=Y+.47579255841246392D-1*(FCT(A+C)+FCT(A-C))
	C=.37770220417750152D0*B
	Y=Y+.62314485627766936D-1*(FCT(A+C)+FCT(A-C))
	C=.30893812220132187D0*B
	Y=Y+.7479799440828837D-1*(FCT(A+C)+FCT(A-C))
	C=.22900838882861369D0*B
	Y=Y+.8457825969750127D-1*(FCT(A+C)+FCT(A-C))
	C=.14080177538962946D0*B
	Y=Y+.9130170752246179D-1*(FCT(A+C)+FCT(A-C))
	C=.47506254918818720D-1*B
	Y=B*(Y+.9472530522753425D-1*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG24
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG24 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 24-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 47
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG24(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.49759360999851068D0*B
	Y=.61706148999935998D-2*(FCT(A+C)+FCT(A-C))
	C=.48736427798565475D0*B
	Y=Y+.14265694314466832D-1*(FCT(A+C)+FCT(A-C))
	C=.46913727600136638D0*B
	Y=Y+.22138719408709903D-1*(FCT(A+C)+FCT(A-C))
	C=.44320776350220052D0*B
	Y=Y+.29649292457718390D-1*(FCT(A+C)+FCT(A-C))
	C=.41000099298695146D0*B
	Y=Y+.36673240705540153D-1*(FCT(A+C)+FCT(A-C))
	C=.37006209578927718D0*B
	Y=Y+.43095080765976638D-1*(FCT(A+C)+FCT(A-C))
	C=.32404682596848778D0*B
	Y=Y+.48809326052056944D-1*(FCT(A+C)+FCT(A-C))
	C=.27271073569441977D0*B
	Y=Y+.53722135057982817D-1*(FCT(A+C)+FCT(A-C))
	C=.21689675381302257D0*B
	Y=Y+.57752834026862801D-1*(FCT(A+C)+FCT(A-C))
	C=.15752133984808169D0*B
	Y=Y+.60835236463901696D-1*(FCT(A+C)+FCT(A-C))
	C=.9555943373680815D-1*B
	Y=Y+.62918728173414148D-1*(FCT(A+C)+FCT(A-C))
	C=.32028446431302813D-1*B
	Y=B*(Y+.63969097673376078D-1*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG32
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG32 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 32-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 63
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG32(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.49863193092474078D0*B
	Y=.35093050047350483D-2*(FCT(A+C)+FCT(A-C))
	C=.49280575577263417D0*B
	Y=Y+.8137197365452835D-2*(FCT(A+C)+FCT(A-C))
	C=.48238112779375322D0*B
	Y=Y+.12696032654631030D-1*(FCT(A+C)+FCT(A-C))
	C=.46745303796886984D0*B
	Y=Y+.17136931456510717D-1*(FCT(A+C)+FCT(A-C))
	C=.44816057788302606D0*B
	Y=Y+.21417949011113340D-1*(FCT(A+C)+FCT(A-C))
	C=.42468380686628499D0*B
	Y=Y+.25499029631188088D-1*(FCT(A+C)+FCT(A-C))
	C=.39724189798397120D0*B
	Y=Y+.29342046739267774D-1*(FCT(A+C)+FCT(A-C))
	C=.36609105937014484D0*B
	Y=Y+.32911111388180923D-1*(FCT(A+C)+FCT(A-C))
	C=.33152213346510760D0*B
	Y=Y+.36172897054424253D-1*(FCT(A+C)+FCT(A-C))
	C=.29385787862038116D0*B
	Y=Y+.39096947893535153D-1*(FCT(A+C)+FCT(A-C))
	C=.25344995446611470D0*B
	Y=Y+.41655962113473378D-1*(FCT(A+C)+FCT(A-C))
	C=.21067563806531767D0*B
	Y=Y+.43826046502201906D-1*(FCT(A+C)+FCT(A-C))
	C=.16593430114106382D0*B
	Y=Y+.45586939347881942D-1*(FCT(A+C)+FCT(A-C))
	C=.11964368112606854D0*B
	Y=Y+.46922199540402283D-1*(FCT(A+C)+FCT(A-C))
	C=.7223598079139825D-1*B
	Y=Y+.47819360039637430D-1*(FCT(A+C)+FCT(A-C))
	C=.24153832843869158D-1*B
	Y=B*(Y+.48270044257363900D-1*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG4 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 7
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG4(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.43056815579702629D0*B
	Y=.17392742256872693D0*(FCT(A+C)+FCT(A-C))
	C=.16999052179242813D0*B
	Y=B*(Y+.32607257743127307D0*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQG8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL DQG8 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL.
C	      XU     - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 15
C	      EXACTLY. FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340.
C
C	..................................................................
C
	SUBROUTINE DQG8(XL,XU,FCT,Y)
C
C
	DOUBLE PRECISION XL,XU,Y,A,B,C,FCT
C
	A=.5D0*(XU+XL)
	B=XU-XL
	C=.48014492824876812D0*B
	Y=.50614268145188130D-1*(FCT(A+C)+FCT(A-C))
	C=.39833323870681337D0*B
	Y=Y+.11119051722668724D0*(FCT(A+C)+FCT(A-C))
	C=.26276620495816449D0*B
	Y=Y+.15685332293894364D0*(FCT(A+C)+FCT(A-C))
	C=.9171732124782490D-1*B
	Y=B*(Y+.18134189168918099D0*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH16
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH16 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH16(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.46887389393058184D1
	Z=-X
	Y=.26548074740111822D-9*(FCT(X)+FCT(Z))
	X=.38694479048601227D1
	Z=-X
	Y=Y+.23209808448652107D-6*(FCT(X)+FCT(Z))
	X=.31769991619799560D1
	Z=-X
	Y=Y+.27118600925378815D-4*(FCT(X)+FCT(Z))
	X=.25462021578474814D1
	Z=-X
	Y=Y+.9322840086241805D-3*(FCT(X)+FCT(Z))
	X=.19517879909162540D1
	Z=-X
	Y=Y+.12880311535509974D-1*(FCT(X)+FCT(Z))
	X=.13802585391988808D1
	Z=-X
	Y=Y+.8381004139898583D-1*(FCT(X)+FCT(Z))
	X=.8229514491446559D0
	Z=-X
	Y=Y+.28064745852853368D0*(FCT(X)+FCT(Z))
	X=.27348104613815245D0
	Z=-X
	Y=Y+.50792947901661374D0*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH24
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH24 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH24(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.60159255614257397D1
	Z=-X
	Y=.16643684964891089D-15*(FCT(X)+FCT(Z))
	X=.52593829276680444D1
	Z=-X
	Y=Y+.65846202430781701D-12*(FCT(X)+FCT(Z))
	X=.46256627564237873D1
	Z=-X
	Y=Y+.30462542699875639D-9*(FCT(X)+FCT(Z))
	X=.40536644024481495D1
	Z=-X
	Y=Y+.40189711749414297D-7*(FCT(X)+FCT(Z))
	X=.35200068130345247D1
	Z=-X
	Y=Y+.21582457049023336D-5*(FCT(X)+FCT(Z))
	X=.30125461375655648D1
	Z=-X
	Y=Y+.56886916364043798D-4*(FCT(X)+FCT(Z))
	X=.25238810170114270D1
	Z=-X
	Y=Y+.8236924826884175D-3*(FCT(X)+FCT(Z))
	X=.20490035736616989D1
	Z=-X
	Y=Y+.70483558100726710D-2*(FCT(X)+FCT(Z))
	X=.15842500109616941D1
	Z=-X
	Y=Y+.37445470503230746D-1*(FCT(X)+FCT(Z))
	X=.11267608176112451D1
	Z=-X
	Y=Y+.12773962178455916D0*(FCT(X)+FCT(Z))
	X=.67417110703721224D0
	Z=-X
	Y=Y+.28617953534644302D0*(FCT(X)+FCT(Z))
	X=.22441454747251559D0
	Z=-X
	Y=Y+.42693116386869925D0*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH32
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH32 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH32(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.71258139098307276D1
	Z=-X
	Y=.7310676427384162D-22*(FCT(X)+FCT(Z))
	X=.64094981492696604D1
	Z=-X
	Y=Y+.9231736536518292D-18*(FCT(X)+FCT(Z))
	X=.58122259495159138D1
	Z=-X
	Y=Y+.11973440170928487D-14*(FCT(X)+FCT(Z))
	X=.52755509865158801D1
	Z=-X
	Y=Y+.42150102113264476D-12*(FCT(X)+FCT(Z))
	X=.47771645035025964D1
	Z=-X
	Y=Y+.59332914633966386D-10*(FCT(X)+FCT(Z))
	X=.43055479533511984D1
	Z=-X
	Y=Y+.40988321647708966D-8*(FCT(X)+FCT(Z))
	X=.38537554854714446D1
	Z=-X
	Y=Y+.15741677925455940D-6*(FCT(X)+FCT(Z))
	X=.34171674928185707D1
	Z=-X
	Y=Y+.36505851295623761D-5*(FCT(X)+FCT(Z))
	X=.29924908250023742D1
	Z=-X
	Y=Y+.54165840618199826D-4*(FCT(X)+FCT(Z))
	X=.25772495377323175D1
	Z=-X
	Y=Y+.53626836552797205D-3*(FCT(X)+FCT(Z))
	X=.21694991836061122D1
	Z=-X
	Y=Y+.36548903266544281D-2*(FCT(X)+FCT(Z))
	X=.17676541094632016D1
	Z=-X
	Y=Y+.17553428831573430D-1*(FCT(X)+FCT(Z))
	X=.13703764109528718D1
	Z=-X
	Y=Y+.60458130955912614D-1*(FCT(X)+FCT(Z))
	X=.9765004635896828D0
	Z=-X
	Y=Y+.15126973407664248D0*(FCT(X)+FCT(Z))
	X=.58497876543593245D0
	Z=-X
	Y=Y+.27745814230252990D0*(FCT(X)+FCT(Z))
	X=.19484074156939933D0
	Z=-X
	Y=Y+.37523835259280239D0*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH48
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH48 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 48-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 95.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH48(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.8975315081931687D1
	Z=-X
	Y=.7935551460773997D-35*(FCT(X)+FCT(Z))
	X=.8310752190704784D1
	Z=-X
	Y=Y+.59846126933138784D-30*(FCT(X)+FCT(Z))
	X=.7759295519765775D1
	Z=-X
	Y=Y+.36850360801506699D-26*(FCT(X)+FCT(Z))
	X=.7266046554164350D1
	Z=-X
	Y=Y+.55645774689022848D-23*(FCT(X)+FCT(Z))
	X=.68100645780741414D1
	Z=-X
	Y=Y+.31883873235051384D-20*(FCT(X)+FCT(Z))
	X=.63805640961864106D1
	Z=-X
	Y=Y+.8730159601186677D-18*(FCT(X)+FCT(Z))
	X=.59710722250135454D1
	Z=-X
	Y=Y+.13151596226584085D-15*(FCT(X)+FCT(Z))
	X=.55773169812237286D1
	Z=-X
	Y=Y+.11975898654791794D-13*(FCT(X)+FCT(Z))
	X=.51962877187923645D1
	Z=-X
	Y=Y+.70469325815458891D-12*(FCT(X)+FCT(Z))
	X=.48257572281332095D1
	Z=-X
	Y=Y+.28152965378381691D-10*(FCT(X)+FCT(Z))
	X=.44640145469344589D1
	Z=-X
	Y=Y+.7930467495165382D-9*(FCT(X)+FCT(Z))
	X=.41097046035605902D1
	Z=-X
	Y=Y+.16225141358957698D-7*(FCT(X)+FCT(Z))
	X=.37617264902283578D1
	Z=-X
	Y=Y+.24686589936697505D-6*(FCT(X)+FCT(Z))
	X=.34191659693638846D1
	Z=-X
	Y=Y+.28472586917348481D-5*(FCT(X)+FCT(Z))
	X=.30812489886451058D1
	Z=-X
	Y=Y+.25285990277484889D-4*(FCT(X)+FCT(Z))
	X=.27473086248223832D1
	Z=-X
	Y=Y+.17515043180117283D-3*(FCT(X)+FCT(Z))
	X=.24167609048732165D1
	Z=-X
	Y=Y+.9563923198194153D-3*(FCT(X)+FCT(Z))
	X=.20890866609442764D1
	Z=-X
	Y=Y+.41530049119775525D-2*(FCT(X)+FCT(Z))
	X=.17638175798953000D1
	Z=-X
	Y=Y+.14444961574981099D-1*(FCT(X)+FCT(Z))
	X=.14405252201375652D1
	Z=-X
	Y=Y+.40479676984603849D-1*(FCT(X)+FCT(Z))
	X=.11188121524021566D1
	Z=-X
	Y=Y+.9182229707928518D-1*(FCT(X)+FCT(Z))
	X=.7983046277785622D0
	Z=-X
	Y=Y+.16920447194564111D0*(FCT(X)+FCT(Z))
	X=.47864633759449610D0
	Z=-X
	Y=Y+.25396154266475910D0*(FCT(X)+FCT(Z))
	X=.15949293584886247D0
	Z=-X
	Y=Y+.31100103037796308D0*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH64
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH64 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 64-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 127.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH64(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.10526123167960546D2
	Z=-X
	Y=.55357065358569428D-28*(FCT(X)+FCT(Z))
	X=.9895287586829539D1
	Z=-X
	Y=Y+.16797479901081592D-22*(FCT(X)+FCT(Z))
	X=.9373159549646721D21
	Z=-X
	Y=Y+.34211380112557405D-18*(FCT(X)+FCT(Z))
	X=.8907249099964770D1
	Z=-X
	Y=Y+.15573906246297638D-14*(FCT(X)+FCT(Z))
	X=.8477529083379863D1
	Z=-X
	Y=Y+.25496608991129993D-11*(FCT(X)+FCT(Z))
	X=.8073687285010225D1
	Z=-X
	Y=Y+.19291035954649669D-8*(FCT(X)+FCT(Z))
	X=.7689540164040497D1
	Z=-X
	Y=Y+.7861797788925910D-6*(FCT(X)+FCT(Z))
	X=.7321013032780949D1
	Z=-X
	Y=Y+.19117068833006428D-3*(FCT(X)+FCT(Z))
	X=.69652411205511075D1
	Z=-X
	Y=Y+.29828627842798512D-1*(FCT(X)+FCT(Z))
	X=.66201122626360274D1
	Z=-X
	Y=Y+.31522545665037814D1*(FCT(X)+FCT(Z))
	X=.62840112287748282D1
	Z=-X
	Y=Y+.23518847106758191D3*(FCT(X)+FCT(Z))
	X=.59556663267994860D1
	Z=-X
	Y=Y+.12800933913224380D5*(FCT(X)+FCT(Z))
	X=.56340521643499721D1
	Z=-X
	Y=Y+.52186237265908475D6*(FCT(X)+FCT(Z))
	X=.53183252246332709D1
	Z=-X
	Y=Y+.16283407307097204D8*(FCT(X)+FCT(Z))
	X=.50077796021987682D1
	Z=-X
	Y=Y+.39591777669477239D9*(FCT(X)+FCT(Z))
	X=.47018156474074998D1
	Z=-X
	Y=Y+.7615217250145451D10*(FCT(X)+FCT(Z))
	X=.43999171682281376D1
	Z=-X
	Y=Y+.11736167423215493D12*(FCT(X)+FCT(Z))
	X=.41016344745666567D1
	Z=-X
	Y=Y+.14651253164761094D13*(FCT(X)+FCT(Z))
	X=.38065715139453605D1
	Z=-X
	Y=Y+.14955329367272471D14*(FCT(X)+FCT(Z))
	X=.35143759357409062D1
	Z=-X
	Y=Y+.12583402510311846D15*(FCT(X)+FCT(Z))
	X=.32247312919920357D1
	Z=-X
	Y=Y+.8788499230850359D15*(FCT(X)+FCT(Z))
	X=.29373508230046218D1
	Z=-X
	Y=Y+.51259291357862747D16*(FCT(X)+FCT(Z))
	X=.26519724354306350D1
	Z=-X
	Y=Y+.25098369851306249D17*(FCT(X)+FCT(Z))
	X=.23683545886324014D1
	Z=-X
	Y=Y+.10363290995075777D18*(FCT(X)+FCT(Z))
	X=.20862728798817620D1
	Z=-X
	Y=Y+.36225869785344588D18*(FCT(X)+FCT(Z))
	X=.18055171714655449D1
	Z=-X
	Y=Y+.10756040509879137D19*(FCT(X)+FCT(Z))
	X=.15258891402098637D1
	Z=-X
	Y=Y+.27203128953688918D19*(FCT(X)+FCT(Z))
	X=.12472001569431179D1
	Z=-X
	Y=Y+.58739981964099435D19*(FCT(X)+FCT(Z))
	X=.9692694230711780D0
	Z=-X
	Y=Y+.10849834930618684D20*(FCT(X)+FCT(Z))
	X=.69192230581004458D0
	Z=-X
	Y=Y+.17168584234908370D20*(FCT(X)+FCT(Z))
	X=.41498882412107868D0
	Z=-X
	Y=Y+.23299478606267805D20*(FCT(X)+FCT(Z))
	X=.13830224498700972D0
	Z=-X
	Y=Y+.27137742494130398D20*(FCT(X)+FCT(Z))
	Y=Y*1.D-20
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQH8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL DQH8 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.213-214.
C
C	..................................................................
C
	SUBROUTINE DQH8(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,Z,FCT
C
	X=.29306374202572440D1
	Z=-X
	Y=.19960407221136762D-3*(FCT(X)+FCT(Z))
	X=.19816567566958429D1
	Z=-X
	Y=Y+.17077983007413475D-1*(FCT(X)+FCT(Z))
	X=.11571937124467802D1
	Z=-X
	Y=Y+.20780232581489188D0*(FCT(X)+FCT(Z))
	X=.38118699020732212D0
	Z=-X
	Y=Y+.66114701255824129D0*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQHFE
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION AND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL DQHFE (H,Y,DERY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH Y OR DERY.
C	      NDIM   - THE DIMENSION OF VECTORS Y,DERY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
C	      (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-230.
C
C	..................................................................
C
	SUBROUTINE DQHFE(H,Y,DERY,Z,NDIM)
C
C
	DIMENSION Y(1),DERY(1),Z(1)
	DOUBLE PRECISION Y,DERY,Z,H,HH,HS,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
1	HH=.5D0*H
	HS=.16666666666666667D0*H
C
C	INTEGRATION LOOP
	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I)))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQHFG
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      GENERAL TABLE OF ARGUMENT, FUNCTION, AND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL DQHFG (X,Y,DERY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH X, Y OR DERY.
C	      NDIM   - THE DIMENSION OF VECTORS X,Y,DERY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
C	      (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-230.
C
C	..................................................................
C
	SUBROUTINE DQHFG(X,Y,DERY,Z,NDIM)
C
C
	DIMENSION X(1),Y(1),DERY(1),Z(1)
	DOUBLE PRECISION X,Y,DERY,Z,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
C
C	INTEGRATION LOOP
1	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=.5D0*(X(I)-X(I-1))
	SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.33333333333333333D0*SUM2*
     1(DERY(I-1)-DERY(I)))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQHSE
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION, FIRST DERIVATIVE,
C	      AND SECOND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL DQHSE (H,Y,FDY,SDY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      FDY    - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE.
C	      SDY    - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH Y, FDY OR SDY.
C	      NDIM   - THE DIMENSION OF VECTORS Y,FDY,SDY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	      PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	      PP.227-230.
C
C	..................................................................
C
	SUBROUTINE DQHSE(H,Y,FDY,SDY,Z,NDIM)
C
C
	DIMENSION Y(1),FDY(1),SDY(1),Z(1)
	DOUBLE PRECISION Y,FDY,SDY,Z,H,HH,HF,HT,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
1	HH=.5D0*H
	HF=.2D0*H
	HT=.08333333333333333D0*H
C
C	INTEGRATION LOOP
	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+
     1              HT*(SDY(I-1)+SDY(I))))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQHSG
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      GENERAL TABLE OF ARGUMENT, FUNCTION, FIRST DERIVATIVE,
C	      AND SECOND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL DQHSG (X,Y,FDY,SDY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      FDY    - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE.
C	      SDY    - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH X, Y, FDY OR SDY.
C	      NDIM   - THE DIMENSION OF VECTORS X,Y,FDY,SDY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	      PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	      PP.227-230.
C
C	..................................................................
C
	SUBROUTINE DQHSG(X,Y,FDY,SDY,Z,NDIM)
C
C
	DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1)
	DOUBLE PRECISION X,Y,FDY,SDY,Z,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
C
C	INTEGRATION LOOP
1	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=.5D0*(X(I)-X(I-1))
	SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4D0*SUM2*((FDY(I-1)-FDY(I))+
     1     .16666666666666667D0*SUM2*(SDY(I-1)+SDY(I))))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL12
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL12 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 12-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL12(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.37099121044466920D2
	Y=.8148077467426242D-15*FCT(X)
	X=.28487967250984000D2
	Y=Y+.30616016350350208D-11*FCT(X)
	X=.22151090379397006D2
	Y=Y+.13423910305150041D-8*FCT(X)
	X=.17116855187462256D2
	Y=Y+.16684938765409103D-6*FCT(X)
	X=.13006054993306348D2
	Y=Y+.8365055856819799D-5*FCT(X)
	X=.9621316842456867D1
	Y=Y+.20323159266299939D-3*FCT(X)
	X=.68445254531151773D1
	Y=Y+.26639735418653159D-2*FCT(X)
	X=.45992276394183485D1
	Y=Y+.20102381154634097D-1*FCT(X)
	X=.28337513377435072D1
	Y=Y+.9044922221168093D-1*FCT(X)
	X=.15126102697764188D1
	Y=Y+.24408201131987756D0*FCT(X)
	X=.61175748451513067D0
	Y=Y+.37775927587313798D0*FCT(X)
	X=.11572211735802068D0
	Y=Y+.26473137105544319D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL16
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL16 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL16(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.51701160339543318D2
	Y=.41614623703728552D-21*FCT(X)
	X=.41940452647688333D2
	Y=Y+.50504737000355128D-17*FCT(X)
	X=.34583398702286626D2
	Y=Y+.62979670025178678D-14*FCT(X)
	X=.28578729742882140D2
	Y=Y+.21270790332241030D-11*FCT(X)
	X=.23515905693991909D2
	Y=Y+.28623502429738816D-9*FCT(X)
	X=.19180156856753135D2
	Y=Y+.18810248410796732D-7*FCT(X)
	X=.15441527368781617D2
	Y=Y+.68283193308711996D-6*FCT(X)
	X=.12214223368866159D2
	Y=Y+.14844586873981299D-4*FCT(X)
	X=.9438314336391939D1
	Y=Y+.20427191530827846D-3*FCT(X)
	X=.70703385350482341D1
	Y=Y+.18490709435263109D-2*FCT(X)
	X=.50780186145497679D1
	Y=Y+.11299900080339453D-1*FCT(X)
	X=.34370866338932066D1
	Y=Y+.47328928694125219D-1*FCT(X)
	X=.21292836450983806D1
	Y=Y+.13629693429637754D0*FCT(X)
	X=.11410577748312269D1
	Y=Y+.26579577764421415D0*FCT(X)
	X=.46269632891508083D0
	Y=Y+.33105785495088417D0*FCT(X)
	X=.8764941047892784D-1
	Y=Y+.20615171495780099D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL24
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL24 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL24(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.8149827923394889D2
	Y=.55753457883283568D-34*FCT(X)
	X=.69962240035105030D2
	Y=Y+.40883015936806578D-29*FCT(X)
	X=.61058531447218762D2
	Y=Y+.24518188458784027D-25*FCT(X)
	X=.53608574544695070D2
	Y=Y+.36057658645529590D-22*FCT(X)
	X=.47153106445156323D2
	Y=Y+.20105174645555035D-19*FCT(X)
	X=.41451720484870767D2
	Y=Y+.53501888130100376D-17*FCT(X)
	X=.36358405801651622D2
	Y=Y+.7819800382459448D-15*FCT(X)
	X=.31776041352374723D2
	Y=Y+.68941810529580857D-13*FCT(X)
	X=.27635937174332717D2
	Y=Y+.39177365150584514D-11*FCT(X)
	X=.23887329848169733D2
	Y=Y+.15070082262925849D-9*FCT(X)
	X=.20491460082616425D2
	Y=Y+.40728589875499997D-8*FCT(X)
	X=.17417992646508979D2
	Y=Y+.7960812959133630D-7*FCT(X)
	X=.14642732289596674D2
	Y=Y+.11513158127372799D-5*FCT(X)
	X=.12146102711729766D2
	Y=Y+.12544721977993333D-4*FCT(X)
	X=.9912098015077706D1
	Y=Y+.10446121465927518D-3*FCT(X)
	X=.7927539247172152D1
	Y=Y+.67216256409354789D-3*FCT(X)
	X=.61815351187367654D1
	Y=Y+.33693490584783036D-2*FCT(X)
	X=.46650837034671708D1
	Y=Y+.13226019405120157D-1*FCT(X)
	X=.33707742642089977D1
	Y=Y+.40732478151408646D-1*FCT(X)
	X=.22925620586321903D1
	Y=Y+.9816627262991889D-1*FCT(X)
	X=.14255975908036131D1
	Y=Y+.18332268897777802D0*FCT(X)
	X=.7660969055459366D0
	Y=Y+.25880670727286980D0*FCT(X)
	X=.31123914619848373D0
	Y=Y+.25877410751742390D0*FCT(X)
	X=.59019852181507977D-1
	Y=Y+.14281197333478185D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL32
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL32 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL32(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.11175139809793770D3
	Y=.45105361938989742D-27*FCT(X)
	X=.9882954286828397D2
	Y=Y+.13386169421062563D-21*FCT(X)
	X=.8873534041789240D2
	Y=Y+.26715112192401370D-17*FCT(X)
	X=.8018744697791352D2
	Y=Y+.11922487600982224D-13*FCT(X)
	X=.7268762809066271D2
	Y=Y+.19133754944542243D-10*FCT(X)
	X=.65975377287935053D2
	Y=Y+.14185605454630369D-7*FCT(X)
	X=.59892509162134018D2
	Y=Y+.56612941303973594D-5*FCT(X)
	X=.54333721333396907D2
	Y=Y+.13469825866373952D-2*FCT(X)
	X=.49224394987308639D2
	Y=Y+.20544296737880454D0*FCT(X)
	X=.44509207995754938D2
	Y=Y+.21197922901636186D2*FCT(X)
	X=.40145719771539442D2
	Y=Y+.15421338333938234D4*FCT(X)
	X=.36100494805751974D2
	Y=Y+.8171823443420719D5*FCT(X)
	X=.32346629153964737D2
	Y=Y+.32378016577292665D7*FCT(X)
	X=.28862101816323475D2
	Y=Y+.9799379288727094D8*FCT(X)
	X=.25628636022459248D2
	Y=Y+.23058994918913361D10*FCT(X)
	X=.22630889013196774D2
	Y=Y+.42813829710409289D11*FCT(X)
	X=.19855860940336055D2
	Y=Y+.63506022266258067D12*FCT(X)
	X=.17292454336715315D2
	Y=Y+.7604567879120781D13*FCT(X)
	X=.14931139755522557D2
	Y=Y+.7416404578667552D14*FCT(X)
	X=.12763697986742725D2
	Y=Y+.59345416128686329D15*FCT(X)
	X=.10783018632539972D2
	Y=Y+.39203419679879472D16*FCT(X)
	X=.8982940924212596D1
	Y=Y+.21486491880136419D17*FCT(X)
	X=.7358126733186241D1
	Y=Y+.9808033066149551D17*FCT(X)
	X=.59039585041742439D1
	Y=Y+.37388162946115248D18*FCT(X)
	X=.46164567697497674D1
	Y=Y+.11918214834838557D19*FCT(X)
	X=.34922132730219945D1
	Y=Y+.31760912509175070D19*FCT(X)
	X=.25283367064257949D1
	Y=Y+.70578623865717442D19*FCT(X)
	X=.17224087764446454D1
	Y=Y+.12998378628607176D20*FCT(X)
	X=.10724487538178176D1
	Y=Y+.19590333597288104D20*FCT(X)
	X=.57688462930188643D0
	Y=Y+.23521322966984801D20*FCT(X)
	X=.23452610951961854D0
	Y=Y+.21044310793881323D20*FCT(X)
	X=.44489365833267018D-1
	Y=Y+.10921834195238497D20*FCT(X)
	Y=Y*1.D-20
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL4 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL4(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.9395070912301133D1
	Y=.53929470556132745D-3*FCT(X)
	X=.45366202969211280D1
	Y=Y+.38887908515005384D-1*FCT(X)
	X=.17457611011583466D1
	Y=Y+.35741869243779969D0*FCT(X)
	X=.32254768961939231D0
	Y=Y+.60315410434163360D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQL8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL DQL8 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      Y      - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
C	      FOR REFERENCE, SEE
C	      SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF
C	      CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED
C	      GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT
C	      TR00.1100 (MARCH 1964), PP.24-25.
C
C	..................................................................
C
	SUBROUTINE DQL8(FCT,Y)
C
C
	DOUBLE PRECISION X,Y,FCT
C
	X=.22863131736889264D2
	Y=.10480011748715104D-8*FCT(X)
	X=.15740678641278005D2
	Y=Y+.8485746716272532D-6*FCT(X)
	X=.10758516010180995D2
	Y=Y+.9076508773358213D-4*FCT(X)
	X=.70459054023934657D1
	Y=Y+.27945362352256725D-2*FCT(X)
	X=.42667001702876588D1
	Y=Y+.33343492261215652D-1*FCT(X)
	X=.22510866298661307D1
	Y=Y+.17579498663717181D0*FCT(X)
	X=.9037017767993799D0
	Y=Y+.41878678081434296D0*FCT(X)
	X=.17027963230510100D0
	Y=Y+.36918858934163753D0*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQSF
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION VALUES.
C
C	   USAGE
C	      CALL DQSF (H,Y,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH Y.
C	      NDIM   - THE DIMENSION OF VECTORS Y AND Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 3.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A
C	      COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF
C	      ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3
C	      TRUNCATION ERROR OF Z(2) IS OF ORDER H**4.
C	      FOR REFERENCE, SEE
C	      (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76.
C	      (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.214-221.
C
C	..................................................................
C
	SUBROUTINE DQSF(H,Y,Z,NDIM)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION Y,Z,H,HT,SUM1,SUM2,AUX,AUX1,AUX2
C
	HT=.33333333333333333D0*H
	IF(NDIM-5)7,8,1
C
C	NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP
1	SUM1=Y(2)+Y(2)
	SUM1=SUM1+SUM1
	SUM1=HT*(Y(1)+SUM1+Y(3))
	AUX1=Y(4)+Y(4)
	AUX1=AUX1+AUX1
	AUX1=SUM1+HT*(Y(3)+AUX1+Y(5))
	AUX2=HT*(Y(1)+3.875D0*(Y(2)+Y(5))+2.625D0*(Y(3)+Y(4))+Y(6))
	SUM2=Y(5)+Y(5)
	SUM2=SUM2+SUM2
	SUM2=AUX2-HT*(Y(4)+SUM2+Y(6))
	Z(1)=0.D0
	AUX=Y(3)+Y(3)
	AUX=AUX+AUX
	Z(2)=SUM2-HT*(Y(2)+AUX+Y(4))
	Z(3)=SUM1
	Z(4)=SUM2
	IF(NDIM-6)5,5,2
C
C	INTEGRATION LOOP
2	DO 4 I=7,NDIM,2
	SUM1=AUX1
	SUM2=AUX2
	AUX1=Y(I-1)+Y(I-1)
	AUX1=AUX1+AUX1
	AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I))
	Z(I-2)=SUM1
	IF(I-NDIM)3,6,6
3	AUX2=Y(I)+Y(I)
	AUX2=AUX2+AUX2
	AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1))
4	Z(I-1)=SUM2
5	Z(NDIM-1)=AUX1
	Z(NDIM)=AUX2
	RETURN
6	Z(NDIM-1)=SUM2
	Z(NDIM)=AUX1
	RETURN
C	END OF INTEGRATION LOOP
C
7	IF(NDIM-3)12,11,8
C
C	NDIM IS EQUAL TO 4 OR 5
8	SUM2=1.125D0*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4))
	SUM1=Y(2)+Y(2)
	SUM1=SUM1+SUM1
	SUM1=HT*(Y(1)+SUM1+Y(3))
	Z(1)=0.D0
	AUX1=Y(3)+Y(3)
	AUX1=AUX1+AUX1
	Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4))
	IF(NDIM-5)10,9,9
9	AUX1=Y(4)+Y(4)
	AUX1=AUX1+AUX1
	Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5))
10	Z(3)=SUM1
	Z(4)=SUM2
	RETURN
C
C	NDIM IS EQUAL TO 3
11	SUM1=HT*(1.25D0*Y(1)+Y(2)+Y(2)-.25D0*Y(3))
	SUM2=Y(2)+Y(2)
	SUM2=SUM2+SUM2
	Z(3)=HT*(Y(1)+SUM2+Y(3))
	Z(1)=0.D0
	Z(2)=SUM1
12	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQTFE
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION VALUES.
C
C	   USAGE
C	      CALL DQTFE (H,Y,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH Y.
C	      NDIM   - THE DIMENSION OF VECTORS Y AND Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA).
C	      FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75.
C
C	..................................................................
C
	SUBROUTINE DQTFE(H,Y,Z,NDIM)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION Y,Z,H,HH,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
1	HH=.5D0*H
C
C	INTEGRATION LOOP
	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+HH*(Y(I)+Y(I-1))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DQTFG
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      GENERAL TABLE OF ARGUMENT AND FUNCTION VALUES.
C
C	   USAGE
C	      CALL DQTFG (X,Y,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES.
C	      Z      - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL
C	               VALUES. Z MAY BE IDENTICAL WITH X OR Y.
C	      NDIM   - THE DIMENSION OF VECTORS X,Y,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA).
C	      FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75.
C
C	..................................................................
C
	SUBROUTINE DQTFG(X,Y,Z,NDIM)
C
C
	DIMENSION X(1),Y(1),Z(1)
	DOUBLE PRECISION X,Y,Z,SUM1,SUM2
C
	SUM2=0.D0
	IF(NDIM-1)4,3,1
C
C	INTEGRATION LOOP
1	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+.5D0*(X(I)-X(I-1))*(Y(I)+Y(I-1))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DRHARM
C
C	   PURPOSE
C	      FINDS THE FOURIER COEFFICIENTS OF ONE DIMENSIONAL DOUBLE
C	      PRECISION REAL DATA
C
C	   USAGE
C	      CALL DRHARM(A,M,INV,S,IFERR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - A DOUBLE PRECISION VECTOR
C	              AS INPUT, CONTAINS ONE DIMENSIONAL REAL DATA. A IS
C	              2*N+4 CORE LOCATIONS, WHERE N = 2**M. 2*N REAL
C	              NUMBERS ARE PUT INTO THE FIRST 2*N CORE LOCATIONS
C	              OF A
C	              AS OUTPUT, A CONTAINS THE FOURIER COEFFICIENTS
C	              A0/2,B0=0,A1,B1,A2,B2,...,AN/2,BN=0 RESPECTIVELY IN
C	              THE FIRST 2N+2 CORE LOCATIONS OF A
C	      M     - AN INTEGER WHICH DETERMINES THE SIZE OF THE VECTOR
C	              A. THE SIZE OF A IS 2*(2**M) + 4
C	      INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION OF
C	              DIMENSION ONE EIGHTH THE NUMBER OF REAL INPUT, VIZ.,
C	              (1/8)*2*(2**M)
C	      S     - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES
C	              WITH DIMENSION THE SAME AS INV
C	      IFERR - A RETURNED VALUE OF 1 MEANS THAT M IS LESS THAN 3 OR
C	              GREATER THAN 20. OTHERWISE IFERR IS SET = 0
C
C	   REMARKS
C	      THIS SUBROUTINE GIVES THE FOURIER COEFFICIENTS OF 2*(2**M)
C	      REAL POINTS. SEE SUBROUTINE DHARM FOR THREE DIMENSIONAL,
C	      DOUBLE PRECISION, COMPLEX FOURIER TRANSFORMS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DHARM
C
C	   METHOD
C	      THE FOURIER COEFFICIENTS A0,B0=0,A1,B1,...,AN,BN=0 ARE
C	      OBTAINED FOR INPUT XJ, J=0,1,2,...,2N-1 FOR THE FOLLOWING
C	      EQUATION (PI = 3.14159...)
C
C	            N-1                                               J
C	XJ=(1/2)A0+SUM (AK*COS(PI*J*K/N)+BK*SIN(PI*J*K/N))+(1/2)AN(-1)
C	            K=1
C
C	      SEE REFERENCE UNDER SUBROUTINE DHARM
C
C	..................................................................
C
	SUBROUTINE DRHARM(A,M,INV,S,IFERR)
	DIMENSION A(1),L(3),INV(1),S(1)
	DOUBLE PRECISION A,SI,AP1IM,FN,CO,CIRE,AP2IM,S,SS,DEL,CIIM,AP1RE,
     1 CNIRE,SC,SIS,AP2RE,CNIIM
	IFSET=1
	L(1)=M
	L(2)=0
	L(3)=0
	NTOT=2**M
	NTOT2 = 2*NTOT
	FN = NTOT
	DO   3 I = 2,NTOT2,2
3	A(I) = -A(I)
	DO   6 I = 1,NTOT2
6	A(I) = A(I)/FN
	CALL DHARM(A,L,INV,S,IFSET,IFERR)
C
C	MOVE LAST HALF OF A(J)S DOWN ONE SLOT AND ADD A(N) AT BOTTOM TO
C	GIVE ARRAY FOR A1PRIME AND A2PRIME CALCULATION
C
21	DO  52 I=1,NTOT,2
	J0=NTOT2+2-I
	A(J0)=A(J0-2)
52	A(J0+1)=A(J0-1)
	A(NTOT2+3)=A(1)
	A(NTOT2+4)=A(2)
C
C	CALCULATE A1PRIMES AND STORE IN FIRST N SLOTS
C	CALCULATE A2PRIMES AND STORE IN SECOND N SLOTS IN REVERSE ORDER
	K0=NTOT+1
	DO 104 I=1,K0,2
	K1=NTOT2-I+4
	AP1RE=.5*(A(I)+A(K1))
	AP2RE=-.5*(A(I+1)+A(K1+1))
	AP1IM=.5*(-A(I+1)+A(K1+1))
	AP2IM=-.5*(A(I)-A(K1))
	A(I)=AP1RE
	A(I+1)=AP1IM
	A(K1)=AP2RE
104	A(K1+1)=AP2IM
	NTO = NTOT/2
110	NT=NTO+1
	DEL=3.141592653589793/DFLOAT(NTOT)
	SS=DSIN(DEL)
	SC=DCOS(DEL)
	SI=0.0
	CO=1.0
C
C	COMPUTE C(J)S FOR J=0 THRU J=N
114	DO 116 I=1,NT
	K6=NTOT2-2*I+5
	AP2RE=A(K6)*CO+A(K6+1)*SI
	AP2IM=-A(K6)*SI+A(K6+1)*CO
	CIRE=.5*(A(2*I-1)+AP2RE)
	CIIM=.5*(A(2*I)+AP2IM)
	CNIRE=.5*(A(2*I-1)-AP2RE)
	CNIIM=.5*(A(2*I)-AP2IM)
	A(2*I-1)=CIRE
	A(2*I)=CIIM
	A(K6)=CNIRE
	A(K6+1)=-CNIIM
	SIS=SI
	SI=SI*SC+CO*SS
116	CO=CO*SC-SIS*SS
C
C	SHIFT C(J)S FOR J=N/2+1 TO J=N UP ONE SLOT
	DO 117 I=1,NTOT,2
	K8=NTOT+4+I
	A(K8-2)=A(K8)
117	A(K8-1)=A(K8+1)
	DO 500 I=3,NTOT2,2
	A(I) = 2. * A(I)
500	A(I + 1) = -2. * A(I + 1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DRKGS
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL
C	      EQUATIONS WITH GIVEN INITIAL VALUES.
C
C	   USAGE
C	      CALL DRKGS (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C	      PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH
C	               DIMENSION GREATER THAN OR EQUAL TO 5, WHICH
C	               SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF
C	               ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN
C	               OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND
C	               SUBROUTINE DRKGS. EXCEPT PRMT(5) THE COMPONENTS
C	               ARE NOT DESTROYED BY SUBROUTINE DRKGS AND THEY ARE
C	      PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DRKGS INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE DRKGS AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE DRKGS DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING DRKGS) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      Y      - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES
C	               (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF
C	               DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE
C	               POINTS X.
C	      DERY   - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS
C	               (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE
C	               EQUAL TO 1. LATERON DERY IS THE VECTOR OF
C	               DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT
C	               INTERMEDIATE POINTS X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE DRKGS RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. ERROR
C	               MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. THIS
C	               SUBROUTINE COMPUTES THE RIGHT HAND SIDES DERY OF
C	               THE SYSTEM TO GIVEN VALUES X AND Y. ITS PARAMETER
C	               LIST MUST BE X,Y,DERY. SUBROUTINE FCT SHOULD
C	               NOT DESTROY X AND Y.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE DRKGS IS TERMINATED.
C	      AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 8
C	               ROWS AND NDIM COLUMNS.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
C	      OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF FOURTH ORDER RUNGE-KUTTA
C	      FORMULAE IN THE MODIFICATION DUE TO GILL. ACCURACY IS
C	      TESTED COMPARING THE RESULTS OF THE PROCEDURE WITH SINGLE
C	      AND DOUBLE INCREMENT.
C	      SUBROUTINE DRKGS AUTOMATICALLY ADJUSTS THE INCREMENT DURING
C	      THE WHOLE COMPUTATION BY HALVING OR DOUBLING. IF MORE THAN
C	      10 BISECTIONS OF THE INCREMENT ARE NECESSARY TO GET
C	      SATISFACTORY ACCURACY, THE SUBROUTINE RETURNS WITH
C	      ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	      TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
C	      MUST BE FURNISHED BY THE USER.
C	      FOR REFERENCE, SEE
C	      RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL COMPUTERS,
C	      WILEY, NEW YORK/LONDON, 1960, PP.110-120.
C
C	..................................................................
C
	SUBROUTINE DRKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C
C
	DIMENSION Y(1),DERY(1),AUX(8,1),A(4),B(4),C(4),PRMT(1)
	DOUBLE PRECISION PRMT,Y,DERY,AUX,A,B,C,X,XEND,H,AJ,BJ,CJ,R1,R2,
     1DELT
	DO 1 I=1,NDIM
1	AUX(8,I)=.066666666666666667D0*DERY(I)
	X=PRMT(1)
	XEND=PRMT(2)
	H=PRMT(3)
	PRMT(5)=0.D0
	CALL FCT(X,Y,DERY)
C
C	ERROR TEST
	IF(H*(XEND-X))38,37,2
C
C	PREPARATIONS FOR RUNGE-KUTTA METHOD
2	A(1)=.5D0
	A(2)=.29289321881345248D0
	A(3)=1.7071067811865475D0
	A(4)=.16666666666666667D0
	B(1)=2.D0
	B(2)=1.D0
	B(3)=1.D0
	B(4)=2.D0
	C(1)=.5D0
	C(2)=.29289321881345248D0
	C(3)=1.7071067811865475D0
	C(4)=.5D0
C
C	PREPARATIONS OF FIRST RUNGE-KUTTA STEP
	DO 3 I=1,NDIM
	AUX(1,I)=Y(I)
	AUX(2,I)=DERY(I)
	AUX(3,I)=0.D0
3	AUX(6,I)=0.D0
	IREC=0
	H=H+H
	IHLF=-1
	ISTEP=0
	IEND=0
C
C
C	START OF A RUNGE-KUTTA STEP
4	IF((X+H-XEND)*H)7,6,5
5	H=XEND-X
6	IEND=1
C
C	RECORDING OF INITIAL VALUES OF THIS STEP
7	CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT)
	IF(PRMT(5))40,8,40
8	ITEST=0
9	ISTEP=ISTEP+1
C
C
C	START OF INNERMOST RUNGE-KUTTA LOOP
	J=1
10	AJ=A(J)
	BJ=B(J)
	CJ=C(J)
	DO 11 I=1,NDIM
	R1=H*DERY(I)
	R2=AJ*(R1-BJ*AUX(6,I))
	Y(I)=Y(I)+R2
	R2=R2+R2+R2
11	AUX(6,I)=AUX(6,I)+R2-CJ*R1
	IF(J-4)12,15,15
12	J=J+1
	IF(J-3)13,14,13
13	X=X+.5D0*H
14	CALL FCT(X,Y,DERY)
	GOTO 10
C	END OF INNERMOST RUNGE-KUTTA LOOP
C
C
C	TEST OF ACCURACY
15	IF(ITEST)16,16,20
C
C	IN CASE ITEST=0 THERE IS NO POSSIBILITY FOR TESTING OF ACCURACY
16	DO 17 I=1,NDIM
17	AUX(4,I)=Y(I)
	ITEST=1
	ISTEP=ISTEP+ISTEP-2
18	IHLF=IHLF+1
	X=X-H
	H=.5D0*H
	DO 19 I=1,NDIM
	Y(I)=AUX(1,I)
	DERY(I)=AUX(2,I)
19	AUX(6,I)=AUX(3,I)
	GOTO 9
C
C	IN CASE ITEST=1 TESTING OF ACCURACY IS POSSIBLE
20	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)21,23,21
21	CALL FCT(X,Y,DERY)
	DO 22 I=1,NDIM
	AUX(5,I)=Y(I)
22	AUX(7,I)=DERY(I)
	GOTO 9
C
C	COMPUTATION OF TEST VALUE DELT
23	DELT=0.D0
	DO 24 I=1,NDIM
24	DELT=DELT+AUX(8,I)*DABS(AUX(4,I)-Y(I))
	IF(DELT-PRMT(4))28,28,25
C
C	ERROR IS TOO GREAT
25	IF(IHLF-10)26,36,36
26	DO 27 I=1,NDIM
27	AUX(4,I)=AUX(5,I)
	ISTEP=ISTEP+ISTEP-4
	X=X-H
	IEND=0
	GOTO 18
C
C	RESULT VALUES ARE GOOD
28	CALL FCT(X,Y,DERY)
	DO 29 I=1,NDIM
	AUX(1,I)=Y(I)
	AUX(2,I)=DERY(I)
	AUX(3,I)=AUX(6,I)
	Y(I)=AUX(5,I)
29	DERY(I)=AUX(7,I)
	CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))40,30,40
30	DO 31 I=1,NDIM
	Y(I)=AUX(1,I)
31	DERY(I)=AUX(2,I)
	IREC=IHLF
	IF(IEND)32,32,39
C
C	INCREMENT GETS DOUBLED
32	IHLF=IHLF-1
	ISTEP=ISTEP/2
	H=H+H
	IF(IHLF)4,33,33
33	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)4,34,4
34	IF(DELT-.02D0*PRMT(4))35,35,4
35	IHLF=IHLF-1
	ISTEP=ISTEP/2
	H=H+H
	GOTO 4
C
C
C	RETURNS TO CALLING PROGRAM
36	IHLF=11
	CALL FCT(X,Y,DERY)
	GOTO 39
37	IHLF=12
	GOTO 39
38	IHLF=13
39	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
40	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DRTMI
C
C	   PURPOSE
C	      TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM FCT(X)=0
C	      BY MEANS OF MUELLER-S ITERATION METHOD.
C
C	   USAGE
C	      CALL DRTMI (X,F,FCT,XLI,XRI,EPS,IEND,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION
C	               FCT(X)=0.
C	      F      - DOUBLE PRECISION RESULTANT FUNCTION VALUE
C	               AT ROOT X.
C	      FCT    - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      XLI    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               INITIAL LEFT BOUND OF THE ROOT X.
C	      XRI    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               INITIAL RIGHT BOUND OF THE ROOT X.
C	      EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               UPPER BOUND OF THE ERROR OF RESULT X.
C	      IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C	      IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0 - NO ERROR,
C	                IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS
C	                        FOLLOWED BY IEND SUCCESSIVE STEPS OF
C	                        BISECTION,
C	                IER=2 - BASIC ASSUMPTION FCT(XLI)*FCT(XRI) LESS
C	                        THAN OR EQUAL TO ZERO IS NOT SATISFIED.
C
C	   REMARKS
C	      THE PROCEDURE ASSUMES THAT FUNCTION VALUES AT INITIAL
C	      BOUNDS XLI AND XRI HAVE NOT THE SAME SIGN. IF THIS BASIC
C	      ASSUMPTION IS NOT SATISFIED BY INPUT VALUES XLI AND XRI, THE
C	      PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      SOLUTION OF EQUATION FCT(X)=0 IS DONE BY MEANS OF MUELLER-S
C	      ITERATION METHOD OF SUCCESSIVE BISECTIONS AND INVERSE
C	      PARABOLIC INTERPOLATION, WHICH STARTS AT THE INITIAL BOUNDS
C	      XLI AND XRI. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
C	      FCT(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
C	      REQUIRES TWO EVALUATIONS OF FCT(X). FOR TEST ON SATISFACTORY
C	      ACCURACY SEE FORMULAE (3,4) OF MATHEMATICAL DESCRIPTION.
C	      FOR REFERENCE, SEE G. K. KRISTIANSEN, ZERO OF ARBITRARY
C	      FUNCTION, BIT, VOL. 3 (1963), PP.205-206.
C
C	..................................................................
C
	SUBROUTINE DRTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER)
C
C
	DOUBLE PRECISION X,F,FCT,XLI,XRI,XL,XR,FL,FR,TOL,TOLF,A,DX,XM,FM
C
C	PREPARE ITERATION
	IER=0
	XL=XLI
	XR=XRI
	X=XL
	TOL=X
	F=FCT(TOL)
	IF(F)1,16,1
1	FL=F
	X=XR
	TOL=X
	F=FCT(TOL)
	IF(F)2,16,2
2	FR=F
	IF(DSIGN(1.D0,FL)+DSIGN(1.D0,FR))25,3,25
C
C	BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED.
C	GENERATE TOLERANCE FOR FUNCTION VALUES.
3	I=0
	TOLF=100.*EPS
C
C
C	START ITERATION LOOP
4	I=I+1
C
C	START BISECTION LOOP
	DO 13 K=1,IEND
	X=.5D0*(XL+XR)
	TOL=X
	F=FCT(TOL)
	IF(F)5,16,5
5	IF(DSIGN(1.D0,F)+DSIGN(1.D0,FR))7,6,7
C
C	INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR
6	TOL=XL
	XL=XR
	XR=TOL
	TOL=FL
	FL=FR
	FR=TOL
7	TOL=F-FL
	A=F*TOL
	A=A+A
	IF(A-FR*(FR-FL))8,9,9
8	IF(I-IEND)17,17,9
9	XR=X
	FR=F
C
C	TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP
	TOL=EPS
	A=DABS(XR)
	IF(A-1.D0)11,11,10
10	TOL=TOL*A
11	IF(DABS(XR-XL)-TOL)12,12,13
12	IF(DABS(FR-FL)-TOLF)14,14,13
13	CONTINUE
C	END OF BISECTION LOOP
C
C	NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND
C	SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION
C	VALUES AT RIGHT BOUNDS. ERROR RETURN.
	IER=1
14	IF(DABS(FR)-DABS(FL))16,16,15
15	X=XL
	F=FL
16	RETURN
C
C	COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION
17	A=FR-F
	DX=(X-XL)*FL*(1.D0+F*(A-TOL)/(A*(FR-FL)))/TOL
	XM=X
	FM=F
	X=XL-DX
	TOL=X
	F=FCT(TOL)
	IF(F)18,16,18
C
C	TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP
18	TOL=EPS
	A=DABS(X)
	IF(A-1.D0)20,20,19
19	TOL=TOL*A
20	IF(DABS(DX)-TOL)21,21,22
21	IF(DABS(F)-TOLF)16,16,22
C
C	PREPARATION OF NEXT BISECTION LOOP
22	IF(DSIGN(1.D0,F)+DSIGN(1.D0,FL))24,23,24
23	XR=X
	FR=F
	GO TO 4
24	XL=X
	FL=F
	XR=XM
	FR=FM
	GO TO 4
C	END OF ITERATION LOOP
C
C
C	ERROR RETURN IN CASE OF WRONG INPUT DATA
25	IER=2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DRTNI
C
C	   PURPOSE
C	      TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM F(X)=0
C	      BY MEANS OF NEWTON-S ITERATION METHOD.
C
C	   USAGE
C	      CALL DRTNI (X,F,DERF,FCT,XST,EPS,IEND,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION F(X)=0.
C	      F      - DOUBLE PRECISION RESULTANT FUNCTION VALUE AT
C	               ROOT X.
C	      DERF   - DOUBLE PRECISION RESULTANT VALUE OF DERIVATIVE
C	               AT ROOT X.
C	      FCT    - NAME OF THE EXTERNAL SUBROUTINE USED. IT COMPUTES
C	               TO GIVEN ARGUMENT X FUNCTION VALUE F AND DERIVATIVE
C	               DERF. ITS PARAMETER LIST MUST BE X,F,DERF, WHERE
C	               ALL PARAMETERS ARE DOUBLE PRECISION.
C	      XST    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               INITIAL GUESS OF THE ROOT X.
C	      EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               UPPER BOUND OF THE ERROR OF RESULT X.
C	      IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C	      IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0 - NO ERROR,
C	                IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
C	                IER=2 - AT ANY ITERATION STEP DERIVATIVE DERF WAS
C	                        EQUAL TO ZERO.
C
C	   REMARKS
C	      THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
C	      IF AT ANY ITERATION STEP DERIVATIVE OF F(X) IS EQUAL TO 0.
C	      POSSIBLY THE PROCEDURE WOULD BE SUCCESSFUL IF IT IS STARTED
C	      ONCE MORE WITH ANOTHER INITIAL GUESS XST.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINE FCT(X,F,DERF) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      SOLUTION OF EQUATION F(X)=0 IS DONE BY MEANS OF NEWTON-S
C	      ITERATION METHOD, WHICH STARTS AT THE INITIAL GUESS XST OF
C	      A ROOT X. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
C	      F(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
C	      REQUIRES ONE EVALUATION OF F(X) AND ONE EVALUATION OF THE
C	      DERIVATIVE OF F(X). FOR TEST ON SATISFACTORY ACCURACY SEE
C	      FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
C	      FOR REFERENCE, SEE R. ZURMUEHL, PRAKTISCHE MATHEMATIK FUER
C	      INGENIEURE UND PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/
C	      HEIDELBERG, 1963, PP.12-17.
C
C	..................................................................
C
	SUBROUTINE DRTNI(X,F,DERF,FCT,XST,EPS,IEND,IER)
C
C
	DOUBLE PRECISION X,F,DERF,XST,TOL,TOLF,DX,A
C
C	PREPARE ITERATION
	IER=0
	X=XST
	TOL=X
	CALL FCT(TOL,F,DERF)
	TOLF=100.*EPS
C
C
C	START ITERATION LOOP
	DO 6 I=1,IEND
	IF(F)1,7,1
C
C	EQUATION IS NOT SATISFIED BY X
1	IF(DERF)2,8,2
C
C	ITERATION IS POSSIBLE
2	DX=F/DERF
	X=X-DX
	TOL=X
	CALL FCT(TOL,F,DERF)
C
C	TEST ON SATISFACTORY ACCURACY
	TOL=EPS
	A=DABS(X)
	IF(A-1.D0)4,4,3
3	TOL=TOL*A
4	IF(DABS(DX)-TOL)5,5,6
5	IF(DABS(F)-TOLF)7,7,6
6	CONTINUE
C	END OF ITERATION LOOP
C
C
C	NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
	IER=1
7	RETURN
C
C	ERROR RETURN IN CASE OF ZERO DIVISOR
8	IER=2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DRTWI
C
C	   PURPOSE
C	      TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM X=FCT(X)
C	      BY MEANS OF WEGSTEIN-S ITERATION METHOD.
C
C	   USAGE
C	      CALL DRTWI (X,VAL,FCT,XST,EPS,IEND,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION RESULTANT ROOT OF EQUATION
C	               X=FCT(X).
C	      VAL    - DOUBLE PRECISION RESULTANT VALUE OF X-FCT(X)
C	               AT ROOT X.
C	      FCT    - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED.
C	      XST    - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               INITIAL GUESS OF THE ROOT X.
C	      EPS    - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE
C	               UPPER BOUND OF THE ERROR OF RESULT X.
C	      IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C	      IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0 - NO ERROR,
C	                IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
C	                IER=2 - AT ANY ITERATION STEP THE DENOMINATOR OF
C	                        ITERATION FORMULA WAS EQUAL TO ZERO.
C
C	   REMARKS
C	      THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
C	      IF AT ANY ITERATION STEP THE DENOMINATOR OF ITERATION
C	      FORMULA WAS EQUAL TO ZERO. THAT MEANS THAT THERE IS AT
C	      LEAST ONE POINT IN THE RANGE IN WHICH ITERATION MOVES WITH
C	      DERIVATIVE OF FCT(X) EQUAL TO 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X)
C	      MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      SOLUTION OF EQUATION X=FCT(X) IS DONE BY MEANS OF
C	      WEGSTEIN-S ITERATION METHOD, WHICH STARTS AT THE INITIAL
C	      GUESS XST OF A ROOT X. ONE ITERATION STEP REQUIRES ONE
C	      EVALUATION OF FCT(X). FOR TEST ON SATISFACTORY ACCURACY SEE
C	      FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
C	      FOR REFERENCE, SEE
C	      (1) G. N. LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
C	          ILIFFE, LONDON, 1960, PP.134-138,
C	      (2) J. WEGSTEIN, ALGORITHM 2, CACM, VOL.3, ISS.2 (1960),
C	          PP.74,
C	      (3) H.C. THACHER, ALGORITHM 15, CACM, VOL.3, ISS.8 (1960),
C	          PP.475,
C	      (4) J.G. HERRIOT, ALGORITHM 26, CACM, VOL.3, ISS.11 (1960),
C	          PP.603.
C
C	..................................................................
C
	SUBROUTINE DRTWI(X,VAL,FCT,XST,EPS,IEND,IER)
C
C
	DOUBLE PRECISION X,VAL,FCT,XST,A,B,D,TOL
C
C	PREPARE ITERATION
	IER=0
	TOL=XST
	X=FCT(TOL)
	A=X-XST
	B=-A
	TOL=X
	VAL=X-FCT(TOL)
C
C
C	START ITERATION LOOP
	DO 6 I=1,IEND
	IF(VAL)1,7,1
C
C	EQUATION IS NOT SATISFIED BY X
1	B=B/VAL-1.D0
	IF(B)2,8,2
C
C	ITERATION IS POSSIBLE
2	A=A/B
	X=X+A
	B=VAL
	TOL=X
	VAL=X-FCT(TOL)
C
C	TEST ON SATISFACTORY ACCURACY
	TOL=EPS
	D=DABS(X)
	IF(D-1.D0)4,4,3
3	TOL=TOL*D
4	IF(DABS(A)-TOL)5,5,6
5	IF(DABS(VAL)-1.D1*TOL)7,7,6
6	CONTINUE
C	END OF ITERATION LOOP
C
C
C	NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
	IER=1
7	RETURN
C
C	ERROR RETURN IN CASE OF ZERO DIVISOR
8	IER=2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DSE13
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
C	      VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
C	      EQUIDISTANTLY SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DSE13(Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
C	               FUNCTION VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 3
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y
C	            IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED
C	      VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST-
C	      SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE
C	      POINTS (X(I+K),Y(I+K)) K = -1,0,1.  (SEE HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 295-302.)
C
C	..................................................................
C
	SUBROUTINE DSE13(Y,Z,NDIM,IER)
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION Y,Z,A,B,C
C
C	   TEST OF DIMENSION
	IF(NDIM-3)3,1,1
C
C	   PREPARE LOOP
1	B=.16666666666666667D0*(5.D0*Y(1)+Y(2)+Y(2)-Y(3))
	C=.16666666666666667*(5.D0*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2))
C
C	   START LOOP
	DO 2 I=3,NDIM
	A=B
	B=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I))
2	Z(I-2)=A
C	   END OF LOOP
C
C	   UPDATE LAST TWO COMPONENTS
	Z(NDIM-1)=B
	Z(NDIM)=C
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 3
3	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DSE15
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
C	      VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
C	      EQUIDISTANTLY SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DSE15(Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
C	               FUNCTION VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
C	      SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
C	      LEAST-SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 5
C	      SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
C	      HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
C
C	..................................................................
C
	SUBROUTINE DSE15(Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION Y,Z,A,B,C
C
C	   TEST OF DIMENSION
	IF(NDIM-5)3,1,1
C
C	   PREPARE LOOP
1	A=Y(1)+Y(1)
	C=Y(2)+Y(2)
	B=.2D0*(A+Y(1)+C+Y(3)-Y(5))
	C=.1D0*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4))
C
C	   START LOOP
	DO 2 I=5,NDIM
	A=B
	B=C
	C=.2D0*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I))
2	Z(I-4)=A
C	   END OF LOOP
C
C	   UPDATE LAST FOUR COMPONENTS
	A=Y(NDIM)+Y(NDIM)
	A=.1D0*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2)
     1      +Y(NDIM-3))
	Z(NDIM-3)=B
	Z(NDIM-2)=C
	Z(NDIM-1)=A
	Z(NDIM)=A+A-C
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
3	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DSE35
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
C	      VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
C	      EQUIDISTANTLY SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL DSE35(Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
C	               FUNCTION VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
C	      SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
C	      LEAST-SQUARES POLYNOMIAL OF DEGREE 3 RELEVANT TO THE 5
C	      SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
C	      HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
C
C	..................................................................
C
	SUBROUTINE DSE35(Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
	DOUBLE PRECISION Y,Z,A,B,C,D
C
C	   TEST OF DIMENSION
	IF(NDIM-5)4,1,1
C
C	   PREPARE LOOP
1	B=Y(1)
	C=Y(2)
C
C	   START LOOP
	DO 3 I=5,NDIM
	A=B
	B=C
	C=Y(I-2)
C
C	   GENERATE FOURTH CENTRAL DIFFERENCE
	D=C-B-Y(I-1)
	D=D+D+C
	D=D+D+A+Y(I)
C
C	   CHECK FIRST TWO COMPONENTS
	IF(I-5)2,2,3
2	Z(1)=A-.014285714285714286D0*D
	Z(2)=B+.057142857142857143D0*D
3	Z(I-2)=C-.08571428571428571D0*D
C	   END OF LOOP
C
C	   UPDATE LAST TWO COMPONENTS
	Z(NDIM-1)=Y(NDIM-1)+.057142857142857143D0*D
	Z(NDIM)=Y(NDIM)-.014285714285714286D0*D
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
4	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DSG13
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN
C	      VECTORS OF ARGUMENT VALUES AND CORRESPONDING FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL DSG13(X,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -  GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES
C	               (DIMENSION NDIM)
C	      Y     -  GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES
C	               CORRESPONDING TO X (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED
C	               FUNCTION VALUES (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS X,Y,AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 3
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
C	            X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED
C	      VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST-
C	      SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE
C	      POINTS (X(I+K),Y(I+K)) K = -1,0,1.(SEE HILDEBRAND, F.B.,
C	      INTRODUCTION  TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP.258-311.)
C
C	..................................................................
C
	SUBROUTINE DSG13(X,Y,Z,NDIM,IER)
C
C
	DIMENSION X(1),Y(1),Z(1)
	DOUBLE PRECISION X,Y,Z,XM,YM,T1,T2,T3,H
C
C	   TEST OF DIMENSION
	IF(NDIM-3)7,1,1
C
C	   START LOOP
1	DO 6 I=3,NDIM
	XM=.33333333333333333D0*(X(I-2)+X(I-1)+X(I))
	YM=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I))
	T1=X(I-2)-XM
	T2=X(I-1)-XM
	T3=X(I)-XM
	XM=T1*T1+T2*T2+T3*T3
	IF(XM)3,3,2
2	XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM
C
C	   CHECK FIRST POINT
3	IF(I-3)4,4,5
4	H=XM*T1+YM
5	Z(I-2)=H
6	H=XM*T2+YM
C	   END OF LOOP
C
C	   UPDATE LAST TWO COMPONENTS
	Z(NDIM-1)=H
	Z(NDIM)=XM*T3+YM
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 3
7	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DSINV
C
C	   PURPOSE
C	      INVERT A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX
C
C	   USAGE
C	      CALL DSINV(A,N,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN
C	               SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT
C	               MATRIX.
C	               ON RETURN A CONTAINS THE RESULTANT UPPER
C	               TRIANGULAR MATRIX IN DOUBLE PRECISION.
C	      N      - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX.
C	      EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED
C	               AS RELATIVE TOLERANCE FOR TEST ON LOSS OF
C	               SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR
C	               IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
C	                        TER N OR BECAUSE SOME RADICAND IS NON-
C	                        POSITIVE (MATRIX A IS NOT POSITIVE
C	                        DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI-
C	                        FICANCE)
C	               IER=K  - WARNING WHICH INDICATES LOSS OF SIGNIFI-
C	                        CANCE. THE RADICAND FORMED AT FACTORIZA-
C	                        TION STEP K+1 WAS STILL POSITIVE BUT NO
C	                        LONGER GREATER THAN ABS(EPS*A(K+1,K+1)).
C
C	   REMARKS
C	      THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE
C	      STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS.
C	      IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU-
C	      LAR MATRIX IS STORED COLUMNWISE TOO.
C	      THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL
C	      CALCULATED RADICANDS ARE POSITIVE.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DMFSD
C
C	   METHOD
C	      SOLUTION IS DONE USING FACTORIZATION BY SUBROUTINE DMFSD.
C
C	..................................................................
C
	SUBROUTINE DSINV(A,N,EPS,IER)
C
C
	DIMENSION A(1)
	DOUBLE PRECISION A,DIN,WORK
C
C	   FACTORIZE GIVEN MATRIX BY MEANS OF SUBROUTINE DMFSD
C	   A = TRANSPOSE(T) * T
	CALL DMFSD(A,N,EPS,IER)
	IF(IER) 9,1,1
C
C	   INVERT UPPER TRIANGULAR MATRIX T
C	   PREPARE INVERSION-LOOP
1	IPIV=N*(N+1)/2
	IND=IPIV
C
C	   INITIALIZE INVERSION-LOOP
	DO 6 I=1,N
	DIN=1.D0/A(IPIV)
	A(IPIV)=DIN
	MIN=N
	KEND=I-1
	LANF=N-KEND
	IF(KEND) 5,5,2
2	J=IND
C
C	   INITIALIZE ROW-LOOP
	DO 4 K=1,KEND
	WORK=0.D0
	MIN=MIN-1
	LHOR=IPIV
	LVER=J
C
C	   START INNER LOOP
	DO 3 L=LANF,MIN
	LVER=LVER+1
	LHOR=LHOR+L
3	WORK=WORK+A(LVER)*A(LHOR)
C	   END OF INNER LOOP
C
	A(J)=-WORK*DIN
4	J=J-MIN
C	   END OF ROW-LOOP
C
5	IPIV=IPIV-MIN
6	IND=IND-1
C	   END OF INVERSION-LOOP
C
C	   CALCULATE INVERSE(A) BY MEANS OF INVERSE(T)
C	   INVERSE(A) = INVERSE(T) * TRANSPOSE(INVERSE(T))
C	   INITIALIZE MULTIPLICATION-LOOP
	DO 8 I=1,N
	IPIV=IPIV+I
	J=IPIV
C
C	   INITIALIZE ROW-LOOP
	DO 8 K=I,N
	WORK=0.D0
	LHOR=J
C
C	   START INNER LOOP
	DO 7 L=K,N
	LVER=LHOR+K-I
	WORK=WORK+A(LHOR)*A(LVER)
7	LHOR=LHOR+L
C	   END OF INNER LOOP
C
	A(J)=WORK
8	J=J+K
C	   END OF ROW- AND MULTIPLICATION-LOOP
C
9	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTCNP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN CHEBYSHEV POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B.
C
C	   USAGE
C	      CALL DTCNP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	              DOUBLE PRECISION VECTOR
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C	              DOUBLE PRECISION ARRAY
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-(1+B)/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR CHEBYSHEV POLYNOMIALS T(N,X)
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X = A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE DTCNP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
	DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+C(2)*B
	POL(2)=C(2)*A
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.D0
	WORK(2)=B
	WORK(3)=0.D0
	WORK(4)=A
	XD=A+A
	X0=B+B
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT CHEBYSHEV POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.D0
C
	DO 5 K=2,J
	H=P-WORK(2*K-3)+X0*WORK(2*K-2)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
	POL(K-1)=POL(K-1)+H*C(J)
5	P=XD*P
	WORK(2*J-1)=0.D0
	WORK(2*J)=P
6	POL(J)=C(J)*P
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTCSP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN SHIFTED CHEBYSHEV POLYNOMIALS WITH
C	      INDEPENDENT VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH
C	      INDEPENDENT VARIABLE Z, WHERE X=A*Z+B.
C
C	   USAGE
C	      CALL DTCSP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C	              DOUBLE PRECISION ARRAY
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (0,1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-B/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=1/(ZR-ZL) AND B=-ZL/(ZR-ZL).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE DTCSP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
	DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	XD=A+A
	X0=B+B-1.D0
	POL(1)=C(1)+C(2)*X0
	POL(2)=C(2)*XD
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.D0
	WORK(2)=X0
	WORK(3)=0.D0
	WORK(4)=XD
	XD=XD+XD
	X0=X0+X0
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT SHIFTED CHEBYSHEV
C	   POLYNOMIAL AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.D0
C
	DO 5 K=2,J
	H=P-WORK(2*K-3)+X0*WORK(2*K-2)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
	POL(K-1)=POL(K-1)+H*C(J)
5	P=XD*P
	WORK(2*J-1)=0.D0
	WORK(2*J)=P
6	POL(J)=C(J)*P
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTEAS
C
C	   PURPOSE
C	      CALCULATE THE LIMIT OF A GIVEN SEQUENCE BY MEANS OF THE
C	      EPSILON-ALGORITHM.
C
C	   USAGE
C	      CALL DTEAS(X,N,FIN,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - DOUBLE PRECISION VECTOR WHOSE COMPONENTS ARE TERMS
C	               OF THE GIVEN SEQUENCE. ON RETURN THE COMPONENTS OF
C	               VECTOR X ARE DESTROYED.
C	      N      - DIMENSION OF INPUT VECTOR X.
C	      FIN    - RESULTANT SCALAR IN DOUBLE PRECISION CONTAINING ON
C	               RETURN THE LIMIT OF THE GIVEN SEQUENCE.
C	      EPS    - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE
C	               UPPER BOUND OF THE RELATIVE (ABSOLUTE) ERROR IF THE
C	               COMPONENTS OF X ARE ABSOLUTELY GREATER (LESS) THAN
C	               ONE.
C	               CALCULATION IS TERMINATED AS SOON AS THREE TIMES IN
C	               SUCCESSION THE RELATIVE (ABSOLUTE) DIFFERENCE
C	               BETWEEN NEIGHBOURING TERMS IS NOT GREATER THAN EPS.
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - REQUIRED ACCURACY NOT REACHED WITH
C	                         MAXIMAL NUMBER OF ITERATIONS
C	                IER=-1 - INTEGER N IS LESS THAN TEN.
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE N LESS THAN TEN.
C	      THE CHARACTER OF THE GIVEN INFINITE SEQUENCE MUST BE
C	      RECOGNIZABLE BY THOSE N COMPONENTS OF THE INPUT VECTOR X.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE CONVERGENCE OF THE GIVEN SEQUENCE IS ACCELERATED BY
C	      MEANS OF THE E(2)-TRANSFORMATION, USED IN AN ITERATIVE WAY.
C	      FOR REFERENCE, SEE
C	      ALGORITHM 215,SHANKS, CACM 1963, NO. 11, PP. 662. AND
C	      P. WYNN, SINGULAR RULES FOR CERTAIN NON-LINEAR ALGORITHMS
C	      BIT VOL. 3, 1963, PP. 175-195.
C
C	..................................................................
C
	SUBROUTINE DTEAS(X,N,FIN,EPS,IER)
C
	DIMENSION X(1)
	DOUBLE PRECISION X,FIN,W1,W2,W3,W4,W5,W6,W7,T
C
C	   TEST ON WRONG INPUT PARAMETER N
C
	NEW=N
	IF(NEW-10)1,2,2
1	IER=-1
	RETURN
C
C	   CALCULATE INITIAL VALUES FOR THE EPSILON ARRAY
C
2	ISW1=0
	ISW2=0
	W1=1.D38
	W7=X(4)-X(3)
	IF(W7)3,4,3
3	W1=1.D0/W7
C
4	W5=1.D38
	W7=X(2)-X(1)
	IF(W7)5,6,5
5	W5=1.D0/W7
C
6	W4=X(3)-X(2)
	IF(W4)9,7,9
7	W4=1.D38
	T=X(2)
	W2=X(3)
8	W3=1.D38
	GO TO 17
C
9	W4=1.D0/W4
C
	T=1.D38
	W7=W4-W5
	IF(W7)10,11,10
10	T=X(2)+1.D0/W7
C
11	W2=W1-W4
	IF(W2)15,12,15
12	W2=1.D38
	IF(T-1.D38)13,14,14
13	ISW2=1
14	W3=W4
	GO TO 17
C
15	W2=X(3)+1.D0/W2
	W7=W2-T
	IF(W7)16,8,16
16	W3=W4+1.D0/W7
C
17	ISW1=ISW2
	ISW2=0
	IMIN=4
C
C	   CALCULATE DIAGONALS OF THE EPSILON ARRAY IN A DO-LOOP
C
	DO 40 I=5,NEW
	IAUS=I-IMIN
	W4=1.D38
	W5=X(I-1)
	W7=X(I)-X(I-1)
	IF(W7)18,24,18
18	W4=1.D0/W7
C
	IF(W1-1.D38)19,25,25
19	W6=W4-W1
C
C	   TEST FOR NECESSITY OF A SINGULAR RULE
C
	IF(DABS(W6)-DABS(W4)*1.D-12)20,20,22
20	ISW2=1
	IF(W6)22,21,22
21	W5=1.D38
	W6=W1
	IF(W2-1.D38)28,26,26
22	W5=X(I-1)+1.D0/W6
C
C	   FIRST TEST FOR LOSS OF SIGNIFICANCE
C
	IF(DABS(W5)-DABS(X(I-1))*1.D-10)23,24,24
23	IF(W5)36,24,36
C
24	W7=W5-W2
	IF(W7)27,25,27
25	W6=1.D38
26	ISW2=0
	X(IAUS)=W2
	GO TO 37
27	W6=W1+1.D0/W7
28	IF(ISW1-1)33,29,29
C
C	   CALCULATE X(IAUS) WITH HELP OF SINGULAR RULE
C
29	IF(W2-1.D38)30,32,32
30	W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2)
	IF(1.D0+W7)31,38,31
31	X(IAUS)=W7*W2/(1.D0+W7)
	GO TO 39
C
32	X(IAUS)=W5+T-X(I-2)
	GO TO 39
C
33	W7=W6-W3
	IF(W7)34,38,34
34	X(IAUS)=W2+1.D0/W7
C
C	   SECOND TEST FOR LOSS OF SIGNIFICANCE
C
	IF(DABS(X(IAUS))-DABS(W2)*1.D-10)35,37,37
35	IF(X(IAUS))36,37,36
C
36	NEW=IAUS-1
	ISW2=0
	GO TO 41
C
37	IF(W2-1.D38)39,38,38
38	X(IAUS)=1.D38
	IMIN=I
C
39	W1=W4
	T=W2
	W2=W5
	W3=W6
	ISW1=ISW2
40	ISW2=0
C
	NEW=NEW-IMIN
C
C	   TEST FOR ACCURACY
C
41	IEND=NEW-1
	DO 47 I=1,IEND
	HE1=DABS(X(I)-X(I+1))
	HE2=DABS(X(I+1))
	IF(HE1-EPS)44,44,42
42	IF(HE2-1.)46,46,43
43	IF(HE1-EPS*HE2)44,44,46
44	ISW2=ISW2+1
	IF(3-ISW2)45,45,47
45	FIN=X(I)
	IER=0
	RETURN
C
46	ISW2=0
47	CONTINUE
C
	IF(NEW-6)48,2,2
48	FIN=X(NEW)
	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTEUL
C
C	   PURPOSE
C	      COMPUTE THE SUM OF FCT(K) FOR K FROM ONE UP TO INFINITY.
C
C	   USAGE
C	      CALL DTEUL(FCT,SUM,MAX,EPS,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION
C	               SUBPROGRAM USED. IT COMPUTES THE K-TH TERM OF THE
C	               SERIES TO ANY GIVEN INDEX K.
C	      SUM    - RESULTANT VALUE IN DOUBLE PRECISION CONTAINING ON
C	               RETURN THE SUM OF THE GIVEN SERIES.
C	      MAX    - INPUT VALUE, WHICH SPECIFIES THE MAXIMAL NUMBER
C	               OF TERMS OF THE SERIES THAT ARE RESPECTED.
C	      EPS    - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE
C	               UPPER BOUND OF THE RELATIVE ERROR.
C	               SUMMATION IS STOPPED AS SOON AS FIVE TIMES IN
C	               SUCCESSION THE ABSOLUTE VALUE OF THE TERMS OF THE
C	               TRANSFORMED SERIES ARE FOUND TO BE LESS THAN
C	               EPS*(ABSOLUTE VALUE OF CURRENT SUM).
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - REQUIRED ACCURACY NOT REACHED WITH
C	                         MAXIMAL NUMBER OF TERMS
C	                IER=-1 - THE INTEGER MAX IS LESS THAN ONE.
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE MAX LESS THAN ONE.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(K) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF A SUITABLY REFINED EULER
C	      TRANSFORMATION. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW/HILL, NEW YORK/TORONTO/LONDON, 1956, PP.155-160, AND
C	      P. NAUR, REPORT ON THE ALGORITHMIC LANGUAGE ALGOL 60,
C	      CACM, VOL.3, ISS.5 (1960), PP.311.
C
C	..................................................................
C
	SUBROUTINE DTEUL (FCT,SUM,MAX,EPS,IER)
C
	DIMENSION Y(15)
	DOUBLE PRECISION FCT,SUM,Y,AMN,AMP
C
C	   TEST ON WRONG INPUT PARAMETER MAX
C
	IF(MAX)1,1,2
1	IER=-1
	GOTO 12
C
C	   INITIALIZE EULER TRANSFORMATION
C
2	IER=1
	I=1
	M=1
	N=1
	Y(1)=FCT(N)
	SUM=Y(1)*.5D0
C
C	   START EULER-LOOP
C
3	J=0
4	I=I+1
	IF(I-MAX)5,5,12
5	N=I
	AMN=FCT(N)
	DO 6 K=1,M
	AMP=(AMN+Y(K))*.5D0
	Y(K)=AMN
6	AMN=AMP
C
C	   CHECK EULER TRANSFORMATION
C
	IF(DABS(AMN)-DABS(Y(M)))7,9,9
7	IF(M-15)8,9,9
8	M=M+1
	Y(M)=AMN
	AMN=.5D0*AMN
C
C	   UPDATE SUM
C
9	SUM=SUM+AMN
	IF(ABS(SNGL(AMN))-EPS*ABS(SNGL(SUM)))10,10,3
C
C	   TEST END OF PROCEDURE
C
10	J=J+1
	IF(J-5)4,11,11
11	IER=0
12	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTHEP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN HERMITE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL DTHEP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTOR POL AND C
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	              DOUBLE PRECISION VECTOR
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C	              DOUBLE PRECISION ARRAY
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-C,C) IN X TO THE RANGE (ZL,ZR) IN Z WHERE
C	      ZL=-(C+B)/A AND ZR=(C-B)/A.
C	      FOR GIVEN ZL, ZR AND C WE HAVE A=2C/(ZR-ZL) AND
C	      B=-C(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR HERMITE POLYNOMIALS H(N,X)
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE H(0,X)=1,H(1,X)=2*X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE DTHEP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
	DOUBLE PRECISION A,B,POL,C,WORK,H,P,FI,XD,X0
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	XD=A+A
	X0=B+B
	POL(1)=C(1)+C(2)*X0
	POL(2)=C(2)*XD
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.D0
	WORK(2)=X0
	WORK(3)=0.D0
	WORK(4)=XD
	FI=2.D0
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT HERMITE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.D0
C
	DO 5 K=2,J
	H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.D0
	WORK(2*J)=P*XD
	FI=FI+2.D0
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTLAP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN LAGUERRE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL DTLAP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	              DOUBLE PRECISION VECTOR
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C	              DOUBLE PRECISION ARRAY
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (0,C) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-B/A AND ZR=(C-B)/A.
C	      FOR GIVEN ZL, ZR AND C WE HAVE A=C/(ZR-ZL) AND
C	      B=-C*ZL/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR LAGUERRE POLYNOMIALS L(N,X)
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE L(0,X)=1, L(1,X)=1-X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE DTLAP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
	DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,Q2,FI
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+C(2)-B*C(2)
	POL(2)=-C(2)*A
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.D0
	WORK(2)=1.D0-B
	WORK(3)=0.D0
	WORK(4)=-A
	FI=1.D0
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT LAGUERRE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	FI=FI+1.D0
	Q=1.D0/FI
	Q1=Q-1.D0
	Q2=1.D0-Q1-B*Q
	Q=Q*A
	P=0.D0
C
	DO 5 K=2,J
	H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.D0
	WORK(2*J)=-Q*P
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE DTLEP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN LEGENDRE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL DTLEP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	              DOUBLE PRECISION VARIABLE
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              DOUBLE PRECISION VECTOR
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	              DOUBLE PRECISION VECTOR
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C	              DOUBLE PRECISION ARRAY
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-(1+B)/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR LEGENDRE POLYNOMIALS P(N,X)
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE DTLEP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
	DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,FI
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+B*C(2)
	POL(2)=A*C(2)
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.D0
	WORK(2)=B
	WORK(3)=0.D0
	WORK(4)=A
	FI=1.D0
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT LEGENDRE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	FI=FI+1.D0
	Q=1.D0/FI-1.D0
	Q1=1.D0-Q
	P=0.D0
C
	DO 5 K=2,J
	H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.D0
	WORK(2*J)=A*P*Q1
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE EIGEN
C
C	   PURPOSE
C	      COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
C	      MATRIX
C
C	   USAGE
C	      CALL EIGEN(A,R,N,MV)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION.
C	          RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF
C	          MATRIX A IN DESCENDING ORDER.
C	      R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE,
C	          IN SAME SEQUENCE AS EIGENVALUES)
C	      N - ORDER OF MATRICES A AND R
C	      MV- INPUT CODE
C	              0   COMPUTE EIGENVALUES AND EIGENVECTORS
C	              1   COMPUTE EIGENVALUES ONLY (R NEED NOT BE
C	                  DIMENSIONED BUT MUST STILL APPEAR IN CALLING
C	                  SEQUENCE)
C
C	   REMARKS
C	      ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1)
C	      MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED
C	      BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN 'MATHEMATICAL
C	      METHODS FOR DIGITAL COMPUTERS', EDITED BY A. RALSTON AND
C	      H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7
C
C	..................................................................
C
	SUBROUTINE EIGEN(A,R,N,MV)
	DIMENSION A(1),R(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX,
C    1                 COSX2,SINCS,RANGE
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
C	   40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT.  ABS IN STATEMENT
C	   62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD
C	   BE CHANGED TO 1.0D-12.
C
C	   ...............................................................
C
C	   GENERATE IDENTITY MATRIX
C
5	RANGE=1.0E-6
	IF(MV-1) 10,25,10
10	IQ=-N
	DO 20 J=1,N
	IQ=IQ+N
	DO 20 I=1,N
	IJ=IQ+I
	R(IJ)=0.0
	IF(I-J) 20,15,20
15	R(IJ)=1.0
20	CONTINUE
C
C	   COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX)
C
25	ANORM=0.0
	DO 35 I=1,N
	DO 35 J=I,N
	IF(I-J) 30,35,30
30	IA=I+(J*J-J)/2
	ANORM=ANORM+A(IA)*A(IA)
35	CONTINUE
	IF(ANORM) 165,165,40
40	ANORM=1.414*SQRT(ANORM)
	ANRMX=ANORM*RANGE/FLOAT(N)
C
C	   INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR
C
	IND=0
	THR=ANORM
45	THR=THR/FLOAT(N)
50	L=1
55	M=L+1
C
C	   COMPUTE SIN AND COS
C
60	MQ=(M*M-M)/2
	LQ=(L*L-L)/2
	LM=L+MQ
62	IF( ABS(A(LM))-THR) 130,65,65
65	IND=1
	LL=L+LQ
	MM=M+MQ
	X=0.5*(A(LL)-A(MM))
68	Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X)
	IF(X) 70,75,75
70	Y=-Y
75	SINX=Y/ SQRT(2.0*(1.0+( SQRT(1.0-Y*Y))))
	SINX2=SINX*SINX
78	COSX= SQRT(1.0-SINX2)
	COSX2=COSX*COSX
	SINCS =SINX*COSX
C
C	   ROTATE L AND M COLUMNS
C
	ILQ=N*(L-1)
	IMQ=N*(M-1)
	DO 125 I=1,N
	IQ=(I*I-I)/2
	IF(I-L) 80,115,80
80	IF(I-M) 85,115,90
85	IM=I+MQ
	GO TO 95
90	IM=M+IQ
95	IF(I-L) 100,105,105
100	IL=I+LQ
	GO TO 110
105	IL=L+IQ
110	X=A(IL)*COSX-A(IM)*SINX
	A(IM)=A(IL)*SINX+A(IM)*COSX
	A(IL)=X
115	IF(MV-1) 120,125,120
120	ILR=ILQ+I
	IMR=IMQ+I
	X=R(ILR)*COSX-R(IMR)*SINX
	R(IMR)=R(ILR)*SINX+R(IMR)*COSX
	R(ILR)=X
125	CONTINUE
	X=2.0*A(LM)*SINCS
	Y=A(LL)*COSX2+A(MM)*SINX2-X
	X=A(LL)*SINX2+A(MM)*COSX2+X
	A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2)
	A(LL)=Y
	A(MM)=X
C
C	   TESTS FOR COMPLETION
C
C	   TEST FOR M = LAST COLUMN
C
130	IF(M-N) 135,140,135
135	M=M+1
	GO TO 60
C
C	   TEST FOR L = SECOND FROM LAST COLUMN
C
140	IF(L-(N-1)) 145,150,145
145	L=L+1
	GO TO 55
150	IF(IND-1) 160,155,160
155	IND=0
	GO TO 50
C
C	   COMPARE THRESHOLD WITH FINAL NORM
C
160	IF(THR-ANRMX) 165,165,45
C
C	   SORT EIGENVALUES AND EIGENVECTORS
C
165	IQ=-N
	DO 185 I=1,N
	IQ=IQ+N
	LL=I+(I*I-I)/2
	JQ=N*(I-2)
	DO 185 J=I,N
	JQ=JQ+N
	MM=J+(J*J-J)/2
	IF(A(LL)-A(MM)) 170,185,185
170	X=A(LL)
	A(LL)=A(MM)
	A(MM)=X
	IF(MV-1) 175,185,175
175	DO 180 K=1,N
	ILR=IQ+K
	IMR=JQ+K
	X=R(ILR)
	R(ILR)=R(IMR)
180	R(IMR)=X
185	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ELI1
C
C	   PURPOSE
C	      COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND
C
C	   USAGE
C	      CALL ELI1(RES,X,CK)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES   - RESULT VALUE
C	      X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
C	              INTEGRAL OF FIRST KIND)
C	      CK    - COMPLEMENTARY MODULUS
C
C	   REMARKS
C	      MODULUS K = SQRT(1.-CK*CK).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED
C	      OVER T FROM 0 TO X).
C	      EQUIVALENT ARE THE DEFINITIONS
C	      RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED
C	      OVER T FROM 0 TO ATAN(X)),
C	      RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER
C	      T FROM 0 TO ATAN(X)).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIONS.
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE ELI1(RES,X,CK)
C
	IF(X)2,1,2
1	RES=0.
	RETURN
2	IF(CK)4,3,4
3	RES=ALOG(ABS(X)+SQRT(1.+X*X))
	GOTO 13
4	ANGLE=ABS(1./X)
	GEO=ABS(CK)
	ARI=1.
	PIM=0.
5	SQGEO=ARI*GEO
	AARI=ARI
	ARI=GEO+ARI
	ANGLE=-SQGEO/ANGLE+ANGLE
	SQGEO=SQRT(SQGEO)
	IF(ANGLE)7,6,7
C	REPLACE 0 BY SMALL VALUE
6	ANGLE=SQGEO*1.E-8
7	TEST=AARI*1.E-4
	IF(ABS(AARI-GEO)-TEST)10,10,8
8	GEO=SQGEO+SQGEO
	PIM=PIM+PIM
	IF(ANGLE)9,5,5
9	PIM=PIM+3.1415927
	GOTO 5
10	IF(ANGLE)11,12,12
11	PIM=PIM+3.1415927
12	RES=(ATAN(ARI/ANGLE)+PIM)/ARI
13	IF(X)14,15,15
14	RES=-RES
15	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ELI2
C
C	   PURPOSE
C	      COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND
C
C	   USAGE
C	      CALL ELI2(R,X,CK,A,B)
C
C	   DESCRIPTION OF PARAMETERS
C	      R     - RESULT VALUE
C	      X     - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC
C	              INTEGRAL OF SECOND KIND)
C	      CK    - COMPLEMENTARY MODULUS
C	      A     - CONSTANT TERM IN NUMERATOR
C	      B     - QUADRATIC TERM IN NUMERATOR
C
C	   REMARKS
C	      MODULUS K = SQRT(1.-CK*CK).
C	      SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF
C	      SECOND KIND ARE
C	      F(ATAN(X),K) OBTAINED WITH A=1., B=1.
C	      E(ATAN(X),K) OBTAINED WITH A=1., B=CK*CK.
C	      B(ATAN(X),K) OBTAINED WITH A=1., B=0.
C	      D(ATAN(X),K) OBTAINED WITH A=0., B=1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)),
C	             SUMMED OVER T FROM 0 TO X).
C	      EQUIVALENT IS THE DEFINITION
C	      R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2),
C	             SUMMED OVER T FROM 0 TO ATAN(X)).
C	      EVALUATION
C	      LANDENS TRANSFORMATION IS USED FOR CALCULATION.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIONS
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE ELI2(R,X,CK,A,B)
C	   TEST ARGUMENT
	IF(X)2,1,2
1	R=0.
	RETURN
C	   TEST MODULUS
2	C=0.
	D=0.5
	IF(CK)7,3,7
3	R=SQRT(1.+X*X)
	R=(A-B)*ABS(X)/R+B*ALOG(ABS(X)+R)
C	   TEST SIGN OF ARGUMENT
4	R=R+C*(A-B)
	IF(X)5,6,6
5	R=-R
6	RETURN
C	   INITIALIZATION
7	AN=(B+A)*0.5
	AA=A
	R=B
	ANG=ABS(1./X)
	PIM=0.
	ISI=0
	ARI=1.
	GEO=ABS(CK)
C	   LANDEN TRANSFORMATION
8	R=AA*GEO+R
	SGEO=ARI*GEO
	AA=AN
	AARI=ARI
C	   ARITHMETIC MEAN
	ARI=GEO+ARI
C	   SUM OF SINE VALUES
	AN=(R/ARI+AA)*0.5
	AANG=ABS(ANG)
	ANG=-SGEO/ANG+ANG
	PIMA=PIM
	IF(ANG)10,9,11
9	ANG=-1.E-8*AANG
10	PIM=PIM+3.1415927
	ISI=ISI+1
11	AANG=ARI*ARI+ANG*ANG
	P=D/SQRT(AANG)
	IF(ISI-4)13,12,12
12	ISI=ISI-4
13	IF(ISI-2)15,14,14
14	P=-P
15	C=C+P
	D=D*(AARI-GEO)*0.5/ARI
	IF(ABS(AARI-GEO)-1.E-4*AARI)17,17,16
16	SGEO=SQRT(SGEO)
C	   GEOMETRIC MEAN
	GEO=SGEO+SGEO
	PIM=PIM+PIMA
	ISI=ISI+ISI
	GOTO 8
C	   ACCURACY WAS SUFFICIENT
17	R=(ATAN(ARI/ANG)+PIM)*AN/ARI
	C=C+D*ANG/AANG
	GOTO 4
	END
C
C	..................................................................
C
C	   SUBROUTINE EXPI
C
C	   PURPOSE
C	      COMPUTES THE EXPONENTIAL INTEGRAL -EI(-X)
C
C	   USAGE
C	      CALL EXPI(X,RES)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     - ARGUMENT OF EXPONENTIAL INTEGRAL
C	      RES   - RESULT VALUE
C	      AUX   - RESULTANT AUXILIARY VALUE
C
C	   REMARKS
C	      X GT 170 (X LT -174) MAY CAUSE UNDERFLOW (OVERFLOW)
C	      WITH THE EXPONENTIAL FUNCTION
C	      FOR X = 0 THE RESULT VALUE IS SET TO -1.7E38                        0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      RES=INTEGRAL(EXP(-T)/T, SUMMED OVER T FROM X TO INFINITY).
C	      EVALUATION
C	      THREE DIFFERENT RATIONAL APPROXIMATIONS ARE USED IN THE
C	      RANGES 1 LE X, X LE -9 AND -9 LT X LE -3 RESPECTIVELY,
C	      A POLYNOMIAL APPROXIMATION IS USED IN -3 LT X LT 1.
C
C	..................................................................
C
	SUBROUTINE EXPI(X,RES,AUX)
	IF(X-1.)2,1,1
1	Y=1./X
	AUX=1.-Y*(((Y+3.377358E0)*Y+2.052156E0)*Y+2.709479E-1)/((((Y*
     11.072553E0+5.716943E0)*Y+6.945239E0)*Y+2.593888E0)*Y+2.709496E-1)
	RES=AUX*Y*EXP(-X)
	RETURN
2	IF(X+3.)6,6,3
3	AUX=(((((((7.122452E-7*X-1.766345E-6)*X+2.928433E-5)*X-2.335379E-4
     1)*X+1.664156E-3)*X-1.041576E-2)*X+5.555682E-2)*X-2.500001E-1)*X
     2+9.999999E-1
	RES=-1.7E38                                                               0
	IF(X)4,5,4
4	RES=X*AUX-ALOG(ABS(X))-5.772157E-1
5	RETURN
6	IF(X+9.)8,8,7
7	AUX=1.-((((5.176245E-2*X+3.061037E0)*X+3.243665E1)*X+2.244234E2)*X
     1+2.486697E2)/((((X+3.995161E0)*X+3.893944E1)*X+2.263818E1)*X
     2+1.807837E2)
	GOTO 9
8	Y=9./X
	AUX=1.-Y*(((Y+7.659824E-1)*Y-7.271015E-1)*Y-1.080693E0)/((((Y
     1*2.518750E0+1.122927E1)*Y+5.921405E0)*Y-8.666702E0)*Y-9.724216E0)
9	RES=AUX*EXP(-X)/X
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR TRIPLE EXPONENTIAL SMOOTHING - EXPON
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD AND A TIME SERIES,
C	      (2) CALL THE SUBROUTINE EXSMO TO SMOOTH THE TIME SERIES,
C	      AND (3) PRINT THE RESULT.
C
C	   REMARKS
C	      A SMOOTHING CONSTANT SPECIFIED IN THE PROBLEM PARAMETER
C	      CARD MUST BE GREATER THAN ZERO BUT LESS THAN ONE IN ORDER
C	      TO OBTAIN REASONABLE RESULTS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      EXSMO
C
C	   METHOD
C	      REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION
C	      OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963,
C	      PP. 140 TO 144.
C
C	..................................................................
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	NUMBER OF DATA POINTS IN A GIVEN TIME SERIES..
cC
cc	   DIMENSION X(1000),S(1000)
cC
cC	..................................................................
cC
c1	FORMAT(A4,A2,I4,F5.0,3F10.0)
c2	FORMAT(12F6.0)
c3	FORMAT(34H1TRIPLE EXPONENTIAL SMOOTHING.....,A4,A2//22H NUMBER OF 
c     1DATA POINTS,I6/19H SMOOTHING CONSTANT,F9.3/)
c4	FORMAT(13H0COEFFICIENTS,9X,1HA,14X,1HB,14X,1HC)
c5	FORMAT(9H0ORIGINAL,F19.5,2F15.5)
c6	FORMAT(8H0UPDATED,F20.5,2F15.5/)
c7	FORMAT(1H0,27X,13HSMOOTHED DATA/7X,10HINPUT DATA,12X,10H(FORECAST)
c     1)
c8	FORMAT(F17.5,8X,F15.5)
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR,PR1,NX,AL,A,B,C
c	IF (EOF) GOTO 999
cC	   PR......PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	   PR1.....PROBLEM NUMBER (CONTINUED)
cC	   NX......NUMBER OF DATA POINTS IN TIME SERIES
cC	   AL......SMOOTHING CONSTANT
cC	   A,B,C...COEFFICIENTS OF THE PREDICTION EQUATION
cC
c	WRITE (6,3) PR,PR1,NX,AL
cC
cC	PRINT ORIGINAL COEFFICIENTS
cC
c	WRITE (6,4)
c	WRITE (6,5) A,B,C
cC
cC	READ TIME SERIES DATA
cC
c	READ (5,2) (X(I),I=1,NX)
cC
c	CALL EXSMO (X,NX,AL,A,B,C,S)
cC
cC	PRINT UPDATED COEFFICIENTS
cC
c	WRITE (6,6) A,B,C
cC
cC	PRINT INPUT AND SMOOTHED DATA
cC
c	WRITE (6,7)
c	DO 200 I=1,NX
c200	WRITE (6,8) X(I),S(I)
c	GO TO 100
c999	STOP
c	END
cC
C	..................................................................
C
C	   SUBROUTINE EXSMO
C
C	   PURPOSE
C	      TO FIND THE TRIPLE EXPONENTIAL SMOOTHED SERIES S OF THE
C	      GIVEN SERIES X.
C
C	   USAGE
C	      CALL EXSMO (X,NX,AL,A,B,C,S)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     - INPUT VECTOR OF LENGTH NX CONTAINING TIME SERIES
C	              DATA WHICH IS TO BE EXPONENTIALLY SMOOTHED.
C	      NX    - THE NUMBER OF ELEMENTS IN X.
C	      AL    - SMOOTHING CONSTANT, ALPHA.  AL MUST BE GREATER THAN
C	              ZERO AND LESS THAN ONE.
C	      A,B,C - COEFFICIENTS OF THE PREDICTION EQUATION WHERE S IS
C	              PREDICTED T PERIODS HENCE BY
C	                            A + B*T + C*T*T/2.
C	              AS INPUT-- IF A=B=C=0, PROGRAM WILL PROVIDE INITIAL
C	              VALUES.  IF AT LEAST ONE OF A,B,C IS NOT ZERO,
C	              PROGRAM WILL TAKE GIVEN VALUES AS INITIAL VALUES.
C	              AS OUTPUT-- A,B,C CONTAIN LATEST, UPDATED COEFFI-
C	              CIENTS OF PREDICTION.
C	      S     - OUTPUT VECTOR OF LENGTH NX CONTAINING TRIPLE
C	              EXPONENTIALLY SMOOTHED TIME SERIES.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION
C	      OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963,
C	      PP. 140 TO 144.
C
C	..................................................................
C
	SUBROUTINE EXSMO (X,NX,AL,A,B,C,S)
	DIMENSION X(1),S(1)
C
C	IF A=B=C=0.0, GENERATE INITIAL VALUES OF A, B, AND C
C
	IF(A) 140, 110, 140
110	IF(B) 140, 120, 140
120	IF(C) 140, 130, 140
130	C=X(1)-2.0*X(2)+X(3)
	B=X(2)-X(1)-1.5*C
	A=X(1)-B-0.5*C
C
140	BE=1.0-AL
	BECUB=BE*BE*BE
	ALCUB=AL*AL*AL
C
C	DO THE FOLLOWING FOR I=1 TO NX
C
	DO 150 I=1,NX
C
C	   FIND S(I) FOR ONE PERIOD AHEAD
C
	S(I)=A+B+0.5*C
C
C	   UPDATE COEFFICIENTS A, B, AND C
C
	DIF=S(I)-X(I)
	A=X(I)+BECUB*DIF
	B=B+C-1.5*AL*AL*(2.0-AL)*DIF
150	C=C-ALCUB*DIF
	RETURN
	END
C
C	.................................................................
C
C	   SAMPLE MAIN PROGRAM FOR FACTOR ANALYSIS - FACTO
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD, (2) CALL FIVE SUBROU-
C	      TINES TO PERFORM A PRINCIPAL COMPONENT SOLUTION AND THE
C	      VARIMAX ROTATION OF A FACTOR MATRIX, AND (3) PRINT THE
C	      RESULTS.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      CORRE  (WHICH, IN TURN, CALLS THE SUBROUTINE NAMED DATA.)
C	      EIGEN
C	      TRACE
C	      LOAD
C	      VARMX
C
C	   METHOD
C	      REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
C	      DIXON, UCLA, 1964.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
C	NUMBER OF VARIABLES, M..
cC
c	   DIMENSION B(35),D(35),S(35),T(35),XBAR(35)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*M..
cC
c	   DIMENSION V(1225)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
cC	(M+1)*M/2..
cC
c	   DIMENSION R(630)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 51..
cC
c	   DIMENSION TV(51)
cC
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION XBAR,S,V,R,D,B,T,TV
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	   ...............................................................
cC
c1	FORMAT(21H1FACTOR ANALYSIS.....A4,A2//3X,12HNO. OF CASES,4X,I6/3X,
c     116HNO. OF VARIABLES,I6/)
c2	FORMAT(6H0MEANS/(8F15.5))
c3	FORMAT(20H0STANDARD DEVIATIONS/(8F15.5))
c4	FORMAT(25H0CORRELATION COEFFICIENTS)
c5	FORMAT(4H0ROWI3/(10F12.5))
c6	FORMAT(1H0/12H EIGENVALUES/(10F12.5))
c7	FORMAT(37H0CUMULATIVE PERCENTAGE OF EIGENVALUES/(10F12.5))
c8	FORMAT(1H0/13H EIGENVECTORS)
c9	FORMAT(7H0VECTORI3/(10F12.5))
c10	FORMAT(1H0/16H FACTOR MATRIX (,I3,9H FACTORS))
c11	FORMAT(9H0VARIABLEI3/(10F12.5))
c12	FORMAT(1H0/10H ITERATION,7X,9HVARIANCES/8H   CYCLE)
c13	FORMAT(I6,F20.6)
c14	FORMAT(1H0/24H ROTATED FACTOR MATRIX (I3,9H FACTORS))
c15	FORMAT(9H0VARIABLEI3/(10F12.5))
c16	FORMAT(1H0/23H CHECK ON COMMUNALITIES//9H VARIABLE,7X,8HORIGINAL,
c     112X,5HFINAL,10X,10HDIFFERENCE)
c17	FORMAT(I6,3F18.5)
c18	FORMAT(A4,A2,I5,I2,F6.0)
c19	FORMAT(5H0ONLY,I2,30H FACTOR RETAINED.  NO ROTATION)
cC	DOUBLE PRECISION TMPFIL,FILE
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC	FILE = TMPFIL('SSP')
cC	OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
cC	1	DISPOSE='DELETE')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,18) PR,PR1,N,M,CON
c	IF (EOF) GOTO 999
cC	   PR.........PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	   PR1........PROBLEM NUMBER (CONTINUED)
cC	   N..........NUMBER OF CASES
cC	   M..........NUMBER OF VARIABLES
cC	   CON........CONSTANT USED TO DECIDE HOW MANY EIGENVALUES
cC	                TO RETAIN
cC
c	WRITE (6,1) PR,PR1,N,M
cC
c	IO=0
c	X=0.0
cC
c	CALL CORRE (N,M,IO,X,XBAR,S,V,R,D,B,T)
cC
cC	PRINT MEANS
cC
c	WRITE (6,2) (XBAR(J),J=1,M)
cC
cC	PRINT STANDARD DEVIATIONS
cC
c	WRITE (6,3) (S(J),J=1,M)
cC
cC	PRINT CORRELATION COEFFICIENTS
cC
c	WRITE (6,4)
c	DO 120 I=1,M
c	DO 110 J=1,M
c	IF(I-J) 102, 104, 104
c102	L=I+(J*J-J)/2
c	GO TO 110
c104	L=J+(I*I-I)/2
c110	D(J)=R(L)
c120	WRITE (6,5) I,(D(J),J=1,M)
cC
c	MV=0
c	CALL EIGEN (R,V,M,MV)
cC
c	CALL TRACE (M,R,CON,K,D)
cC
cC	PRINT EIGENVALUES
cC
c	DO 130 I=1,K
c	L=I+(I*I-I)/2
c130	S(I)=R(L)
c	WRITE (6,6) (S(J),J=1,K)
cC
cC	PRINT CUMULATIVE PERCENTAGE OF EIGENVALUES
cC
c	WRITE (6,7) (D(J),J=1,K)
cC
cC	PRINT EIGENVECTORS
cC
c	WRITE (6,8)
c	L=0
c	DO 150 J=1,K
c	DO 140 I=1,M
c	L=L+1
c140	D(I)=V(L)
c150	WRITE (6,9) J,(D(I),I=1,M)
cC
c	CALL LOAD (M,K,R,V)
cC
cC	PRINT FACTOR MATRIX
cC
c	WRITE (6,10) K
c	DO 180 I=1,M
c	DO 170 J=1,K
c	L=M*(J-1)+I
c170	D(J)=V(L)
c180	WRITE (6,11) I,(D(J),J=1,K)
cC
c	IF(K-1) 185, 185, 188
c185	WRITE (6,19) K
c	GO TO 100
cC
c188	CALL VARMX (M,K,V,NC,TV,B,T,D,IER)
c	IF (IER .EQ. 1) WRITE (6,998)
c998	FORMAT(/' **** WARNING ****'/
c     1	' CONVERGENCE NOT REACHED AFTER 50 ITERATIONS'/)
cC
cC	PRINT VARIANCES
cC
c	NV=NC+1
c	WRITE (6,12)
c	DO 190 I=1,NV
c	NC=I-1
c190	WRITE (6,13) NC,TV(I)
cC
cC	PRINT ROTATED FACTOR MATRIX
cC
c	WRITE (6,14) K
c	DO 220 I=1,M
c	DO 210 J=1,K
c	L=M*(J-1)+I
c210	S(J)=V(L)
c220	WRITE (6,15) I,(S(J),J=1,K)
cC
cC	PRINT COMMUNALITIES
cC
c	WRITE (6,16)
c	DO 230 I=1,M
c230	WRITE (6,17) I,B(I),T(I),D(I)
c	GO TO 100
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE FACTR
C
C	   PURPOSE
C	      FACTORIZATION OF THE MATRIX A INTO A PRODUCT OF A LOWER
C	      TRIANGULAR MATRIX L AND AN UPPER TRIANGULAR MATRIX U.  L HAS
C	      UNIT DIAGONAL WHICH IS NOT STORED.
C
C	   USAGE
C	      CALL FACTR(A,PER,N,IA,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      MATRIX A
C	      PER    ONE DIMENSIONAL ARRAY WHERE PERMUTATIONS OF ROWS OF
C	             THE MATRIX ARE STORED
C	             DIMENSION OF PER MUST BE GREATER THAN OR EQUAL TO N
C	      N      ORDER OF THE MATRIX A
C	      IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A
C	             IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE
C	             SUBSCRIPTED DATA STORAGE MODE.  IA=N WHEN THE MATRIX
C	             IS IN SSP VECTOR STORAGE MODE.
C	      IER    ERROR INDICATOR WHICH IS ZERO IF THERE IS NO ERROR,
C	             AND IS THREE IF THE PROCEDURE FAILS.
C
C	   REMARKS
C	      THE ORIGINAL MATRIX, A,IS REPLACED BY THE TRIANGULAR FACTORS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SUCCESSIVE COMPUTATION OF THE COLUMNS OF L AND THE
C	      CORRESPONDING ROWS OF U.
C
C	   REFERENCES
C	      J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
C	      CLARENDON PRESS, OXFORD, 1965. H. J. BOWDLER, R. S. MARTIN,
C	      G. PETERS, AND J. H. WILKINSON - 'SOLUTION OF REAL AND
C	      COMPLEX SYSTEMS OF LINEAR EQUATIONS', NUMERISCHE MATHEMATIK,
C	      VOL. 8, NO. 3, 1966, P. 217-234.
C
C	..................................................................
C
	SUBROUTINE FACTR(A,PER,N,IA,IER)
	DIMENSION A(1),PER(1)
	DOUBLE PRECISION DP
C
C	   COMPUTATION OF WEIGHTS FOR EQUILIBRATION
C
	DO 20 I=1,N
	X=0.
	IJ=I
	DO 10 J=1,N
	IF (ABS(A(IJ))-X)10,10,5
5	X=ABS(A(IJ))
10	IJ=IJ+IA
	IF (X) 110,110,20
20	PER(I)=1./X
	I0=0
	DO 100 I=1,N
	IM1=I-1
	IP1=I+1
	IPIVOT=I
	X=0.
C
C	   COMPUTATION OF THE ITH COLUMN OF L
C
	DO 50 K=I,N
	KI=I0+K
	DP=A(KI)
	IF (I-1) 110,40,25
25	KJ=K
	DO 30 J=1,IM1
	IJ=I0+J
	DP=DP-1.D0*A(KJ)*A(IJ)
30	KJ=KJ+IA
	A(KI)=DP
C
C	   SEARCH FOR EQUILIBRATED PIVOT
C
40	IF (X-DABS(DP)*PER(K))45,50,50
45	IPIVOT=K
	X=DABS(DP)*PER(K)
50	CONTINUE
	IF (X)110,110,55
C
C	   PERMUTATION OF ROWS IF REQUIRED
C
55	IF (IPIVOT-I) 110,70,57
57	KI=IPIVOT
	IJ=I
	DO 60 J=1,N
	X=A(IJ)
	A(IJ)=A(KI)
	A(KI)=X
	KI=KI+IA
60	IJ=IJ+IA
	PER(IPIVOT)=PER(I)
70	PER(I)=IPIVOT
	IF (I-N) 72,100,100
72	IJ=I0+I
	X=A(IJ)
C
C	   COMPUTATION OF THE ITH ROW OF U
C
	K0=I0+IA
	DO 90 K=IP1,N
	KI=I0+K
	A(KI)=A(KI)/X
	IF (I-1)110,90,75
75	IJ=I
	KI=K0+I
	DP=A(KI)
	DO 80 J=1,IM1
	KJ=K0+J
	DP=DP-1.D0*A(IJ)*A(KJ)
80	IJ=IJ+IA
	A(KI)=DP
90	K0=K0+IA
100	I0=I0+IA
	IER=0
	RETURN
110	IER=3
	RETURN
	END
C	FUNCTION FCDF
C	GIVES PROBABILITIES FOR OBSERVED STATISTICS
C
C	T P=P^2
C	N = DF
C	M = INFINITY
C
C	Z P=P^2
C	N = INFINITY
CF	M = 1
C
C	CHI2 P=P/M
C	N =  INFINITY
C	M = DF
C
C	F P=P
C	M = DF1
C	N = DF2
	FUNCTION FCDF(FR,M,N)
C	FROM DECUSSCOPE
C	13:2 PAGE 7
C MODIFIED 10/8/84 LP ADDED DOUBLE
	IMPLICIT DOUBLE PRECISION (A-J,P-Z)
	REAL FR
	KONSTANT PI=3.1415926535
	FCDF=0
	CON=1
	FM=M
	FN=N
	IF((M-M/2*2).EQ.0)GOTO 80
	IF((N-N/2*2).EQ.0)GOTO 60
	IF(N.NE.1)GOTO 5
	THETA=ATAN(SQRT(FN/(FM*FR)))
	J=M/2
	GOTO 7
5	THETA=ATAN(SQRT(FM*FR/FN))
	J=N/2
7	SINE=SIN(THETA)
	SINSQ=SINE*SINE
	COSQ=1.0-SINSQ
	COSN=SQRT(COSQ)
	IF((M.EQ.1).AND.(N.EQ.1))GOTO 50
	DO 10 I=1,J
	FCDF=FCDF+CON
	TWI=2*I
10	CON=CON*TWI*COSQ/(TWI+1.0)
50	FCDF=1.0-2.0*(FCDF*SINE*COSN+THETA)/PI
	IF (N.EQ.1)RETURN
	FCDF=1.0-FCDF
	IF(M.EQ.1)RETURN
	FCTR=CON
	CON=1.0
	PEP=0.0
	FNM1=N-1
	J=M/2
	DO 20 I=1,J
	PEP=PEP+CON
	TWI=2*I
20	CON=CON*(FNM1+TWI)*SINSQ/(TWI+1.0)
	FCDF=FCDF-2.*FN*FCTR*SINE*COSN*PEP/PI
	RETURN
60	X=FN/(FN+FM*FR)
	J=N/2
	FMS2=M-2
	GOTO 85
80	X=FM*FR/(FN+FM*FR)
	J=M/2
	FMS2=N-2
85	OWX=1.0-X
	DO 90 I=1,J
	FCDF=FCDF+CON
	TWI=2*I
	CON=CON*(FMS2+TWI)*X/TWI
	IF(CON.LT.1E-6)GOTO 91
90	CONTINUE
91	IF((M-M/2*2).NE.0)GOTO 100
	FCDF=1.0-OWX**(FN/2.0)*FCDF
	RETURN
100	FCDF=OWX**(FM/2.0)*FCDF
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE FMCG
C
C	   PURPOSE
C	      TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
C	      BY THE METHOD OF CONJUGATE GRADIENTS
C
C	   USAGE
C	      CALL FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DESCRIPTION OF PARAMETERS
C	      FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
C	               BE MINIMIZED. IT MUST BE OF THE FORM
C	               SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
C	               AND MUST SERVE THE FOLLOWING PURPOSE
C	               FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
C	               FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
C	               AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
C	      N      - NUMBER OF VARIABLES
C	      X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
C	               ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
C	               X HOLDS THE ARGUMENT CORRESPONDING TO THE
C	               COMPUTED MINIMUM FUNCTION VALUE
C	      F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
C	               VALUE ON RETURN, I.E. F=F(X).
C	      G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
C	               VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
C	               I.E. G=G(X).
C	      EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
C	      EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
C	               A REASONABLE CHOICE IS 10**(-6), I.E.
C	               SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
C	               NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
C	               REPRESENTATION.
C	      LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
C	      IER    - ERROR PARAMETER
C	               IER = 0 MEANS CONVERGENCE WAS OBTAINED
C	               IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
C	               IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
C	               IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
C	               IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
C	      H      - WORKING STORAGE OF DIMENSION 2*N.
C
C	   REMARKS
C	       I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
C	          MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
C	      II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
C	          DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
C	          A TOLERABLE RANGE OF ARGUMENT.
C	          IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
C	          INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
C	          RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
C	          MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
C	          TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
C	          IS FOUND WHERE THE FUNCTION INCREASES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      FUNCT
C
C	   METHOD
C	      THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
C	      R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY
C	      CONJUGATE GRADIENTS,
C	      COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154.
C
C	..................................................................
C
	SUBROUTINE FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION X(1),G(1),H(1)
C
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
	CALL FUNCT(N,X,F,G)
C
C	   RESET ITERATION COUNTER
	KOUNT=0
	IER=0
	N1=N+1
C
C	   START ITERATION CYCLE FOR EVERY N+1 ITERATIONS
1	DO 43 II=1,N1
C
C	   STEP ITERATION COUNTER AND SAVE FUNCTION VALUE
	KOUNT=KOUNT+1
	OLDF=F
C
C	   COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO
	GNRM=0.
	DO 2 J=1,N
2	GNRM=GNRM+G(J)*G(J)
	IF(GNRM)46,46,3
C
C	   EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL
C	   BE IN DIRECTION OF STEEPEST DESCENT
3	IF(II-1)4,4,6
4	DO 5 J=1,N
5	H(J)=-G(J)
	GO TO 8
C
C	   FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING
C	   TO THE CONJUGATE GRADIENT METHOD
6	AMBDA=GNRM/OLDG
	DO 7 J=1,N
7	H(J)=AMBDA*H(J)-G(J)
C
C	   COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL
C	   DERIVATIVE
8	DY=0.
	HNRM=0.
	DO 9 J=1,N
	K=J+N
C
C	   SAVE ARGUMENT VECTOR
	H(K)=X(J)
	HNRM=HNRM+ABS(H(J))
9	DY=DY+H(J)*G(J)
C
C	   CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND
C	   SKIP LINEAR SEARCH ROUTINE IF NOT
	IF(DY)10,42,42
C
C	   COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE
10	SNRM=1./HNRM
C
C	   SEARCH MINIMUM ALONG DIRECTION H
C
C	   SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
	FY=F
	ALFA=2.*(EST-F)/DY
	AMBDA=SNRM
C
C	   USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
C	   SNRM. OTHERWISE TAKE SNRM AS STEPSIZE.
	IF(ALFA)13,13,11
11	IF(ALFA-AMBDA)12,13,13
12	AMBDA=ALFA
13	ALFA=0.
C
C	   SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
14	FX=FY
	DX=DY
C
C	   STEP ARGUMENT ALONG H
	DO 15 I=1,N
15	X(I)=X(I)+AMBDA*H(I)
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
	CALL FUNCT(N,X,F,G)
	FY=F
C
C	   COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
C	   SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
	DY=0.
	DO 16 I=1,N
16	DY=DY+G(I)*H(I)
	IF(DY)17,38,20
C
C	   TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
C	   A MINIMUM HAS BEEN PASSED
17	IF(FY-FX)18,20,20
C
C	   REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
18	AMBDA=AMBDA+ALFA
	ALFA=AMBDA
C
C	   TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
	IF(HNRM*AMBDA-1.E10)14,14,19
C
C	   LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
19	IER=2
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
	F=OLDF
	DO 100 J=1,N
	G(J)=H(J)
	K=N+J
100	X(J)=H(K)
	RETURN
C	   END OF SEARCH LOOP
C
C	   INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
C	   ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
C	   POLYNOMIAL IS MINIMIZED
C
20	T=0.
21	IF(AMBDA)22,38,22
22	Z=3.*(FX-FY)/AMBDA+DX+DY
	ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY))
	DALFA=Z/ALFA
	DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
	IF(DALFA)23,27,27
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
23	DO 24 J=1,N
	K=N+J
24	X(J)=H(K)
	CALL FUNCT(N,X,F,G)
C
C	   TEST FOR REPEATED FAILURE OF ITERATION
25	IF(IER)47,26,47
26	IER=-1
	GOTO 1
27	W=ALFA*SQRT(DALFA)
	ALFA=DY-DX+W+W
	IF(ALFA)270,271,270
270	ALFA=(DY-Z+W)/ALFA
	GO TO 272
271	ALFA=(Z+DY-W)/(Z+DX+Z+DY)
272	ALFA=ALFA*AMBDA
	DO 28 I=1,N
28	X(I)=X(I)+(T-ALFA)*H(I)
C
C	   TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
C	   THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
C	   THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
C	   THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
C	   VALUE OF THE FUNCTION AND ITS GRADIENT AT X
C
	CALL FUNCT(N,X,F,G)
	IF(F-FX)29,29,30
29	IF(F-FY)38,38,30
C
C	   COMPUTE DIRECTIONAL DERIVATIVE
30	DALFA=0.
	DO 31 I=1,N
31	DALFA=DALFA+G(I)*H(I)
	IF(DALFA)32,35,35
32	IF(F-FX)34,33,35
33	IF(DX-DALFA)34,38,34
34	FX=F
	DX=DALFA
	T=ALFA
	AMBDA=ALFA
	GO TO 21
35	IF(FY-F)37,36,37
36	IF(DY-DALFA)37,38,37
37	FY=F
	DY=DALFA
	AMBDA=AMBDA-ALFA
	GO TO 20
C
C	   TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
C	   OTHERWISE SAVE GRADIENT NORM
38	IF(OLDF-F+EPS)19,25,39
39	OLDG=GNRM
C
C	   COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR
	T=0.
	DO 40 J=1,N
	K=J+N
	H(K)=X(J)-H(K)
40	T=T+ABS(H(K))
C
C	   TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS
C	   HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS
	IF(KOUNT-N1)42,41,41
41	IF(T-EPS)45,45,42
C
C	   TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
42	IF(KOUNT-LIMIT)43,44,44
43	IER=0
C	   END OF ITERATION CYCLE
C
C	   START NEXT ITERATION CYCLE
	GO TO 1
C
C	   NO CONVERGENCE AFTER  LIMIT  ITERATIONS
44	IER=1
	IF(GNRM-EPS)46,46,47
C
C	   TEST FOR SUFFICIENTLY SMALL GRADIENT
45	IF(GNRM-EPS)46,46,25
46	IER=0
47	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE FMFP
C
C	   PURPOSE
C	      TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES
C	      BY THE METHOD OF FLETCHER AND POWELL
C
C	   USAGE
C	      CALL FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DESCRIPTION OF PARAMETERS
C	      FUNCT  - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO
C	               BE MINIMIZED. IT MUST BE OF THE FORM
C	               SUBROUTINE FUNCT(N,ARG,VAL,GRAD)
C	               AND MUST SERVE THE FOLLOWING PURPOSE
C	               FOR EACH N-DIMENSIONAL ARGUMENT VECTOR  ARG,
C	               FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED
C	               AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY
C	      N      - NUMBER OF VARIABLES
C	      X      - VECTOR OF DIMENSION N CONTAINING THE INITIAL
C	               ARGUMENT WHERE THE ITERATION STARTS. ON RETURN,
C	               X HOLDS THE ARGUMENT CORRESPONDING TO THE
C	               COMPUTED MINIMUM FUNCTION VALUE
C	      F      - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION
C	               VALUE ON RETURN, I.E. F=F(X).
C	      G      - VECTOR OF DIMENSION N CONTAINING THE GRADIENT
C	               VECTOR CORRESPONDING TO THE MINIMUM ON RETURN,
C	               I.E. G=G(X).
C	      EST    - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE.
C	      EPS    - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR.
C	               A REASONABLE CHOICE IS 10**(-6), I.E.
C	               SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE
C	               NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT
C	               REPRESENTATION.
C	      LIMIT  - MAXIMUM NUMBER OF ITERATIONS.
C	      IER    - ERROR PARAMETER
C	               IER = 0 MEANS CONVERGENCE WAS OBTAINED
C	               IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS
C	               IER =-1 MEANS ERRORS IN GRADIENT CALCULATION
C	               IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES
C	               IT IS LIKELY THAT THERE EXISTS NO MINIMUM.
C	      H      - WORKING STORAGE OF DIMENSION N*(N+7)/2.
C
C	   REMARKS
C	       I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT  FUNCT
C	          MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM.
C	      II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED
C	          DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN
C	          A TOLERABLE RANGE OF ARGUMENT.
C	          IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F
C	          INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS
C	          RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE
C	          MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH
C	          TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT
C	          IS FOUND WHERE THE FUNCTION INCREASES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      FUNCT
C
C	   METHOD
C	      THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE
C	      R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR
C	      MINIMIZATION,
C	      COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168.
C
C	..................................................................
C
	SUBROUTINE FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION H(1),X(1),G(1)
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT
	CALL FUNCT(N,X,F,G)
C
C	   RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX
	IER=0
	KOUNT=0
	N2=N+N
	N3=N2+N
	N31=N3+1
1	K=N31
	DO 4 J=1,N
	H(K)=1.
	NJ=N-J
	IF(NJ)5,5,2
2	DO 3 L=1,NJ
	KL=K+L
3	H(KL)=0.
4	K=KL+1
C
C	   START ITERATION LOOP
5	KOUNT=KOUNT +1
C
C	   SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR
	OLDF=F
	DO 9 J=1,N
	K=N+J
	H(K)=G(J)
	K=K+N
	H(K)=X(J)
C
C	   DETERMINE DIRECTION VECTOR H
	K=J+N3
	T=0.
	DO 8 L=1,N
	T=T-G(L)*H(K)
	IF(L-J)6,7,7
6	K=K+N-L
	GO TO 8
7	K=K+1
8	CONTINUE
9	H(J)=T
C
C	   CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H.
	DY=0.
	HNRM=0.
	GNRM=0.
C
C	   CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION
C	   VECTOR H AND GRADIENT VECTOR G.
	DO 10 J=1,N
	HNRM=HNRM+ABS(H(J))
	GNRM=GNRM+ABS(G(J))
10	DY=DY+H(J)*G(J)
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL
C	   DERIVATIVE APPEARS TO BE POSITIVE OR ZERO.
	IF(DY)11,51,51
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION
C	   VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G.
11	IF(HNRM/GNRM-EPS)51,51,12
C
C	   SEARCH MINIMUM ALONG DIRECTION H
C
C	   SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE
12	FY=F
	ALFA=2.*(EST-F)/DY
	AMBDA=1.
C
C	   USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN
C	   1. OTHERWISE TAKE 1. AS STEPSIZE
	IF(ALFA)15,15,13
13	IF(ALFA-AMBDA)14,15,15
14	AMBDA=ALFA
15	ALFA=0.
C
C	   SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT
16	FX=FY
	DX=DY
C
C	   STEP ARGUMENT ALONG H
	DO 17 I=1,N
17	X(I)=X(I)+AMBDA*H(I)
C
C	   COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT
	CALL FUNCT(N,X,F,G)
	FY=F
C
C	   COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT.  TERMINATE
C	   SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND
	DY=0.
	DO 18 I=1,N
18	DY=DY+G(I)*H(I)
	IF(DY)19,36,22
C
C	   TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT
C	   A MINIMUM HAS BEEN PASSED
19	IF(FY-FX)20,22,22
C
C	   REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES
20	AMBDA=AMBDA+ALFA
	ALFA=AMBDA
C	   END OF SEARCH LOOP
C
C	   TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE
	IF(HNRM*AMBDA-1.E10)16,16,21
C
C	   LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS
21	IER=2
	RETURN
C
C	   INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH
C	   ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION
C	   POLYNOMIAL IS MINIMIZED
22	T=0.
23	IF(AMBDA)24,36,24
24	Z=3.*(FX-FY)/AMBDA+DX+DY
	ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY))
	DALFA=Z/ALFA
	DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA
	IF(DALFA)51,25,25
25	W=ALFA*SQRT(DALFA)
	ALFA=DY-DX+W+W
	IF(ALFA) 250,251,250
250	ALFA=(DY-Z+W)/ALFA
	GO TO 252
251	ALFA=(Z+DY-W)/(Z+DX+Z+DY)
252	ALFA=ALFA*AMBDA
	DO 26 I=1,N
26	X(I)=X(I)+(T-ALFA)*H(I)
C
C	   TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS
C	   THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE
C	   THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT
C	   THE INTERPOLATION.  WHICH END-POINT IS CHOOSEN DEPENDS ON THE
C	   VALUE OF THE FUNCTION AND ITS GRADIENT AT X
C
	CALL FUNCT(N,X,F,G)
	IF(F-FX)27,27,28
27	IF(F-FY)36,36,28
28	DALFA=0.
	DO 29 I=1,N
29	DALFA=DALFA+G(I)*H(I)
	IF(DALFA)30,33,33
30	IF(F-FX)32,31,33
31	IF(DX-DALFA)32,36,32
32	FX=F
	DX=DALFA
	T=ALFA
	AMBDA=ALFA
	GO TO 23
33	IF(FY-F)35,34,35
34	IF(DY-DALFA)35,36,35
35	FY=F
	DY=DALFA
	AMBDA=AMBDA-ALFA
	GO TO 22
C
C	   TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION
36	IF(OLDF-F+EPS)51,38,38
C
C	   COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM
C	   TWO CONSECUTIVE ITERATIONS
38	DO 37 J=1,N
	K=N+J
	H(K)=G(J)-H(K)
	K=N+K
37	H(K)=X(J)-H(K)
C
C	   TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR
C	   IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF
C	   BOTH ARE LESS THAN  EPS
	IER=0
	IF(KOUNT-N)42,39,39
39	T=0.
	Z=0.
	DO 40 J=1,N
	K=N+J
	W=H(K)
	K=K+N
	T=T+ABS(H(K))
40	Z=Z+W*H(K)
	IF(HNRM-EPS)41,41,42
41	IF(T-EPS)56,56,42
C
C	   TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED  LIMIT
42	IF(KOUNT-LIMIT)43,50,50
C
C	   PREPARE UPDATING OF MATRIX H
43	ALFA=0.
	DO 47 J=1,N
	K=J+N3
	W=0.
	DO 46 L=1,N
	KL=N+L
	W=W+H(KL)*H(K)
	IF(L-J)44,45,45
44	K=K+N-L
	GO TO 46
45	K=K+1
46	CONTINUE
	K=N+J
	ALFA=ALFA+W*H(K)
47	H(J)=W
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS
C	   ARE NOT SATISFACTORY
	IF(Z*ALFA)48,1,48
C
C	   UPDATE MATRIX H
48	K=N31
	DO 49 L=1,N
	KL=N2+L
	DO 49 J=L,N
	NJ=N2+J
	H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA
49	K=K+1
	GO TO 5
C	   END OF ITERATION LOOP
C
C	   NO CONVERGENCE AFTER  LIMIT  ITERATIONS
50	IER=1
	RETURN
C
C	   RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS
51	DO 52 J=1,N
	K=N2+J
52	X(J)=H(K)
	CALL FUNCT(N,X,F,G)
C
C	   REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE
C	   FAILS TO BE SUFFICIENTLY SMALL
	IF(GNRM-EPS)55,55,53
C
C	   TEST FOR REPEATED FAILURE OF ITERATION
53	IF(IER)56,54,54
54	IER=-1
	GOTO 1
55	IER=0
56	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE FORIF
C
C	   PURPOSE
C	      FOURIER ANALYSIS OF A GIVEN PERIODIC FUNCTION IN THE
C	      RANGE 0-2PI
C	      COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS
C	      IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX)
C	      WHERE K=1,2,...,M TO APPROXIMATE THE COMPUTED VALUES OF A
C	      GIVEN FUNCTION SUBPROGRAM
C
C	   USAGE
C	      CALL FORIF(FUN,N,M,A,B,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      FUN-NAME OF FUNCTION SUBPROGRAM TO BE USED FOR COMPUTING
C	          DATA POINTS
C	      N  -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN
C	          OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1
C	      M  -THE MAXIMUM ORDER OF THE HARMONICS TO BE FITTED
C	      A  -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF
C	          LENGTH M+1
C	          A SUB 0, A SUB 1,..., A SUB M
C	      B  -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF
C	          LENGTH M+1
C	          B SUB 0, B SUB 1,..., B SUB M
C	      IER-RESULTANT ERROR CODE WHERE
C	          IER=0  NO ERROR
C	          IER=1  N NOT GREATER OR EQUAL TO M
C	          IER=2  M LESS THAN 0
C
C	   REMARKS
C	      M MUST BE GREATER THAN OR EQUAL TO ZERO
C	      N MUST BE GREATER THAN OR EQUAL TO M
C	      THE FIRST ELEMENT IN VECTOR B IS ZERO IN ALL CASES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      FUN-NAME OF USER FUNCTION SUBPROGRAM USED FOR COMPUTING
C	          DATA POINTS
C	      CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT
C	      CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO
C	      FORIF
C
C	   METHOD
C	      USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF,
C	      'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY
C	      AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF
C	      INDEXING THROUGH THE PROCEDURE HAS BEEN MODIFIED TO
C	      SIMPLIFY THE COMPUTATION.
C
C	..................................................................
C
	SUBROUTINE FORIF(FUN,N,M,A,B,IER)
	DIMENSION A(1),B(1)
C
C	   CHECK FOR PARAMETER ERRORS
C
	IER=0
20	IF(M) 30,40,40
30	IER=2
	RETURN
40	IF(M-N) 60,60,50
50	IER=1
	RETURN
C
C	   COMPUTE AND PRESET CONSTANTS
C
60	AN=N
	COEF=2.0/(2.0*AN+1.0)
	CONST=3.141593*COEF
	S1=SIN(CONST)
	C1=COS(CONST)
	C=1.0
	S=0.0
	J=1
	FUNZ=FUN(0.0)
70	U2=0.0
	U1=0.0
	AI=2*N
C
C	   FORM FOURIER COEFFICIENTS RECURSIVELY
C
75	X=AI*CONST
	U0=FUN(X)+2.0*C*U1-U2
	U2=U1
	U1=U0
	AI=AI-1.0
	IF(AI) 80,80,75
80	A(J)=COEF*(FUNZ+C*U1-U2)
	B(J)=COEF*S*U1
	IF(J-(M+1)) 90,100,100
90	Q=C1*C-S1*S
	S=C1*S+S1*C
	C=Q
	J=J+1
	GO TO 70
100	A(1)=A(1)*0.5
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE FORIT
C
C	   PURPOSE
C	      FOURIER ANALYSIS OF A PERIODICALLY TABULATED FUNCTION.
C	      COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS
C	      IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX)
C	      WHERE K=1,2,...,M TO APPROXIMATE A GIVEN SET OF
C	      PERIODICALLY TABULATED VALUES OF A FUNCTION.
C
C	   USAGE
C	      CALL FORIT(FNT,N,M,A,B,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      FNT-VECTOR OF TABULATED FUNCTION VALUES OF LENGTH 2N+1
C	      N  -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN
C	          OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1
C	      M  -MAXIMUM ORDER OF HARMONICS TO BE FITTED
C	      A  -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF
C	          LENGTH M+1
C	          A SUB 0, A SUB 1,..., A SUB M
C	      B  -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF
C	          LENGTH M+1
C	          B SUB 0, B SUB 1,..., B SUB M
C	      IER-RESULTANT ERROR CODE WHERE
C	          IER=0  NO ERROR
C	          IER=1  N NOT GREATER OR EQUAL TO M
C	          IER=2  M LESS THAN 0
C
C	   REMARKS
C	      M MUST BE GREATER THAN OR EQUAL TO ZERO
C	      N MUST BE GREATER THAN OR EQUAL TO M
C	      THE FIRST ELEMENT OF VECTOR B IS ZERO IN ALL CASES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF,
C	      'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY
C	      AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF INDEXING
C	      THROUGH THE PROCEDURE HAS BEEN MODIFIED TO SIMPLIFY THE
C	      COMPUTATION.
C
C	..................................................................
C
	SUBROUTINE FORIT(FNT,N,M,A,B,IER)
	DIMENSION A(1),B(1),FNT(1)
C
C	   CHECK FOR PARAMETER ERRORS
C
	IER=0
20	IF(M) 30,40,40
30	IER=2
	RETURN
40	IF(M-N) 60,60,50
50	IER=1
	RETURN
C
C	   COMPUTE AND PRESET CONSTANTS
C
60	AN=N
	COEF=2.0/(2.0*AN+1.0)
	CONST=3.141593*COEF
	S1=SIN(CONST)
	C1=COS(CONST)
	C=1.0
	S=0.0
	J=1
	FNTZ=FNT(1)
70	U2=0.0
	U1=0.0
	I=2*N+1
C
C	   FORM FOURIER COEFFICIENTS RECURSIVELY
C
75	U0=FNT(I)+2.0*C*U1-U2
	U2=U1
	U1=U0
	I=I-1
	IF(I-1) 80,80,75
80	A(J)=COEF*(FNTZ+C*U1-U2)
	B(J)=COEF*S*U1
	IF(J-(M+1)) 90,100,100
90	Q=C1*C-S1*S
	S=C1*S+S1*C
	C=Q
	J=J+1
	GO TO 70
100	A(1)=A(1)*0.5
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE FRAT
C
C	   PURPOSE
C	      FRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS
C	      WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF
C	      RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY
C
C	   USAGE
C	      CALL FRAT(I,N,M,P,DATI,WGT,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      I     - SUBSCRIPT OF CURRENT DATA POINT
C	      N     - NUMBER OF ALL DATA POINTS
C	      M     - NUMBER OF FUNDAMENTAL FUNCTIONS USED
C	      P     - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS
C	              ON RETURN THE VALUES OF THE M FUNDAMENTAL
C	              FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE
C	      DATI  - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED
C	              BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY
C	              N WEIGHT VALUES
C	      WGT   - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM
C	      IER   - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT
C	              VALUES FOR CONTROL
C	              IER(2) MEANS DIMENSION OF NUMERATOR
C	              IER(3) MEANS DIMENSION OF DENOMINATOR
C	              IER(1) IS USED AS RESULTANT ERROR PARAMETER,
C	              IER(1) = 0 IN CASE OF NO ERRORS
C	              IER(1) = 1 OTHERWISE (ZERO DENOMINATOR)
C
C	   REMARKS
C	      VECTOR IER IS USED FOR COMMUNICATION BETWEEN ARAT AND FRAT
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      CNP
C
C	   METHOD
C	      CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT
C
C	..................................................................
C
	SUBROUTINE FRAT(I,N,M,P,DATI,WGT,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION P(1),DATI(1),IER(1)
C
C	   INITIALIZATION
	IP=IER(2)
	IQ=IER(3)
	IQM1=IQ-1
	IPQ=IP+IQ
C
C	   LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT
C	   LOOK UP NUMERATOR AND DENOMINATOR
	T=DATI(I)
	J=I+N
	F=DATI(J)
	FNUM=P(J)
	J=J+N
	WGT=1.
	IF(DATI(2*N+1))2,2,1
1	WGT=DATI(J)
2	FDEN=P(J)
C
C	   CALCULATE FUNCTION VALUE USED
	F=F*FDEN-FNUM
C
C	   CHECK FOR ZERO DENOMINATOR
	IF(FDEN)4,3,4
C
C	   ERROR RETURN IN CASE OF ZERO DENOMINATOR
3	IER(1)=1
	RETURN
C
C	   CALCULATE WEIGHT FACTORS USED
4	WGT=WGT/(FDEN*FDEN)
	FNUM=-FNUM/FDEN
C
C	   CALCULATE FUNDAMENTAL FUNCTIONS
	J=IQM1
	IF(IP-IQ)6,6,5
5	J=IP-1
6	CALL CNP(P(IQ),T,J)
C
C	   STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS
7	IF(IQM1)10,10,8
8	DO 9 II=1,IQM1
	J=II+IQ
9	P(II)=P(J)*FNUM
C
C	   STORE FUNCTION VALUE
10	P(IPQ)=F
C
C	   NORMAL RETURN
	IER(1)=0
	RETURN
	END
	FUNCTION FUN(X,Y)
C
	FUN=1./X
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GAUSS
C
C	   PURPOSE
C	      COMPUTES A NORMALLY DISTRIBUTED RANDOM NUMBER WITH A GIVEN
C	      MEAN AND STANDARD DEVIATION
C
C	   USAGE
C	      CALL GAUSS(IX,S,AM,V)
C
C	   DESCRIPTION OF PARAMETERS
C	      IX -IX MUST CONTAIN AN ODD INTEGER NUMBER WITH NINE OR
C	          LESS DIGITS ON THE FIRST ENTRY TO GAUSS. THEREAFTER
C	          IT WILL CONTAIN A UNIFORMLY DISTRIBUTED INTEGER RANDOM
C	          NUMBER GENERATED BY THE SUBROUTINE FOR USE ON THE NEXT
C	          ENTRY TO THE SUBROUTINE.
C	      S  -THE DESIRED STANDARD DEVIATION OF THE NORMAL
C	          DISTRIBUTION.
C	      AM -THE DESIRED MEAN OF THE NORMAL DISTRIBUTION
C	      V  -THE VALUE OF THE COMPUTED NORMAL RANDOM VARIABLE
C
C	   REMARKS
C	      THIS SUBROUTINE USES RANDU WHICH IS MACHINE SPECIFIC
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANDU
C
C	   METHOD
C	      USES 12 UNIFORM RANDOM NUMBERS TO COMPUTE NORMAL RANDOM
C	      NUMBERS BY CENTRAL LIMIT THEOREM. THE RESULT IS THEN
C	      ADJUSTED TO MATCH THE GIVEN MEAN AND STANDARD DEVIATION.
C	      THE UNIFORM RANDOM NUMBERS COMPUTED WITHIN THE SUBROUTINE
C	      ARE FOUND BY THE POWER RESIDUE METHOD.
C
C	..................................................................
C
	SUBROUTINE GAUSS(IX,S,AM,V)
	A=0.0
	DO 50 I=1,12
	CALL RANDU(IX,IY,Y)
	IX=IY
50	A=A+Y
	V=(A-6.0)*S+AM
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GDATA
C
C	   PURPOSE
C	      GENERATE INDEPENDENT VARIABLES UP TO THE M-TH POWER (THE
C	      HIGHEST DEGREE POLYNOMIAL SPECIFIED) AND COMPUTE MEANS,
C	      STANDARD DEVIATIONS, AND CORRELATION COEFFICIENTS.  THIS
C	      SUBROUTINE IS NORMALLY CALLED BEFORE SUBROUTINES ORDER,
C	      MINV AND MULTR IN THE PERFORMANCE OF A POLYNOMIAL
C	      REGRESSION.
C
C	   USAGE
C	      CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ)
C
C	   DESCRIPTION OF PARAMETERS
C	      N     - NUMBER OF OBSERVATIONS.
C	      M     - THE HIGHEST DEGREE POLYNOMIAL TO BE FITTED.
C	      X     - INPUT MATRIX (N BY M+1) .  WHEN THE SUBROUTINE IS
C	              CALLED, DATA FOR THE INDEPENDENT VARIABLE ARE
C	              STORED IN THE FIRST COLUMN OF MATRIX X, AND DATA FOR
C	              THE DEPENDENT VARIABLE ARE STORED IN THE LAST
C	              COLUMN OF THE MATRIX.  UPON RETURNING TO THE
C	              CALLING ROUTINE, GENERATED POWERS OF THE INDEPENDENT
C	              VARIABLE ARE STORED IN COLUMNS 2 THROUGH M.
C	      XBAR  - OUTPUT VECTOR OF LENGTH M+1 CONTAINING MEANS OF
C	              INDEPENDENT AND DEPENDENT VARIABLES.
C	      STD   - OUTPUT VECTOR OF LENGTH M+1 CONTAINING STANDARD
C	              DEVIATIONS OF INDEPENDENT AND DEPENDENT VARIABLES.
C	      D     - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
C	              SYMMETRIC MATRIX OF M+1 BY M+1) CONTAINING CORRELA-
C	              TION COEFFICIENTS.  (STORAGE MODE OF 1)
C	      SUMSQ - OUTPUT VECTOR OF LENGTH M+1 CONTAINING SUMS OF
C	              PRODUCTS OF DEVIATIONS FROM MEANS  OF INDEPENDENT
C	              AND DEPENDENT VARIABLES.
C
C	   REMARKS
C	      N MUST BE GREATER THAN M+1.
C	      IF M IS EQUAL TO 5 OR GREATER, SINGLE PRECISION MAY NOT BE
C	      SUFFICIENT TO GIVE SATISFACTORY COMPUTATIONAL RESULTS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO B. OSTLE, 'STATISTICS IN RESEARCH', THE IOWA STATE
C	      COLLEGE PRESS, 1954, CHAPTER 6.
C
C	..................................................................
C
	SUBROUTINE GDATA (N,M,X,XBAR,STD,D,SUMSQ)
	DIMENSION X(1),XBAR(1),STD(1),D(1),SUMSQ(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION X,XBAR,STD,D,SUMSQ,T1,T2
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
C	   STATEMENT 180 MUST BE CHANGED TO DSQRT AND DABS.
C
C	   ...............................................................
C
C	GENERATE INDEPENDENT VARIABLES
C
	IF(M-1) 105, 105, 90
90	L1=0
	DO 100 I=2,M
	L1=L1+N
	DO 100 J=1,N
	L=L1+J
	K=L-N
100	X(L)=X(K)*X(J)
C
C	CALCULATE MEANS
C
105	MM=M+1
	DF=N
	L=0
	DO 115 I=1,MM
	XBAR(I)=0.0
	DO 110 J=1,N
	L=L+1
110	XBAR(I)=XBAR(I)+X(L)
115	XBAR(I)=XBAR(I)/DF
C
	DO 130 I=1,MM
130	STD(I)=0.0
C
C	CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C
	L=((MM+1)*MM)/2
	DO 150 I=1,L
150	D(I)=0.0
	DO 170 K=1,N
	L=0
	DO 170 J=1,MM
	L2=N*(J-1)+K
	T2=X(L2)-XBAR(J)
	STD(J)=STD(J)+T2
	DO 170 I=1,J
	L1=N*(I-1)+K
	T1=X(L1)-XBAR(I)
	L=L+1
170	D(L)=D(L)+T1*T2
	L=0
	DO 175 J=1,MM
	DO 175 I=1,J
	L=L+1
175	D(L)=D(L)-STD(I)*STD(J)/DF
	L=0
	DO 180 I=1,MM
	L=L+I
	SUMSQ(I)=D(L)
180	STD(I)= SQRT( ABS(D(L)))
C
C	CALCULATE CORRELATION COEFFICIENTS
C
	L=0
	DO 190 J=1,MM
	DO 190 I=1,J
	L=L+1
190	D(L)=D(L)/(STD(I)*STD(J))
C
C	CALCULATE STANDARD DEVIATIONS
C
	DF=SQRT(DF-1.0)
	DO 200 I=1,MM
200	STD(I)=STD(I)/DF
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GELB
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A
C	      COEFFICIENT MATRIX OF BAND STRUCTURE.
C
C	   USAGE
C	      CALL GELB(R,A,M,N,MUD,MLD,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - M BY N RIGHT HAND SIDE MATRIX (DESTROYED).
C	               ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
C	      A      - M BY M COEFFICIENT MATRIX WITH BAND STRUCTURE
C	               (DESTROYED).
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      MUD    - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS
C	               CODIAGONALS ABOVE MAIN DIAGONAL).
C	      MLD    - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS
C	               CODIAGONALS BELOW MAIN DIAGONAL).
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
C	               TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
C	                        TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT
C	                        AT ANY ELIMINATION STEP EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
C
C	   REMARKS
C	      BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST
C	      ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA
C	      STORAGE LOCATIONS, WHERE
C	        MA=M*MC-ML*(ML+1)/2    AND    ME=MA-MU*(MU+1)/2    WITH
C	        MC=MIN(M,1+MUD+MLD),  ML=MC-1-MLD,  MU=MC-1-MUD.
C	      RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
C	      IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION
C	      MATRIX R IS STORED COLUMNWISE TOO.
C	      INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING
C	      RESTRICTIONS     MUD NOT LESS THAN ZERO
C	                       MLD NOT LESS THAN ZERO
C	                       MUD+MLD NOT GREATER THAN 2*M-2.
C	      NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
C	      RESTRICTIONS ARE NOT SATISFIED.
C	      THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
C	      PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL
C	      ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING
C	      IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE.
C	      IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE
C	      EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K.
C	      NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH
C	      COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE
C	      IN REMAINING COEFFICIENT MATRICES.
C
C	..................................................................
C
	SUBROUTINE GELB(R,A,M,N,MUD,MLD,EPS,IER)
C
C
	DIMENSION R(1),A(1)
C
C	TEST ON WRONG INPUT PARAMETERS
	IF(MLD)47,1,1
1	IF(MUD)47,2,2
2	MC=1+MLD+MUD
	IF(MC+1-M-M)3,3,47
C
C	PREPARE INTEGER PARAMETERS
C	   MC=NUMBER OF COLUMNS IN MATRIX A
C	   MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A
C	   ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A
C	   MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS
C	   MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A
C	   MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A
C	   NM=NUMBER OF ELEMENTS IN MATRIX R
3	IF(MC-M)5,5,4
4	MC=M
5	MU=MC-MUD-1
	ML=MC-MLD-1
	MR=M-ML
	MZ=(MU*(MU+1))/2
	MA=M*MC-(ML*(ML+1))/2
	NM=N*M
C
C	MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT
C	(NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS)
	IER=0
	PIV=0.
	IF(MLD)14,14,6
6	JJ=MA
	J=MA-MZ
	KST=J
	DO 9 K=1,KST
	TB=A(J)
	A(JJ)=TB
	TB=ABS(TB)
	IF(TB-PIV)8,8,7
7	PIV=TB
8	J=J-1
9	JJ=JJ-1
C
C	INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0)
	IF(MZ)14,14,10
10	JJ=1
	J=1+MZ
	IC=1+MUD
	DO 13 I=1,MU
	DO 12 K=1,MC
	A(JJ)=0.
	IF(K-IC)11,11,12
11	A(JJ)=A(J)
	J=J+1
12	JJ=JJ+1
13	IC=IC+1
C
C	GENERATE TEST VALUE FOR SINGULARITY
14	TOL=EPS*PIV
C
C
C	START DECOMPOSITION LOOP
	KST=1
	IDST=MC
	IC=MC-1
	DO 38 K=1,M
	IF(K-MR-1)16,16,15
15	IDST=IDST-1
16	ID=IDST
	ILR=K+MLD
	IF(ILR-M)18,18,17
17	ILR=M
18	II=KST
C
C	PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR)
	PIV=0.
	DO 22 I=K,ILR
	TB=ABS(A(II))
	IF(TB-PIV)20,20,19
19	PIV=TB
	J=I
	JJ=II
20	IF(I-MR)22,22,21
21	ID=ID-1
22	II=II+ID
C
C	TEST ON SINGULARITY
	IF(PIV)47,47,23
23	IF(IER)26,24,26
24	IF(PIV-TOL)25,25,26
25	IER=K-1
26	PIV=1./A(JJ)
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	ID=J-K
	DO 27 I=K,NM,M
	II=I+ID
	TB=PIV*R(II)
	R(II)=R(I)
27	R(I)=TB
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A
	II=KST
	J=JJ+IC
	DO 28 I=JJ,J
	TB=PIV*A(I)
	A(I)=A(II)
	A(II)=TB
28	II=II+1
C
C	ELEMENT REDUCTION
	IF(K-ILR)29,34,34
29	ID=KST
	II=K+1
	MU=KST+1
	MZ=KST+IC
	DO 33 I=II,ILR
C
C	IN MATRIX A
	ID=ID+MC
	JJ=I-MR-1
	IF(JJ)31,31,30
30	ID=ID-JJ
31	PIV=-A(ID)
	J=ID+1
	DO 32 JJ=MU,MZ
	A(J-1)=A(J)+PIV*A(JJ)
32	J=J+1
	A(J-1)=0.
C
C	IN MATRIX R
	J=K
	DO 33 JJ=I,NM,M
	R(JJ)=R(JJ)+PIV*R(J)
33	J=J+M
34	KST=KST+MC
	IF(ILR-MR)36,35,35
35	IC=IC-1
36	ID=K-MR
	IF(ID)38,38,37
37	KST=KST-ID
38	CONTINUE
C	END OF DECOMPOSITION LOOP
C
C
C	BACK SUBSTITUTION
	IF(MC-1)46,46,39
39	IC=2
	KST=MA+ML-MC+2
	II=M
	DO 45 I=2,M
	KST=KST-MC
	II=II-1
	J=II-MR
	IF(J)41,41,40
40	KST=KST+J
41	DO 43 J=II,NM,M
	TB=R(J)
	MZ=KST+IC-2
	ID=J
	DO 42 JJ=KST,MZ
	ID=ID+1
42	TB=TB-A(JJ)*R(ID)
43	R(J)=TB
	IF(IC-MC)44,45,45
44	IC=IC+1
45	CONTINUE
46	RETURN
C
C
C	ERROR RETURN
47	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GELG
C
C	   PURPOSE
C	      TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS.
C
C	   USAGE
C	      CALL GELG(R,A,M,N,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - THE M BY N MATRIX OF RIGHT HAND SIDES.  (DESTROYED)
C	               ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
C	      A      - THE M BY M COEFFICIENT MATRIX.  (DESTROYED)
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
C	               TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C	                        PIVOT ELEMENT AT ANY ELIMINATION STEP
C	                        EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
C
C	   REMARKS
C	      INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE
C	      IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN
C	      SOLUTION MATRIX R IS STORED COLUMNWISE TOO.
C	      THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C	      GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C	      ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C	      INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C	      SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C	      INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C	      GIVEN IN CASE M=1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C	      COMPLETE PIVOTING.
C
C	..................................................................
C
	SUBROUTINE GELG(R,A,M,N,EPS,IER)
C
C
	DIMENSION A(1),R(1)
	IF(M)23,23,1
C
C	SEARCH FOR GREATEST ELEMENT IN MATRIX A
1	IER=0
	PIV=0.
	MM=M*M
	NM=N*M
	DO 3 L=1,MM
	TB=ABS(A(L))
	IF(TB-PIV)3,3,2
2	PIV=TB
	I=L
3	CONTINUE
	TOL=EPS*PIV
C	A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C	START ELIMINATION LOOP
	LST=1
	DO 17 K=1,M
C
C	TEST ON SINGULARITY
	IF(PIV)23,23,4
4	IF(IER)7,5,7
5	IF(PIV-TOL)6,6,7
6	IER=K-1
7	PIVI=1./A(I)
	J=(I-1)/M
	I=I-J*M-K
	J=J+1-K
C	I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	DO 8 L=K,NM,M
	LL=L+I
	TB=PIVI*R(LL)
	R(LL)=R(L)
8	R(L)=TB
C
C	IS ELIMINATION TERMINATED
	IF(K-M)9,18,18
C
C	COLUMN INTERCHANGE IN MATRIX A
9	LEND=LST+M-K
	IF(J)12,12,10
10	II=J*M
	DO 11 L=LST,LEND
	TB=A(L)
	LL=L+II
	A(L)=A(LL)
11	A(LL)=TB
C
C	ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A
12	DO 13 L=LST,MM,M
	LL=L+I
	TB=PIVI*A(LL)
	A(LL)=A(L)
13	A(L)=TB
C
C	SAVE COLUMN INTERCHANGE INFORMATION
	A(LST)=J
C
C	ELEMENT REDUCTION AND NEXT PIVOT SEARCH
	PIV=0.
	LST=LST+1
	J=0
	DO 16 II=LST,LEND
	PIVI=-A(II)
	IST=II+M
	J=J+1
	DO 15 L=IST,MM,M
	LL=L-J
	A(L)=A(L)+PIVI*A(LL)
	TB=ABS(A(L))
	IF(TB-PIV)15,15,14
14	PIV=TB
	I=L
15	CONTINUE
	DO 16 L=K,NM,M
	LL=L+J
16	R(LL)=R(LL)+PIVI*R(L)
17	LST=LST+M
C	END OF ELIMINATION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
18	IF(M-1)23,22,19
19	IST=MM+M
	LST=M+1
	DO 21 I=2,M
	II=LST-I
	IST=IST-LST
	L=IST-M
	L=A(L)+.5
	DO 21 J=II,NM,M
	TB=R(J)
	LL=J
	DO 20 K=IST,MM,M
	LL=LL+1
20	TB=TB-A(K)*R(LL)
	K=J+L
	R(J)=R(K)
21	R(K)=TB
22	RETURN
C
C
C	ERROR RETURN
23	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GELS
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH
C	      SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH
C	      IS ASSUMED TO BE STORED COLUMNWISE.
C
C	   USAGE
C	      CALL GELS(R,A,M,N,EPS,IER,AUX)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - M BY N RIGHT HAND SIDE MATRIX.  (DESTROYED)
C	               ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS.
C	      A      - UPPER TRIANGULAR PART OF THE SYMMETRIC
C	               M BY M COEFFICIENT MATRIX.  (DESTROYED)
C	      M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C	      N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
C	               TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR,
C	               IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C	                        PIVOT ELEMENT AT ANY ELIMINATION STEP
C	                        EQUAL TO 0,
C	               IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                        CANCE INDICATED AT ELIMINATION STEP K+1,
C	                        WHERE PIVOT ELEMENT WAS LESS THAN OR
C	                        EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C	                        ABSOLUTELY GREATEST MAIN DIAGONAL
C	                        ELEMENT OF MATRIX A.
C	      AUX    - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1.
C
C	   REMARKS
C	      UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED
C	      COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT
C	      HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE
C	      LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE
C	      TOO.
C	      THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C	      GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C	      ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C	      INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C	      SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C	      INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C	      GIVEN IN CASE M=1.
C	      ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT
C	      MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS
C	      ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH
C	      WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C	      PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE
C	      SYMMETRY IN REMAINING COEFFICIENT MATRICES.
C
C	..................................................................
C
	SUBROUTINE GELS(R,A,M,N,EPS,IER,AUX)
C
C
	DIMENSION A(1),R(1),AUX(1)
	IF(M)24,24,1
C
C	SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT
1	IER=0
	PIV=0.
	L=0
	DO 3 K=1,M
	L=L+K
	TB=ABS(A(L))
	IF(TB-PIV)3,3,2
2	PIV=TB
	I=L
	J=K
3	CONTINUE
	TOL=EPS*PIV
C	MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT.
C	PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C	START ELIMINATION LOOP
	LST=0
	NM=N*M
	LEND=M-1
	DO 18 K=1,M
C
C	TEST ON USEFULNESS OF SYMMETRIC ALGORITHM
	IF(PIV)24,24,4
4	IF(IER)7,5,7
5	IF(PIV-TOL)6,6,7
6	IER=K-1
7	LT=J-K
	LST=LST+K
C
C	PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
	PIVI=1./A(I)
	DO 8 L=K,NM,M
	LL=L+LT
	TB=PIVI*R(LL)
	R(LL)=R(L)
8	R(L)=TB
C
C	IS ELIMINATION TERMINATED
	IF(K-M)9,19,19
C
C	ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A.
C	ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX.
9	LR=LST+(LT*(K+J-1))/2
	LL=LR
	L=LST
	DO 14 II=K,LEND
	L=L+II
	LL=LL+1
	IF(L-LR)12,10,11
10	A(LL)=A(LST)
	TB=A(L)
	GO TO 13
11	LL=L+LT
12	TB=A(LL)
	A(LL)=A(L)
13	AUX(II)=TB
14	A(L)=PIVI*TB
C
C	SAVE COLUMN INTERCHANGE INFORMATION
	A(LST)=LT
C
C	ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT
	PIV=0.
	LLST=LST
	LT=0
	DO 18 II=K,LEND
	PIVI=-AUX(II)
	LL=LLST
	LT=LT+1
	DO 15 LLD=II,LEND
	LL=LL+LLD
	L=LL+LT
15	A(L)=A(L)+PIVI*A(LL)
	LLST=LLST+II
	LR=LLST+LT
	TB=ABS(A(LR))
	IF(TB-PIV)17,17,16
16	PIV=TB
	I=LR
	J=II+1
17	DO 18 LR=K,NM,M
	LL=LR+LT
18	R(LL)=R(LL)+PIVI*R(LR)
C	END OF ELIMINATION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
19	IF(LEND)24,23,20
20	II=M
	DO 22 I=2,M
	LST=LST-II
	II=II-1
	L=A(LST)+.5
	DO 22 J=II,NM,M
	TB=R(J)
	LL=J
	K=LST
	DO 21 LT=II,LEND
	LL=LL+1
	K=K+LT
21	TB=TB-A(K)*R(LL)
	K=J+L
	R(J)=R(K)
22	R(K)=TB
23	RETURN
C
C
C	ERROR RETURN
24	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GMADD
C
C	   PURPOSE
C	      ADD TWO GENERAL MATRICES TO FORM RESULTANT GENERAL MATRIX
C
C	   USAGE
C	      CALL GMADD(A,B,R,N,M)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A,B,R
C	      M - NUMBER OF COLUMNS IN A,B,R
C
C	   REMARKS
C	      ALL MATRICES MUST BE STORED AS GENERAL MATRICES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      ADDITION IS PERFORMED ELEMENT BY ELEMENT
C
C	..................................................................
C
	SUBROUTINE GMADD(A,B,R,N,M)
	DIMENSION A(1),B(1),R(1)
C
C	   CALCULATE NUMBER OF ELEMENTS
C
	NM=N*M
C
C	   ADD MATRICES
C
	DO 10 I=1,NM
10	R(I)=A(I)+B(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GMMMA
C
C	   PURPOSE
C	      COMPUTES THE GAMMA FUNCTION FOR A GIVEN ARGUMENT
C
C	   USAGE
C	      CALL GMMMA(XX,GX,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      XX -THE ARGUMENT FOR THE GAMMA FUNCTION
C	      GX -THE RESULTANT GAMMA FUNCTION VALUE
C	      IER-RESULTANT ERROR CODE WHERE
C	          IER=0  NO ERROR
C	          IER=1  XX IS WITHIN .000001 OF BEING A NEGATIVE INTEGER
C	          IER=2  XX GT 57, OVERFLOW, GX SET TO 1.0E75
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE RECURSION RELATION AND POLYNOMIAL APPROXIMATION
C	      BY C.HASTINGS,JR., 'APPROXIMATIONS FOR DIGITAL COMPUTERS',
C	      PRINCETON UNIVERSITY PRESS, 1955
C
C	..................................................................
C
	SUBROUTINE GMMMA(XX,GX,IER)
	IF(XX-57.)6,6,4
4	IER=2
	GX=1.7E38                                                                 0
	RETURN
6	X=XX
	ERR=1.0E-6
	IER=0
	GX=1.0
	IF(X-2.0)50,50,15
10	IF(X-2.0)110,110,15
15	X=X-1.0
	GX=GX*X
	GO TO 10
50	IF(X-1.0)60,120,110
C
C	   SEE IF X IS NEAR NEGATIVE INTEGER OR ZERO
C
60	IF(X-ERR)62,62,80
62	Y=FLOAT(INT(X))-X
	IF(ABS(Y)-ERR)130,130,64
64	IF(1.0-Y-ERR)130,130,70
C
C	   X NOT NEAR A NEGATIVE INTEGER OR ZERO
C
70	IF(X-1.0)80,80,110
80	GX=GX/X
	X=X+1.0
	GO TO 70
110	Y=X-1.0
	GY=1.0+Y*(-0.5771017+Y*(+0.9858540+Y*(-0.8764218+Y*(+0.8328212+
     1Y*(-0.5684729+Y*(+0.2548205+Y*(-0.05149930)))))))
	GX=GX*GY
120	RETURN
130	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GMPRD
C
C	   PURPOSE
C	      MULTIPLY TWO GENERAL MATRICES TO FORM A RESULTANT GENERAL
C	      MATRIX
C
C	   USAGE
C	      CALL GMPRD(A,B,R,N,M,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A
C	      M - NUMBER OF COLUMNS IN A AND ROWS IN B
C	      L - NUMBER OF COLUMNS IN B
C
C	   REMARKS
C	      ALL MATRICES MUST BE STORED AS GENERAL MATRICES
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B
C	      NUMBER OF COLUMNS OF MATRIX A MUST BE EQUAL TO NUMBER OF ROW
C	      OF MATRIX B
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE M BY L MATRIX B IS PREMULTIPLIED BY THE N BY M MATRIX A
C	      AND THE RESULT IS STORED IN THE N BY L MATRIX R.
C
C	..................................................................
C
	SUBROUTINE GMPRD(A,B,R,N,M,L)
	DIMENSION A(1),B(1),R(1)
C
	IR=0
	IK=-M
	DO 10 K=1,L
	IK=IK+M
	DO 10 J=1,N
	IR=IR+1
	JI=J-N
	IB=IK
	R(IR)=0
	DO 10 I=1,M
	JI=JI+N
	IB=IB+1
10	R(IR)=R(IR)+A(JI)*B(IB)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GMSUB
C
C	   PURPOSE
C	      SUBTRACT ONE GENERAL MATRIX FROM ANOTHER TO FORM RESULTANT
C	      MATRIX
C
C	   USAGE
C	      CALL GMSUB(A,B,R,N,M)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A,B,R
C	      M - NUMBER OF COLUMNS IN A,B,R
C
C	   REMARKS
C	      ALL MATRICES MUST BE STORED AS GENERAL MATRICES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      MATRIX B ELEMENTS ARE SUBTRACTED FROM CORRESPONDING MATRIX A
C	      ELEMENTS
C
C	..................................................................
C
	SUBROUTINE GMSUB(A,B,R,N,M)
	DIMENSION A(1),B(1),R(1)
C
C	   CALCULATE NUMBER OF ELEMENTS
C
	NM=N*M
C
C	   SUBTRACT MATRICES
C
	DO 10 I=1,NM
10	R(I)=A(I)-B(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GMTRA
C
C	   PURPOSE
C	      TRANSPOSE A GENERAL MATRIX
C
C	   USAGE
C	      CALL GMTRA(A,R,N,M)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF MATRIX TO BE TRANSPOSED
C	      R - NAME OF RESULTANT MATRIX
C	      N - NUMBER OF ROWS OF A AND COLUMNS OF R
C	      M - NUMBER OF COLUMNS OF A AND ROWS OF R
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRICES A AND R MUST BE STORED AS GENERAL MATRICES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      TRANSPOSE N BY M MATRIX A TO FORM M BY N MATRIX R
C
C	..................................................................
C
	SUBROUTINE GMTRA(A,R,N,M)
	DIMENSION A(1),R(1)
C
	IR=0
	DO 10 I=1,N
	IJ=I-N
	DO 10 J=1,M
	IJ=IJ+N
	IR=IR+1
10	R(IR)=A(IJ)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE GTPRD
C
C	   PURPOSE
C	      PREMULTIPLY A GENERAL MATRIX BY THE TRANSPOSE OF ANOTHER
C	      GENERAL MATRIX
C
C	   USAGE
C	      CALL GTPRD(A,B,R,N,M,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A AND B
C	      M - NUMBER OF COLUMNS IN A AND ROWS IN R
C	      L - NUMBER OF COLUMNS IN B AND R
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B
C	      ALL MATRICES MUST BE STORED AS GENERAL MATRICES
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      MATRIX TRANSPOSE OF A IS NOT ACTUALLY CALCULATED. INSTEAD,
C	      ELEMENTS OF MATRIX A ARE TAKEN COLUMNWISE RATHER THAN
C	      ROWWISE FOR POSTMULTIPLICATION BY MATRIX B.
C
C	..................................................................
C
	SUBROUTINE GTPRD(A,B,R,N,M,L)
	DIMENSION A(1),B(1),R(1)
C
	IR=0
	IK=-N
	DO 10 K=1,L
	IJ=0
	IK=IK+N
	DO 10 J=1,M
	IB=IK
	IR=IR+1
	R(IR)=0
	DO 10 I=1,N
	IJ=IJ+1
	IB=IB+1
10	R(IR)=R(IR)+A(IJ)*B(IB)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE HARM
C
C	   PURPOSE
C	      PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX
C	      THREE DIMENSIONAL ARRAY
C
C	   USAGE
C	      CALL HARM (A,M,INV,S,IFSET,IFERR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL
C	              ARRAY TO BE TRANSFORMED.  THE REAL PART OF
C	              A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL
C	              WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE
C	              NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC.
C	              THE IMAGINARY PART IS IN THE CELL IMMEDIATELY
C	              FOLLOWING.  NOTE THAT THE SUBSCRIPT I1 INCREASES
C	              MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY.
C	              AS OUTPUT, A CONTAINS THE COMPLEX FOURIER
C	              TRANSFORM.  THE NUMBER OF CORE LOCATIONS OF
C	              ARRAY A IS 2*(N1*N2*N3)
C	      M     - A THREE CELL VECTOR WHICH DETERMINES THE SIZES
C	              OF THE 3 DIMENSIONS OF THE ARRAY A.   THE SIZE,
C	              NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3
C	      INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION
C	              OF DIMENSION ONE FOURTH OF THE QUANTITY
C	              MAX(N1,N2,N3)
C	      S     - A VECTOR WORK AREA FOR SINE TABLES WITH DIMENSION
C	              THE SAME AS INV
C	      IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS
C	                 0    SET UP SINE AND INV TABLES ONLY
C	                 1    SET UP SINE AND INV TABLES ONLY AND
C	                      CALCULATE FOURIER TRANSFORM
C	                -1    SET UP SINE AND INV TABLES ONLY AND
C	                      CALCULATE INVERSE FOURIER TRANSFORM (FOR
C	                      THE MEANING OF INVERSE SEE THE EQUATIONS
C	                      UNDER METHOD BELOW)
C	                 2    CALCULATE FOURIER TRANSFORM ONLY (ASSUME
C	                      SINE AND INV TABLES EXIST)
C	                -2    CALCULATE INVERSE FOURIER TRANSFORM ONLY
C	                      (ASSUME SINE AND INV TABLES EXIST)
C	      IFERR - ERROR INDICATOR.   WHEN IFSET IS 0,+1,-1,
C	              IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN
C	             20 , I=1,2,3   WHEN IFSET IS 2,-2 , IFERR = 1
C	              MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE
C	              ENOUGH OR HAVE NOT BEEN COMPUTED .
C	              IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE
C	              CONDITIONS ARE PRESENT
C
C	   REMARKS
C	      THIS SUBROUTINE IS TO BE USED FOR COMPLEX, 3-DIMENSIONAL
C	      ARRAYS IN WHICH EACH DIMENSION IS A POWER OF 2.  THE
C	      MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN 20,
C	      I = 1,2,3
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX
C	      ARRAY A IS OBTAINED.
C
C	             N1-1   N2-1   N3-1                L1   L2   L3
C	X(J1,J2,J3)=SUM    SUM    SUM    A(K1,K2,K3)*W1  *W2  *W3
C	             K1=0   K2=0   K3=0
C
C	             WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1,
C	                   L2=K2*J2, L3=K3*J3
C
C
C	      FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF
C	      COMPLEX ARRAY X IS OBTAINED.
C
C	A(K1,K2,K3)=
C	          1      N1-1   N2-1   N3-1                -L1  -L2  -L3
C	      -------- *SUM    SUM    SUM    X(J1,J2,J3)*W1  *W2  *W3
C	      N1*N2*N3   J1=0   J2=0   J3=0
C
C
C	      SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE
C	      MACHINE CALCULATION OF COMPLEX FOURIER SERIES',
C	      MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297.
C
C	..................................................................
C
	SUBROUTINE HARM(A,M,INV,S,IFSET, IFERR)
	DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2)
	EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3)
10	IF( IABS(IFSET) - 1) 900,900,12
12	MTT=MAX0(M(1),M(2),M(3)) -2
	ROOT2 = SQRT(2.)
	IF (MTT-MT ) 14,14,13
13	IFERR=1
	RETURN
14	IFERR=0
	M1=M(1)
	M2=M(2)
	M3=M(3)
	N1=2**M1
	N2=2**M2
	N3=2**M3
16	IF(IFSET) 18,18,20
18	NX= N1*N2*N3
	FN = NX
	DO 19 I = 1,NX
	A(2*I-1) = A(2*I-1)/FN
19	A(2*I) = -A(2*I)/FN
20	NP(1)=N1*2
	NP(2)= NP(1)*N2
	NP(3)=NP(2)*N3
	DO 250 ID=1,3
	IL = NP(3)-NP(ID)
	IL1 = IL+1
	MI = M(ID)
	IF (MI)250,250,30
30	IDIF=NP(ID)
	KBIT=NP(ID)
	MEV = 2*(MI/2)
	IF (MI - MEV )60,60,40
C
C	M IS ODD. DO L=1 CASE
40	KBIT=KBIT/2
	KL=KBIT-2
	DO 50 I=1,IL1,IDIF
	KLAST=KL+I
	DO 50 K=I,KLAST,2
	KD=K+KBIT
C
C	DO ONE STEP WITH L=1,J=0
C	A(K)=A(K)+A(KD)
C	A(KD)=A(K)-A(KD)
C
	T=A(KD)
	A(KD)=A(K)-T
	A(K)=A(K)+T
	T=A(KD+1)
	A(KD+1)=A(K+1)-T
50	A(K+1)=A(K+1)+T
	IF (MI - 1)250,250,52
52	LFIRST =3
C
C	DEF - JLAST = 2**(L-2) -1
	JLAST=1
	GO TO 70
C
C	M IS EVEN
60	LFIRST = 2
	JLAST=0
70	DO 240 L=LFIRST,MI,2
	JJDIF=KBIT
	KBIT=KBIT/4
	KL=KBIT-2
C
C	DO FOR J=0
	DO 80 I=1,IL1,IDIF
	KLAST=I+KL
	DO 80 K=I,KLAST,2
	K1=K+KBIT
	K2=K1+KBIT
	K3=K2+KBIT
C
C	DO TWO STEPS WITH J=0
C	A(K)=A(K)+A(K2)
C	A(K2)=A(K)-A(K2)
C	A(K1)=A(K1)+A(K3)
C	A(K3)=A(K1)-A(K3)
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	T=A(K2)
	A(K2)=A(K)-T
	A(K)=A(K)+T
	T=A(K2+1)
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	T=A(K3)
	A(K3)=A(K1)-T
	A(K1)=A(K1)+T
	T=A(K3+1)
	A(K3+1)=A(K1+1)-T
	A(K1+1)=A(K1+1)+T
C
	T=A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	R=-A(K3+1)
	T = A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
80	A(K2+1)=A(K2+1)+T
	IF (JLAST) 235,235,82
82	JJ=JJDIF   +1
C
C	DO FOR J=1
	ILAST= IL +JJ
	DO 85 I = JJ,ILAST,IDIF
	KLAST = KL+I
	DO 85 K=I,KLAST,2
	K1 = K+KBIT
	K2 = K1+KBIT
	K3 = K2+KBIT
C
C	LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I,
C	A(K)=A(K)+A(K2)*I
C	A(K2)=A(K)-A(K2)*I
C	A(K1)=A(K1)*W+A(K3)*W3
C	A(K3)=A(K1)*W-A(K3)*W3
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	R =-A(K2+1)
	T = A(K2)
	A(K2) = A(K)-R
	A(K) = A(K)+R
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	AWR=A(K1)-A(K1+1)
	AWI = A(K1+1)+A(K1)
	R=-A(K3)-A(K3+1)
	T=A(K3)-A(K3+1)
	A(K3)=(AWR-R)/ROOT2
	A(K3+1)=(AWI-T)/ROOT2
	A(K1)=(AWR+R)/ROOT2
	A(K1+1)=(AWI+T)/ROOT2
	T= A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
	R=-A(K3+1)
	T=A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
85	A(K2+1)=A(K2+1)+T
	IF(JLAST-1) 235,235,90
90	JJ= JJ + JJDIF
C
C	NOW DO THE REMAINING J'S
	DO 230 J=2,JLAST
C
C	FETCH W'S
C	DEF- W=W**INV(J), W2=W**2, W3=W**3
96	I=INV(J+1)
98	IC=NT-I
	W(1)=S(IC)
	W(2)=S(I)
	I2=2*I
	I2C=NT-I2
	IF(I2C)120,110,100
C
C	2*I IS IN FIRST QUADRANT
100	W2(1)=S(I2C)
	W2(2)=S(I2)
	GO TO 130
110	W2(1)=0.
	W2(2)=1.
	GO TO 130
C
C	2*I IS IN SECOND QUADRANT
120	I2CC = I2C+NT
	I2C=-I2C
	W2(1)=-S(I2C)
	W2(2)=S(I2CC)
130	I3=I+I2
	I3C=NT-I3
	IF(I3C)160,150,140
C
C	I3 IN FIRST QUADRANT
140	W3(1)=S(I3C)
	W3(2)=S(I3)
	GO TO 200
150	W3(1)=0.
	W3(2)=1.
	GO TO 200
C
160	I3CC=I3C+NT
	IF(I3CC)190,180,170
C
C	I3 IN SECOND QUADRANT
170	I3C=-I3C
	W3(1)=-S(I3C)
	W3(2)=S(I3CC)
	GO TO 200
180	W3(1)=-1.
	W3(2)=0.
	GO TO 200
C
C	3*I IN THIRD QUADRANT
190	I3CCC=NT+I3CC
	I3CC = -I3CC
	W3(1)=-S(I3CCC)
	W3(2)=-S(I3CC)
200	ILAST=IL+JJ
	DO 220 I=JJ,ILAST,IDIF
	KLAST=KL+I
	DO 220 K=I,KLAST,2
	K1=K+KBIT
	K2=K1+KBIT
	K3=K2+KBIT
C
C	DO TWO STEPS WITH J NOT 0
C	A(K)=A(K)+A(K2)*W2
C	A(K2)=A(K)-A(K2)*W2
C	A(K1)=A(K1)*W+A(K3)*W3
C	A(K3)=A(K1)*W-A(K3)*W3
C
C	A(K)=A(K)+A(K1)
C	A(K1)=A(K)-A(K1)
C	A(K2)=A(K2)+A(K3)*I
C	A(K3)=A(K2)-A(K3)*I
C
	R=A(K2)*W2(1)-A(K2+1)*W2(2)
	T=A(K2)*W2(2)+A(K2+1)*W2(1)
	A(K2)=A(K)-R
	A(K)=A(K)+R
	A(K2+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
C
	R=A(K3)*W3(1)-A(K3+1)*W3(2)
	T=A(K3)*W3(2)+A(K3+1)*W3(1)
	AWR=A(K1)*W(1)-A(K1+1)*W(2)
	AWI=A(K1)*W(2)+A(K1+1)*W(1)
	A(K3)=AWR-R
	A(K3+1)=AWI-T
	A(K1)=AWR+R
	A(K1+1)=AWI+T
	T=A(K1)
	A(K1)=A(K)-T
	A(K)=A(K)+T
	T=A(K1+1)
	A(K1+1)=A(K+1)-T
	A(K+1)=A(K+1)+T
	R=-A(K3+1)
	T=A(K3)
	A(K3)=A(K2)-R
	A(K2)=A(K2)+R
	A(K3+1)=A(K2+1)-T
220	A(K2+1)=A(K2+1)+T
C	END OF I AND K LOOPS
C
230	JJ=JJDIF+JJ
C	END OF J-LOOP
C
235	JLAST=4*JLAST+3
240	CONTINUE
C	END OF  L  LOOP
C
250	CONTINUE
C	END OF  ID  LOOP
C
C	WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE
C	BIT-REVERSED.  THE FOLLOWING ROUTINE PUTS THEM IN ORDER
	NTSQ=NT*NT
	M3MT=M3-MT
350	IF(M3MT) 370,360,360
C
C	M3 GR. OR EQ. MT
360	IGO3=1
	N3VNT=N3/NT
	MINN3=NT
	GO TO 380
C
C	M3 LESS THAN MT
370	IGO3=2
	N3VNT=1
	NTVN3=NT/N3
	MINN3=N3
380	JJD3 = NTSQ/N3
	M2MT=M2-MT
450	IF (M2MT)470,460,460
C
C	M2 GR. OR EQ. MT
460	IGO2=1
	N2VNT=N2/NT
	MINN2=NT
	GO TO 480
C
C	M2 LESS THAN MT
470	IGO2 = 2
	N2VNT=1
	NTVN2=NT/N2
	MINN2=N2
480	JJD2=NTSQ/N2
	M1MT=M1-MT
550	IF(M1MT)570,560,560
C
C	M1 GR. OR EQ. MT
560	IGO1=1
	N1VNT=N1/NT
	MINN1=NT
	GO TO 580
C
C	M1 LESS THAN MT
570	IGO1=2
	N1VNT=1
	NTVN1=NT/N1
	MINN1=N1
580	JJD1=NTSQ/N1
600	JJ3=1
	J=1
	DO 880 JPP3=1,N3VNT
	IPP3=INV(JJ3)
	DO 870 JP3=1,MINN3
	GO TO (610,620),IGO3
610	IP3=INV(JP3)*N3VNT
	GO TO 630
620	IP3=INV(JP3)/NTVN3
630	I3=(IPP3+IP3)*N2
700	JJ2=1
	DO 870 JPP2=1,N2VNT
	IPP2=INV(JJ2)+I3
	DO 860 JP2=1,MINN2
	GO TO (710,720),IGO2
710	IP2=INV(JP2)*N2VNT
	GO TO 730
720	IP2=INV(JP2)/NTVN2
730	I2=(IPP2+IP2)*N1
800	JJ1=1
	DO 860 JPP1=1,N1VNT
	IPP1=INV(JJ1)+I2
	DO 850 JP1=1,MINN1
	GO TO (810,820),IGO1
810	IP1=INV(JP1)*N1VNT
	GO TO 830
820	IP1=INV(JP1)/NTVN1
830	I=2*(IPP1+IP1)+1
	IF (J-I) 840,850,850
840	T=A(I)
	A(I)=A(J)
	A(J)=T
	T=A(I+1)
	A(I+1)=A(J+1)
	A(J+1)=T
850	J=J+2
860	JJ1=JJ1+JJD1
C	END OF JPP1 AND JP2
C
870	JJ2=JJ2+JJD2
C	END OF JPP2 AND JP3 LOOPS
C
880	JJ3 = JJ3+JJD3
C	END OF JPP3 LOOP
C
890	IF(IFSET)891,895,895
891	DO 892 I = 1,NX
892	A(2*I) = -A(2*I)
895	RETURN
C
C	THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES.
C
900	MT=MAX0(M(1),M(2),M(3)) -2
	MT = MAX0(2,MT)
904	IF (MT-18) 906,906,13
906	IFERR=0
	NT=2**MT
	NTV2=NT/2
C
C	SET UP SIN TABLE
C	THETA=PIE/2**(L+1) FOR L=1
910	THETA=.7853981634
C
C	JSTEP=2**(MT-L+1) FOR L=1
	JSTEP=NT
C
C	JDIF=2**(MT-L) FOR L=1
	JDIF=NTV2
	S(JDIF)=SIN(THETA)
	DO 950 L=2,MT
	THETA=THETA/2.
	JSTEP2=JSTEP
	JSTEP=JDIF
	JDIF=JSTEP/2
	S(JDIF)=SIN(THETA)
	JC1=NT-JDIF
	S(JC1)=COS(THETA)
	JLAST=NT-JSTEP2
	IF(JLAST - JSTEP) 950,920,920
920	DO 940 J=JSTEP,JLAST,JSTEP
	JC=NT-J
	JD=J+JDIF
940	S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC)
950	CONTINUE
C
C	SET UP INV(J) TABLE
C
960	MTLEXP=NTV2
C
C	MTLEXP=2**(MT-L). FOR L=1
	LM1EXP=1
C
C	LM1EXP=2**(L-1). FOR L=1
	INV(1)=0
	DO 980 L=1,MT
	INV(LM1EXP+1) = MTLEXP
	DO 970 J=2,LM1EXP
	JJ=J+LM1EXP
970	INV(JJ)=INV(J)+MTLEXP
	MTLEXP=MTLEXP/2
980	LM1EXP=LM1EXP*2
982	IF(IFSET)12,895,12
	END
C
C	..................................................................
C
C	   SUBROUTINE HEP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL HEP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF HERMITE POLYNOMIAL
C	      N     - ORDER OF HERMITE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      HERMITE POLYNOMIALS H(N,X)
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X))
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X.
C
C	..................................................................
C
	SUBROUTINE HEP(Y,X,N)
C
	DIMENSION Y(1)
C
C	   TEST OF ORDER
	Y(1)=1.
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X+X
	IF(N-1)1,1,3
C
3	DO 4 I=2,N
	F=X*Y(I)-FLOAT(I-1)*Y(I-1)
4	Y(I+1)=F+F
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE HEPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL HEPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	      X     - ARGUMENT VALUE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)).
C
C	..................................................................
C
	SUBROUTINE HEPS(Y,X,C,N)
C
	DIMENSION C(1)
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.
	H1=X+X
C
	DO 4 I=2,N
	H2=X*H1-FLOAT(I-1)*H0
	H0=H1
	H1=H2+H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE HIST
C
C	   PURPOSE
C	      PRINT A HISTOGRAM OF FREQUENCIES VERSUS INTERVALS
C
C	   USAGE
C	      CALL HIST(NU,FREQ,IN)
C
C	   DESCRIPTION OF PARAMETERS
C	      NU   - HISTOGRAM NUMBER (3 DIGITS MAXIMUM)
C	      FREQ - VECTOR OF FREQUENCIES
C	      IN   - NUMBER OF INTERVALS AND LENGTH OF FREQ (MAX IS 20)
C	             NORMALLY, FREQ(1) CONTAINS THE FREQUENCY SMALLER THAN
C	             THE LOWER BOUND AND FREQ(IN) CONTAINS THE FREQUENCY
C	             LARGER THAN THE UPPER BOUND
C
C	   REMARKS
C	      FREQUENCIES MUST BE POSITIVE NUMBERS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE LARGEST FREQUENCY IS DETERMINED AND SCALING IS USED
C	      IF REQUIRED
C
C	..................................................................
C
	SUBROUTINE HIST(NU,FREQ,IN)
	DIMENSION JOUT(20),FREQ(20)
C
1	FORMAT(6H EACH ,A1,8H EQUALS ,I2,7H POINTS,/)
2	FORMAT(I6,4X,20(4X,A1))
3	FORMAT(9H0INTERVAL,4X,19(I2,3X),I2)
4	FORMAT(1H1,47X,11H HISTOGRAM ,I3)
5	FORMAT(10H0FREQUENCY,20I5)
6	FORMAT(6H CLASS)
7	FORMAT(113H   ----------------------------------------------------
     1----------------------------------------------------------)
8	FORMAT(1H )
9	FORMAT(A1)
10	FORMAT(1H*)
C
	REWIND 13
	WRITE(13,10)
	REWIND 13
	READ(13,9) K
	REWIND 13
	WRITE(13,8)
	REWIND 13
	READ(13,9) NOTH
	REWIND 13
C
C	   PRINT TITLE AND FREQUENCY VECTOR
C
	WRITE(6,4) NU
	DO 12 I=1,IN
12	JOUT(I)=FREQ(I)
	WRITE(6,5)(JOUT(I),I=1,IN)
	WRITE(6,7)
C
C	   FIND LARGEST FREQUENCY
C
	FMAX=0.0
	DO 20 I=1,IN
	IF(FREQ(I)-FMAX) 20,20,15
15	FMAX=FREQ(I)
20	CONTINUE
C
C	   SCALE IF NECESSARY
C
	JSCAL=1
	IF(FMAX-50.0) 40,40,30
30	JSCAL=(FMAX+49.0)/50.0
	WRITE(6,1)K,JSCAL
C
C	   CLEAR OUTPUT AREA TO BLANKS
C
40	DO 50 I=1,IN
50	JOUT(I)=NOTH
C
C	   LOCATE FREQUENCIES IN EACH INTERVAL
C
	MAX=FMAX/FLOAT(JSCAL)
	DO 80 I=1,MAX
	X=MAX-(I-1)
	DO 70 J=1,IN
	IF(FREQ(J)/FLOAT(JSCAL)-X) 70,60,60
60	JOUT(J)=K
70	CONTINUE
	IX=X*FLOAT(JSCAL)
C
C	   PRINT LINE OF FREQUENCIES
C
80	WRITE(6,2)IX,(JOUT(J),J=1,IN)
C
C	   GENERATE CONSTANTS
C
	DO 90 I=1,IN
90	JOUT(I)=I
C
C	   PRINT INTERVAL NUMBERS
C
	WRITE(6,7)
	WRITE(6,3)(JOUT(J),J=1,IN)
	WRITE(6,6)
	RETURN
	END
C
C
C	..................................................................
C
C	   SUBROUTINE HPCG
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL
C	      DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
C
C	   USAGE
C	      CALL HPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C	      PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER
C	               OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF
C	               THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR
C	               COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED
C	               BY THE USER) AND SUBROUTINE HPCG. EXCEPT PRMT(5)
C	               THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE
C	               HPCG AND THEY ARE
C	      PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCG INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE HPCG AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE HPCG DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING HPCG) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      Y      - INPUT VECTOR OF INITIAL VALUES.  (DESTROYED)
C	               LATERON Y IS THE RESULTING VECTOR OF DEPENDENT
C	               VARIABLES COMPUTED AT INTERMEDIATE POINTS X.
C	      DERY   - INPUT VECTOR OF ERROR WEIGHTS.  (DESTROYED)
C	               THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1.
C	               LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH
C	               BELONG TO FUNCTION VALUES Y AT A POINT X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE HPCG RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM
C	               TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST
C	               MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT
C	               DESTROY X AND Y.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE HPCG IS TERMINATED.
C	      AUX    - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM
C	               COLUMNS.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND
C	      OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
C	      CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
C	      PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
C	      DEPENDENT VARIABLES.
C	      FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
C	      USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
C	      COMPUTATION OF STARTING VALUES.
C	      SUBROUTINE HPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING
C	      THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
C	      TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
C	      MUST BE CODED BY THE USER.
C	      FOR REFERENCE, SEE
C	      (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	           COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	           MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C
C	..................................................................
C
	SUBROUTINE HPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX)
C
C
	DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1)
	N=1
	IHLF=0
	X=PRMT(1)
	H=PRMT(3)
	PRMT(5)=0.
	DO 1 I=1,NDIM
	AUX(16,I)=0.
	AUX(15,I)=DERY(I)
1	AUX(1,I)=Y(I)
	IF(H*(PRMT(2)-X))3,2,4
C
C	ERROR RETURNS
2	IHLF=12
	GOTO 4
3	IHLF=13
C
C	COMPUTATION OF DERY FOR STARTING VALUES
4	CALL FCT(X,Y,DERY)
C
C	RECORDING OF STARTING VALUES
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))6,5,6
5	IF(IHLF)7,7,6
6	RETURN
7	DO 8 I=1,NDIM
8	AUX(8,I)=DERY(I)
C
C	COMPUTATION OF AUX(2,I)
	ISW=1
	GOTO 100
C
9	X=X+H
	DO 10 I=1,NDIM
10	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
11	IHLF=IHLF+1
	X=X-H
	DO 12 I=1,NDIM
12	AUX(4,I)=AUX(2,I)
	H=.5*H
	N=1
	ISW=2
	GOTO 100
C
13	X=X+H
	CALL FCT(X,Y,DERY)
	N=2
	DO 14 I=1,NDIM
	AUX(2,I)=Y(I)
14	AUX(9,I)=DERY(I)
	ISW=3
	GOTO 100
C
C	COMPUTATION OF TEST VALUE DELT
15	DELT=0.
	DO 16 I=1,NDIM
16	DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I))
	DELT=.06666667*DELT
	IF(DELT-PRMT(4))19,19,17
17	IF(IHLF-10)11,18,18
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
18	IHLF=11
	X=X+H
	GOTO 4
C
C	THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS.
19	X=X+H
	CALL FCT(X,Y,DERY)
	DO 20 I=1,NDIM
	AUX(3,I)=Y(I)
20	AUX(10,I)=DERY(I)
	N=3
	ISW=4
	GOTO 100
C
21	N=1
	X=X+H
	CALL FCT(X,Y,DERY)
	X=PRMT(1)
	DO 22 I=1,NDIM
	AUX(11,I)=DERY(I)
   22	Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I)
     1-.2083333*AUX(10,I)+.04166667*DERY(I))
23	X=X+H
	N=N+1
	CALL FCT(X,Y,DERY)
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))6,24,6
24	IF(N-4)25,200,200
25	DO 26 I=1,NDIM
	AUX(N,I)=Y(I)
26	AUX(N+7,I)=DERY(I)
	IF(N-3)27,29,200
C
27	DO 28 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
28	Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 23
C
29	DO 30 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
30	Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 23
C
C	THE FOLLOWING PART OF SUBROUTINE HPCG COMPUTES BY MEANS OF
C	RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
C	PREDICTOR-CORRECTOR METHOD.
100	DO 101 I=1,NDIM
	Z=H*AUX(N+7,I)
	AUX(5,I)=Z
101	Y(I)=AUX(N,I)+.4*Z
C	Z IS AN AUXILIARY STORAGE LOCATION
C
	Z=X+.4*H
	CALL FCT(Z,Y,DERY)
	DO 102 I=1,NDIM
	Z=H*DERY(I)
	AUX(6,I)=Z
102	Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*Z
C
	Z=X+.4557372*H
	CALL FCT(Z,Y,DERY)
	DO 103 I=1,NDIM
	Z=H*DERY(I)
	AUX(7,I)=Z
103	Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*Z
C
	Z=X+H
	CALL FCT(Z,Y,DERY)
	DO 104 I=1,NDIM
  104	Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I)
     1+1.205536*AUX(7,I)+.1711848*H*DERY(I)
	GOTO(9,13,15,21),ISW
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
200	ISTEP=3
201	IF(N-8)204,202,204
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
202	DO 203 N=2,7
	DO 203 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
203	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
204	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 205 I=1,NDIM
	AUX(N-1,I)=Y(I)
205	AUX(N+6,I)=DERY(I)
	X=X+H
206	ISTEP=ISTEP+1
	DO 207 I=1,NDIM
	DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+
     1AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198*AUX(16,I)
207	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
C
	CALL FCT(X,Y,DERY)
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
C
	DO 208 I=1,NDIM
	DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+
     1AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
208	Y(I)=DELT+.07438017*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.
	DO 209 I=1,NDIM
209	DELT=DELT+AUX(15,I)*ABS(AUX(16,I))
	IF(DELT-PRMT(4))210,222,222
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
210	CALL FCT(X,Y,DERY)
	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))212,211,212
211	IF(IHLF-11)213,212,212
212	RETURN
213	IF(H*(X-PRMT(2)))214,212,212
214	IF(ABS(X-PRMT(2))-.1*ABS(H))212,215,215
215	IF(DELT-.02*PRMT(4))216,216,201
C
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE
216	IF(IHLF)201,201,217
217	IF(N-7)201,218,218
218	IF(ISTEP-4)201,219,219
219	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)201,220,201
220	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 221 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  221	AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT
     1+AUX(N+4,I))
	GOTO 201
C
C
C	H MUST BE HALVED
222	IHLF=IHLF+1
	IF(IHLF-10)223,223,210
223	H=.5*H
	ISTEP=0
	DO 224 I=1,NDIM
	Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+
     1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H
	AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+
     1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)-
     29.*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
224	AUX(N+4,I)=AUX(N+5,I)
	X=X-H
	DELT=X-(H+H)
	CALL FCT(DELT,Y,DERY)
	DO 225 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
225	Y(I)=AUX(N-4,I)
	DELT=DELT-(H+H)
	CALL FCT(DELT,Y,DERY)
	DO 226 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
	AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT
     1+DERY(I))
226	AUX(N+3,I)=DERY(I)
	GOTO 206
	END
C
C	..................................................................
C
C	   SUBROUTINE HPCL
C
C	   PURPOSE
C	      TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR
C	      DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES.
C
C	   USAGE
C	      CALL HPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
C	      PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER
C	               OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF
C	               THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR
C	               COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED
C	               BY THE USER) AND SUBROUTINE HPCL. EXCEPT PRMT(5)
C	               THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE
C	               HPCL AND THEY ARE
C	      PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCL INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE HPCL AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE HPCL DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING HPCL) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      Y      - INPUT VECTOR OF INITIAL VALUES.  (DESTROYED)
C	               LATERON Y IS THE RESULTING VECTOR OF DEPENDENT
C	               VARIABLES COMPUTED AT INTERMEDIATE POINTS X.
C	      DERY   - INPUT VECTOR OF ERROR WEIGHTS.  (DESTROYED)
C	               THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1.
C	               LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH
C	               BELONG TO FUNCTION VALUES Y AT A POINT X.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE HPCL RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY.
C	      AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE
C	               RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
C	               ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE
C	               SHOULD NOT DESTROY X.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
C	               RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE.
C	               ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE
C	               SHOULD NOT DESTROY X.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE HPCL IS TERMINATED.
C	      AUX    - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM
C	               COLUMNS.
C	      A      - AN NDIM BY NDIM MATRIX, WHICH IS USED AS AUXILIARY
C	               STORAGE ARRAY.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND
C	      OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR-
C	      CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4
C	      PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE
C	      DEPENDENT VARIABLES.
C	      FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS
C	      USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR
C	      COMPUTATION OF STARTING VALUES.
C	      SUBROUTINE HPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING
C	      THE WHOLE COMPUTATION BY HALVING OR DOUBLING.
C	      TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE
C	      MUST BE CODED BY THE USER.
C	      FOR REFERENCE, SEE
C	      (1)  RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	           COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (2)  RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	           MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C
C	..................................................................
C
	SUBROUTINE HPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A)
C
C
C	THE FOLLOWING FIRST PART OF SUBROUTINE HPCL (UNTIL FIRST BREAK-
C	POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE
C	COMPUTATION
C
	DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1)
	GOTO 100
C
C	THIS PART OF SUBROUTINE HPCL COMPUTES THE RIGHT HAND SIDE DERY OF
C	THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS.
1	CALL AFCT(X,A)
	CALL FCT(X,DERY)
	DO 3 M=1,NDIM
	LL=M-NDIM
	HS=0.
	DO 2 L=1,NDIM
	LL=LL+NDIM
2	HS=HS+A(LL)*Y(L)
3	DERY(M)=HS+DERY(M)
	GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
100	N=1
	IHLF=0
	X=PRMT(1)
	H=PRMT(3)
	PRMT(5)=0.
	DO 101 I=1,NDIM
	AUX(16,I)=0.
	AUX(15,I)=DERY(I)
101	AUX(1,I)=Y(I)
	IF(H*(PRMT(2)-X))103,102,104
C
C	ERROR RETURNS
102	IHLF=12
	GOTO 104
103	IHLF=13
C
C	COMPUTATION OF DERY FOR STARTING VALUES
104	ISW2=1
	GOTO 1
C
C	RECORDING OF STARTING VALUES
105	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))107,106,107
106	IF(IHLF)108,108,107
107	RETURN
108	DO 109 I=1,NDIM
109	AUX(8,I)=DERY(I)
C
C	COMPUTATION OF AUX(2,I)
	ISW1=1
	GOTO 200
C
110	X=X+H
	DO 111 I=1,NDIM
111	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
112	IHLF=IHLF+1
	X=X-H
	DO 113 I=1,NDIM
113	AUX(4,I)=AUX(2,I)
	H=.5*H
	N=1
	ISW1=2
	GOTO 200
C
114	X=X+H
	ISW2=5
	GOTO 1
115	N=2
	DO 116 I=1,NDIM
	AUX(2,I)=Y(I)
116	AUX(9,I)=DERY(I)
	ISW1=3
	GOTO 200
C
C	COMPUTATION OF TEST VALUE DELT
117	DELT=0.
	DO 118 I=1,NDIM
118	DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I))
	DELT=.06666667*DELT
	IF(DELT-PRMT(4))121,121,119
119	IF(IHLF-10)112,120,120
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
120	IHLF=11
	X=X+H
	GOTO 104
C
C	SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
121	X=X+H
	ISW2=6
	GOTO 1
122	DO 123 I=1,NDIM
	AUX(3,I)=Y(I)
123	AUX(10,I)=DERY(I)
	N=3
	ISW1=4
	GOTO 200
C
124	N=1
	X=X+H
	ISW2=7
	GOTO 1
125	X=PRMT(1)
	DO 126 I=1,NDIM
	AUX(11,I)=DERY(I)
  126	Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I)
     1-.2083333*AUX(10,I)+.04166667*DERY(I))
127	X=X+H
	N=N+1
	ISW2=12
	GOTO 1
128	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))107,129,107
129	IF(N-4)130,300,300
130	DO 131 I=1,NDIM
	AUX(N,I)=Y(I)
131	AUX(N+7,I)=DERY(I)
	IF(N-3)132,134,300
C
132	DO 133 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
133	Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 127
C
134	DO 135 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
135	Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 127
C
C	THE FOLLOWING PART OF SUBROUTINE HPCL COMPUTES BY MEANS OF
C	RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING
C	PREDICTOR-CORRECTOR METHOD.
200	Z=X
	DO 201 I=1,NDIM
	X=H*AUX(N+7,I)
	AUX(5,I)=X
201	Y(I)=AUX(N,I)+.4*X
C	X IS AN AUXILIARY STORAGE LOCATION
C
	X=Z+.4*H
	ISW2=2
	GOTO 1
202	DO 203 I=1,NDIM
	X=H*DERY(I)
	AUX(6,I)=X
203	Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X
C
	X=Z+.4557372*H
	ISW2=3
	GOTO 1
204	DO 205 I=1,NDIM
	X=H*DERY(I)
	AUX(7,I)=X
205	Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X
C
	X=Z+H
	ISW2=4
	GOTO 1
206	DO 207 I=1,NDIM
  207	Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I)
     1+1.205536*AUX(7,I)+.1711848*H*DERY(I)
	X=Z
	GOTO(110,114,117,124),ISW1
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
300	ISTEP=3
301	IF(N-8)304,302,304
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
302	DO 303 N=2,7
	DO 303 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
303	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
304	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 305 I=1,NDIM
	AUX(N-1,I)=Y(I)
305	AUX(N+6,I)=DERY(I)
	X=X+H
306	ISTEP=ISTEP+1
	DO 307 I=1,NDIM
	DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+
     1AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198*AUX(16,I)
307	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
	ISW2=8
	GOTO 1
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY
C
308	DO 309 I=1,NDIM
	DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+
     1AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
309	Y(I)=DELT+.07438017*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.
	DO 310 I=1,NDIM
310	DELT=DELT+AUX(15,I)*ABS(AUX(16,I))
	IF(DELT-PRMT(4))311,324,324
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
311	ISW2=9
	GOTO 1
312	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))314,313,314
313	IF(IHLF-11)315,314,314
314	RETURN
315	IF(H*(X-PRMT(2)))316,314,314
316	IF(ABS(X-PRMT(2))-.1*ABS(H))314,317,317
317	IF(DELT-.02*PRMT(4))318,318,301
C
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE
318	IF(IHLF)301,301,319
319	IF(N-7)301,320,320
320	IF(ISTEP-4)301,321,321
321	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)301,322,301
322	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 323 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  323	AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT
     1+AUX(N+4,I))
	GOTO 301
C
C
C	H MUST BE HALVED
324	IHLF=IHLF+1
	IF(IHLF-10)325,325,311
325	H=.5*H
	ISTEP=0
	DO 326 I=1,NDIM
	Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+
     1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H
	AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+
     1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)-
     29.*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
326	AUX(N+4,I)=AUX(N+5,I)
	DELT=X-H
	X=DELT-(H+H)
	ISW2=10
	GOTO 1
327	DO 328 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
328	Y(I)=AUX(N-4,I)
	X=X-(H+H)
	ISW2=11
	GOTO 1
329	X=DELT
	DO 330 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
	AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT
     1+DERY(I))
330	AUX(N+3,I)=DERY(I)
	GOTO 306
	END
C
C	..................................................................
C
C	   SUBROUTINE HSBG
C
C	   PURPOSE
C	      TO REDUCE A REAL MATRIX INTO UPPER ALMOST TRIANGULAR FORM
C
C	   USAGE
C	      CALL HSBG(N,A,IA)
C
C	   DESCRIPTION OF THE PARAMETERS
C	      N      ORDER OF THE MATRIX
C	      A      THE INPUT MATRIX, N BY N
C	      IA     SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY
C	             A IN THE CALLING PROGRAM WHEN THE MATRIX IS IN
C	             DOUBLE SUBSCRIPTED DATA STORAGE MODE.  IA=N WHEN
C	             THE MATRIX IS IN SSP VECTOR STORAGE MODE.
C
C	   REMARKS
C	      THE HESSENBERG FORM REPLACES THE ORIGINAL MATRIX IN THE
C	      ARRAY A.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SIMILARITY TRANSFORMATIONS USING ELEMENTARY ELIMINATION
C	      MATRICES, WITH PARTIAL PIVOTING.
C
C	   REFERENCES
C	      J.H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM -
C	      CLARENDON PRESS, OXFORD, 1965.
C
C	..................................................................
C
	SUBROUTINE HSBG(N,A,IA)
	DIMENSION A(1)
	DOUBLE PRECISION S
	L=N
	NIA=L*IA
	LIA=NIA-IA
C
C	   L IS THE ROW INDEX OF THE ELIMINATION
C
20	IF(L-3) 360,40,40
40	LIA=LIA-IA
	L1=L-1
	L2=L1-1
C
C	   SEARCH FOR THE PIVOTAL ELEMENT IN THE LTH ROW
C
	ISUB=LIA+L
	IPIV=ISUB-IA
	PIV=ABS(A(IPIV))
	IF(L-3) 90,90,50
50	M=IPIV-IA
	DO 80 I=L,M,IA
	T=ABS(A(I))
	IF(T-PIV) 80,80,60
60	IPIV=I
	PIV=T
80	CONTINUE
90	IF(PIV) 100,320,100
100	IF(PIV-ABS(A(ISUB))) 180,180,120
C
C	   INTERCHANGE THE COLUMNS
C
120	M=IPIV-L
	DO 140 I=1,L
	J=M+I
	T=A(J)
	K=LIA+I
	A(J)=A(K)
140	A(K)=T
C
C	   INTERCHANGE THE ROWS
C
	M=L2-M/IA
	DO 160 I=L1,NIA,IA
	T=A(I)
	J=I-M
	A(I)=A(J)
160	A(J)=T
C
C	   TERMS OF THE ELEMENTARY TRANSFORMATION
C
180	DO 200 I=L,LIA,IA
200	A(I)=A(I)/A(ISUB)
C
C	   RIGHT TRANSFORMATION
C
	J=-IA
	DO 240 I=1,L2
	J=J+IA
	LJ=L+J
	DO 220 K=1,L1
	KJ=K+J
	KL=K+LIA
220	A(KJ)=A(KJ)-A(LJ)*A(KL)
240	CONTINUE
C
C	   LEFT TRANSFORMATION
C
	K=-IA
	DO 300 I=1,N
	K=K+IA
	LK=K+L1
	S=A(LK)
	LJ=L-IA
	DO 280 J=1,L2
	JK=K+J
	LJ=LJ+IA
280	S=S+A(LJ)*A(JK)*1.0D0
300	A(LK)=S
C
C	   SET THE LOWER PART OF THE MATRIX TO ZERO
C
	DO 310 I=L,LIA,IA
310	A(I)=0.0
320	L=L1
	GO TO 20
360	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE I0
C
C	   PURPOSE
C	       COMPUTE THE MODIFIED BESSEL FUNCTION I OF ORDER ZERO
C
C	   USAGE
C	       CALL I0(X,RI0)
C
C	   DESCRIPTION OF PARAMETERS
C	       X    -GIVEN ARGUMENT OF THE BESSEL FUNCTION I OF ORDER 0
C	       RI0  -RESULTANT VALUE OF THE BESSEL FUNCTION I OF ORDER 0
C
C	   REMARKS
C	       LARGE VALUES OF THE ARGUMENT MAY CAUSE OVERFLOW IN THE
C	       BUILTIN EXP-FUNCTION
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      POLYNOMIAL APPROXIMATIONS GIVEN BY E.E. ALLEN ARE USED FOR
C	      CALCULATION.
C	      FOR REFERENCE SEE
C	      M. ABRAMOWITZ AND I.A. STEGUN,'HANDBOOK OF MATHEMATICAL
C	      FUNCTIONS', U.S. DEPARTMENT OF COMMERCE, NATIONAL BUREAU OF
C	      STANDARDS APPLIED MATHEMATICS SERIES, 1966, P.378.
C
C	..................................................................
C
	SUBROUTINE I0(X,RI0)
	RI0=ABS(X)
	IF(RI0-3.75)1,1,2
1	Z=X*X*7.111111E-2
	RI0=((((( 4.5813E-3*Z+3.60768E-2)*Z+2.659732E-1)*Z+1.206749E0)*Z
     1+3.089942E0)*Z+3.515623E0)*Z+1.
	RETURN
2	Z=3.75/RI0
	RI0= EXP(RI0)/SQRT(RI0)*((((((((3.92377E-3*Z-1.647633E-2)*Z
     1+2.635537E-2)*Z-2.057706E-2)*Z+9.16281E-3)*Z-1.57565E-3)*Z
     2+2.25319E-3)*Z+1.328592E-2)*Z+3.989423E-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE INUE
C
C	   PURPOSE
C	      COMPUTE THE MODIFIED BESSEL FUNCTIONS I FOR ORDERS 1 TO N
C
C	   USAGE
C	      CALL INUE(X,N,ZI,RI)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -GIVEN ARGUMENT OF THE BESSEL FUNCTIONS I
C	      N     -GIVEN MAXIMUM ORDER OF BESSEL FUNCTIONS I
C	      ZI    -GIVEN VALUE OF BESSEL FUNCTION I OF ORDER ZERO
C	             FOR ARGUMENT X
C	      RI    -RESULTANT VECTOR OF DIMENSION N, CONTAINING THE
C	             VALUES OF THE FUNCTIONS I FOR ORDERS 1 TO N
C
C	   REMARKS
C	      THE VALUE OF ZI MAY BE CALCULATED USING SUBROUTINE I0.
C	      USING A DIFFERENT VALUE HAS THE EFFECT THAT ALL VALUES OF
C	      BESSEL FUNCTIONS I ARE MULTIPLIED BY THE  FACTOR ZI/I(0,X)
C	      WHERE I(0,X) IS THE VALUE OF I FOR ORDER 0 AND ARGUMENT X.
C	      THIS MAY BE USED DISADVANTAGEOUSLY IF ONLY THE RATIOS OF I
C	      FOR DIFFERENT ORDERS ARE REQUIRED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE VALUES ARE OBTAINED USING BACKWARD RECURRENCE RELATION
C	      TECHNIQUE. THE RATIO I(N+1,X)/I(N,X) IS OBTAINED FROM A
C	      CONTINUED FRACTION.
C	      FOR REFERENCE SEE
C	      G. BLANCH,'NUMERICAL EVALUATION OF CONTINUED FRACTIONS',
C	      SIAM REVIEW, VOL.6,NO.4,1964,PP.383-421.
C
C	..................................................................
C
	SUBROUTINE INUE(X,N,ZI,RI)
	DIMENSION RI(1)
	IF(N)10,10,1
1	FN=N+N
	Q1=X/FN
	IF(ABS(X)-5.E-4)6,6,2
2	A0=1.
	A1=0.
	B0=0.
	B1=1.
	FI=FN
3	FI=FI+2.
	AN=FI/ABS(X)
	A=AN*A1+A0
	B=AN*B1+B0
	A0=A1
	B0=B1
	A1=A
	B1=B
	Q0=Q1
	Q1=A/B
	IF(ABS((Q1-Q0)/Q1)-1.E-6)4,4,3
4	IF(X)5,6,6
5	Q1=-Q1
6	K=N
7	Q1=X/(FN+X*Q1)
	RI(K)=Q1
	FN=FN-2.
	K=K-1
	IF(K)8,8,7
8	FI=ZI
	DO 9 I=1,N
	FI=FI*RI(I)
9	RI(I)=FI
10	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE JELF
C
C	   PURPOSE
C	      COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN.
C
C	   USAGE
C	      CALL JELF(SN,CN,DN,X,SCK)
C
C	   DESCRIPTION OF PARAMETERS
C	      SN    - RESULT VALUE SN(X)
C	      CN    - RESULT VALUE CN(X)
C	      DN    - RESULT VALUE DN(X)
C	      X     - ARGUMENT OF JACOBIAN ELLIPTIC FUNCTIONS
C	      SCK   - SQUARE OF COMPLEMENTARY MODULUS
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER
C	      T FROM 0 TO SN), WHERE K=SQRT(1-SCK).
C	      SN*SN + CN*CN = 1
C	      (K*SN)**2 + DN**2 = 1.
C	      EVALUATION
C	      CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC
C	      GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION
C	      BEFORE INVERSION OF THE INTEGRAL TAKES PLACE.
C	      REFERENCE
C	      R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND
C	             ELLIPTIC FUNCTIOMS.
C	             HANDBOOK SERIES OF SPECIAL FUNCTIONS
C	             NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90.
C
C	..................................................................
C
	SUBROUTINE JELF(SN,CN,DN,X,SCK)
C
C
	DIMENSION ARI(12),GEO(12)
C	TEST MODULUS
	CM=SCK
	Y=X
	IF(SCK)3,1,4
1	D=EXP(X)
	A=1./D
	B=A+D
	CN=2./B
	DN=CN
	SN=TANH(X)
C	   DEGENERATE CASE SCK=0 GIVES RESULTS
C	      CN X = DN X = 1/COSH X
C	      SN X = TANH X
2	RETURN
C	   JACOBIS MODULUS TRANSFORMATION
3	D=1.-SCK
	CM=-SCK/D
	D=SQRT(D)
	Y=D*X
4	A=1.
	DN=1.
	DO 6 I=1,12
	L=I
	ARI(I)=A
	CM=SQRT(CM)
	GEO(I)=CM
	C=(A+CM)*.5
	IF(ABS(A-CM)-1.E-4*A)7,7,5
5	CM=A*CM
6	A=C
C
C	START BACKWARD RECURSION
7	Y=C*Y
	SN=SIN(Y)
	CN=COS(Y)
	IF(SN)8,13,8
8	A=CN/SN
	C=A*C
	DO 9 I=1,L
	K=L-I+1
	B=ARI(K)
	A=C*A
	C=DN*C
	DN=(GEO(K)+A)/(B+A)
9	A=C/B
	A=1./SQRT(C*C+1.)
	IF(SN)10,11,11
10	SN=-A
	GOTO 12
11	SN=A
12	CN=C*SN
13	IF(SCK)14,2,2
14	A=DN
	DN=CN
	CN=A
	SN=SN/D
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR THE KOLMOGOROV-SMIRNOV TEST-KOLM
C
C	   PURPOSE
C	      (1) READ THE CONTROL CARD FOR A ONE OR TWO SAMPLE TEST
C	      (2) READ THE SAMPLE DATA AND DETERMINE THE SAMPLE SIZES
C	      (3) PRINT RESULTS
C
C	   REMARKS
C	      THE USER SHOULD NOTE THE REMARKS GIVEN IN SUBROUTINES
C	      KOLMO, KOLM2, AND SMIRN, AND THE MATHEMATICAL DESCRIPTIONS
C	      FOR THESE SUBROUTINES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      KOLMO
C	      KOLM2
C	      SMIRN
C	      NDTR
C
C	   METHOD
C	      REFER TO SUBROUTINES KOLMO, KOLM2, AND SMIRN
C
C	..................................................................
C
C	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN THE NUMBER OF DATA
C	ELEMENTS IN THE TWO SAMPLES, M AND N
cC
c	   DIMENSION X(501),Y(501)
cC
cC	..................................................................
cC
c	   DIMENSION TITLE(5),D(12),TIT1(20),DIST(5,3)
cC
cC	..................................................................
cC
c1	FORMAT(5A4,3I1,5(F1.0,2F5.0))
c2	FORMAT(//'CC.21, CONTROL CARD, INCORRECT, OR SAMPLE SIZE IS TOO LA
c     1RGE.  JOB IGNORED.')
c3	FORMAT(12F6.0)
c4	FORMAT(1H1,5A4)
c5	FORMAT(//2H A,I2,' SAMPLE TEST WAS REQUESTED')
c6	FORMAT(20A4)
c7	FORMAT(//(10F10.3))
c8	FORMAT(//' SORTED SAMPLE ONE FOLLOWS')
c9	FORMAT(//' THE HYPOTHESIS THAT THE SAMPLE IS FROM A(N) ',4A4,  ' D
c     1ISTRIBUTION')
c10	FORMAT(//' SORTED SAMPLE TWO FOLLOWS')
c11	FORMAT(//' THE HYPOTHESIS THAT THE TWO SAMPLES ARE FROM THE SAME P
c     1OPULATION CAN BE REJECTED WITH (ASYMPTOTIC)',/,' PROBABILITY OF BE
c     2ING INCORRECT OF ',F6.3,'.  THE STATISTIC Z IS ',E12.4,' FOR THESE
c     3 SAMPLES.')
c12	FORMAT(//,' THE SIZE OF SAMPLE',I3,' IS',I4,'.')
c13	FORMAT(//,' NOTE THE REMARKS CONCERNING ASYMPTOTIC RESULTS AND SAM
c     1PLE SIZE IN SUBROUTINE SMIRN')
c14	FORMAT(//,' AT LEAST ONE (S) ENTRY PARAMETER FOR THE SUBROUTINE KO
c     1LMO WAS INCORRECT.'/' THE TEST FOR THE ASSOCIATED CONTINUOUS PDF W
c     2AS IGNORED.')
c15	FORMAT(A4)
c16	FORMAT(//,' THIS JOB CALLS FOR THE USE OF A PREVIOUSLY READ SAMPLE
c     1, AND THE PREVIOUS JOB WAS IGNORED BECAUSE OF ERRORS.'/ ' JOB IGNO
c     2RED.')
c17	FORMAT(//,' FIRST CARD IN JOB DECK (JOB CONTROL CARD) IS INCORRECT
c     1.')
c18	FORMAT(1H ,' WITH MEAN',F13.4,' AND VARIANCE',F13.4)
c19	FORMAT(1H ,' WITH MEDIAN',F13.4,' AND FIRST QUARTILE',F13.4)
c20	FORMAT(1H ,' IN THE INTERVAL',F13.4,' TO',F13.4,' INCLUSIVE')
c21	FORMAT(1H ,' CAN BE REJECTED WITH PROBABILITY',F6.3,' OF BEING INC
c     1ORRECT.  THE STATISTIC Z',/,'  IS',E12.4,' FOR THIS SAMPLE.')
c22	FORMAT(//,'  THE JOB WITH TITLE ',5A4,' WAS COMPLETED.')
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	   READ DISTRIBUTION NAMES AND JOB CONTROL CARD
cC
c	IFL=0
c	READ(5,15)DASH
c	READ(5,6)TIT1
cC
cC	   SELECT PROGRAM CONTROLS
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ(5,15)DAS2
c	IF (EOF) GOTO 999
c	IF(DASH-DAS2)101,102,101
c101	WRITE(6,17)
c	GO TO 107
c102	READ(5,1)TITLE,IS,IR,IO,((DIST(I,J),J=1,3),I=1,5)
c	IES=0
c	WRITE(6,4)TITLE
c	WRITE(6,5)IS
cC
cC	   NUMBER OF SAMPLES DECISION
cC
c	IF(IR)103,105,103
c103	IF(IFL)104,115,104
c104	WRITE(6,16)
c	GO TO 107
c105	IF(IS-1)106,109,109
cC
cC	   NOT ONE OR TWO SAMPLES
cC
c106	WRITE(6,2)
c107	READ(5,15)DAS2
c	IF(DASH-DAS2)107,108,107
c108	IFL=1
c	GO TO 102
cC
cC	   READ FIRST SAMPLE
cC
c109	N=0
c	DO 111 I=1,50
c	READ(5,3)D
c	DO 111 J=1,12
c	IF(D(J)-999999.0)110,112,110
c110	N=N+1
c	IF(N-501)111,106,106
c111	X(N)=D(J)
c112	N1=1
c	WRITE(6,12)N1,N
cC
cC	   CHECK THE SIZE OF N
cC
c	IF(N-100)113,113,114
c113	WRITE(6,13)
c114	IF(IS-2)121,115,106
cC
cC	   READ SECOND SAMPLE
cC
c115	M=0
c	DO 117 I=1,50
c	READ(5,3)D
c	DO 117 J=1,12
c	IF(D(J)-999999.0)116,118,116
c116	M=M+1
c	IF(M-501)117,106,106
c117	Y(M)=D(J)
c118	N1=2
c	WRITE(6,12)N1,M
cC
cC	   CHECK THE SIZE OF M
cC
c	IF(M-100)119,119,120
c119	WRITE(6,13)
c120	IF(IS-1)121,121,133
cC
cC	   ONE SAMPLE TEST USING ALL DISTRIBUTIONS REQUESTED
cC
c121	DO 130 I=1,5
c	IF(DIST(I,1))130,130,122
c122	CALL KOLMO(X,N,Z,P,I,DIST(I,2),DIST(I,3),IER)
c	IES=IER+IES
c	IF(IER)130,124,130
c123	WRITE(6,14)
c	GO TO 136
cC
cC	   OUTPUT RESULTS
cC
c124	K=4*I-3
c	WRITE(6,9)TIT1(K),TIT1(K+1),TIT1(K+2),TIT1(K+3)
c	IF(I-3)125,126,127
c125	S2=DIST(I,3)**2
c	WRITE(6,18)DIST(I,2),S2
c	GO TO 129
c126	S2=DIST(I,2)-DIST(I,3)
c	WRITE(6,19)DIST(I,2),S2
c	GO TO 129
c127	IF(I-4)128,128,130
c128	WRITE(6,20)DIST(I,2),DIST(I,3)
c129	WRITE(6,21)P,Z
c130	CONTINUE
cC
cC	   OUTPUT SAMPLE ONE DECISION
cC
c	IF(IO)131,132,131
c131	WRITE(6,8)
c	WRITE(6,7)(X(J),J=1,N)
c132	IF(IES)123,136,123
cC
cC	   TWO SAMPLE TEST
cC
c133	CALL KOLM2(X,Y,N,M,Z,P)
cC
cC	   OUTPUT SAMPLES DECISION
cC
c	IF(IO)134,135,134
c134	WRITE(6,8)
c	WRITE(6,7)(X(J),J=1,N)
c	WRITE(6,10)
c	WRITE(6,7)(Y(J),J=1,M)
c135	WRITE(6,11)P,Z
c136	IFL=0
c	WRITE(6,22)TITLE
c	GO TO 100
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE KOLM2
C
C	   PURPOSE
C
C	      TESTS THE DIFFERENCE BETWEEN TWO SAMPLE DISTRIBUTION
C	      FUNCTIONS USING THE KOLMOGOROV-SMIRNOV TEST
C
C	   USAGE
C	      CALL KOLM2(X,Y,N,M,Z,PROB)
C
C	   DESCRIPTION OF PARAMETERS
C	      X    - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS.  ON
C	             RETURN FROM KOLM2, X HAS BEEN SORTED INTO A
C	             MONOTONIC NON-DECREASING SEQUENCE.
C	      Y    - INPUT VECTOR OF M INDEPENDENT OBSERVATIONS.  ON
C	             RETURN FROM KOLM2, Y HAS BEEN SORTED INTO A
C	             MONOTONIC NON-DECREASING SEQUENCE.
C	      N    - NUMBER OF OBSERVATIONS IN X
C	      M    - NUMBER OF OBSERVATIONS IN Y
C	      Z    - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH
C	             RESPECT TO THE SPECTRUM OF X AND Y OF
C	             SQRT((M*N)/(M+N))*ABS(FN(X)-GM(Y)) WHERE
C	             FN(X) IS THE EMPIRICAL DISTRIBUTION FUNCTION OF THE
C	             SET (X) AND GM(Y) IS THE EMPIRICAL DISTRIBUTION
C	             FUNCTION OF THE SET (Y).
C	      PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF
C	             THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF
C	             THE HYPOTHESIS THAT X AND Y ARE FROM THE SAME PDF IS
C	             TRUE.  E.G., PROB= 0.05 IMPLIES THAT ONE CAN REJECT
C	             THE NULL HYPOTHESIS THAT THE SETS X AND Y ARE FROM
C	             THE SAME DENSITY WITH 5 PER CENT PROBABILITY OF BEING
C	             INCORRECT.  PROB = 1. - SMIRN(Z).
C
C	   REMARKS
C	      N AND M SHOULD BE GREATER THAN OR EQUAL TO 100.  (SEE THE
C	      MATHEMATICAL DESCRIPTION FOR THIS SUBROUTINE AND FOR THE
C	      SUBROUTINE SMIRN, CONCERNING ASYMPTOTIC FORMULAE).
C
C	      DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL
C	      WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY.
C	      IF ONE WISHES TO COMMUNICATE WITH KOLM2 IN A DOUBLE
C	      PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED
C	      PROGRAM SNGL(X) PRIOR TO CALLING KOLM2, AND CALL THE
C	      FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLM2.
C	      (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION
C	      CAPABILITY AS SUPPLIED BY THIS PACKAGE.)
C
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SMIRN
C
C	   METHOD
C	      FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV
C	      LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS--
C	      ANNALS OF MATH. STAT., 19, 1948.  177-189,
C	      (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT
C	      OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19,
C	      1948.  279-281.
C	      (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND
C	      STATISTICS--ACADEMIC PRESS, NEW YORK, 1964.  490-493,
C	      (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA
C	      PUBLISHING COMPANY, NEW YORK, 1962.  384-401.
C
C	..................................................................
C
	SUBROUTINE KOLM2(X,Y,N,M,Z,PROB)
	DIMENSION X(1),Y(1)
C
C	   SORT X INTO ASCENDING SEQUENCE
C
	DO 5 I=2,N
	IF(X(I)-X(I-1))1,5,5
1	TEMP=X(I)
	IM=I-1
	DO 3 J=1,IM
	L=I-J
	IF(TEMP-X(L))2,4,4
2	X(L+1)=X(L)
3	CONTINUE
	X(1)=TEMP
	GO TO 5
4	X(L+1)=TEMP
5	CONTINUE
C
C	   SORT Y INTO ASCENDING SEQUENCE
C
	DO 10 I=2,M
	IF(Y(I)-Y(I-1))6,10,10
6	TEMP=Y(I)
	IM=I-1
	DO 8  J=1,IM
	L=I-J
	IF(TEMP-Y(L))7,9,9
7	Y(L+1)=Y(L)
8	CONTINUE
	Y(1)=TEMP
	GO TO 10
9	Y(L+1)=TEMP
10	CONTINUE
C
C	   CALCULATE D = ABS(FN-GM) OVER THE SPECTRUM OF X AND Y
C
	XN=FLOAT(N)
	XN1=1./XN
	XM=FLOAT(M)
	XM1=1./XM
	D=0.0
	I=0
	J=0
	K=0
	L=0
11	IF(X(I+1)-Y(J+1))12,13,18
12	K=1
	GO TO 14
13	K=0
14	I=I+1
	IF(I-N)15,21,21
15	IF(X(I+1)-X(I))14,14,16
16	IF(K)17,18,17
C
C	   CHOOSE THE MAXIMUM DIFFERENCE, D
C
17	D=AMAX1(D,ABS(FLOAT(I)*XN1-FLOAT(J)*XM1))
	IF(L)22,11,22
18	J=J+1
	IF(J-M)19,20,20
19	IF(Y(J+1)-Y(J))18,18,17
20	L=1
	GO TO 17
21	L=1
	GO TO 16
C
C	   CALCULATE THE STATISTIC Z
C
22	Z=D*SQRT((XN*XM)/(XN+XM))
C
C	   CALCULATE THE PROBABILITY ASSOCIATED WITH Z
C
	CALL SMIRN(Z,PROB)
	PROB=1.0-PROB
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE KOLMO
C
C	   PURPOSE
C	      TESTS THE DIFFERENCE BETWEEN EMPIRICAL AND THEORETICAL
C	      DISTRIBUTIONS  USING THE KOLMOGOROV-SMIRNOV TEST
C
C	   USAGE
C	      CALL KOLMO(X,N,Z,PROB,IFCOD,U,S,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X    - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS.  ON
C	             RETURN FROM KOLMO, X HAS BEEN SORTED INTO A
C	             MONOTONIC NON-DECREASING SEQUENCE.
C	      N    - NUMBER OF OBSERVATIONS IN X
C	      Z    - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH
C	             RESPECT TO X OF  SQRT(N)*ABS(FN(X)-F(X)) WHERE
C	             F(X) IS A  THEORETICAL DISTRIBUTION FUNCTION AND
C	             FN(X) AN EMPIRICAL DISTRIBUTION FUNCTION.
C	      PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF
C	             THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF
C	             THE HYPOTHESIS THAT X IS FROM THE DENSITY UNDER
C	             CONSIDERATION IS TRUE.  E.G., PROB = 0.05 IMPLIES
C	             THAT ONE CAN REJECT THE NULL HYPOTHESIS THAT THE SET
C	             X IS FROM THE DENSITY UNDER CONSIDERATION WITH 5 PER
C	             CENT PROBABILITY OF BEING INCORRECT.  PROB = 1. -
C	             SMIRN(Z).
C	      IFCOD- A CODE DENOTING THE PARTICULAR THEORETICAL
C	             PROBABILITY DISTRIBUTION FUNCTION BEING CONSIDERED.
C	             = 1---F(X) IS THE NORMAL PDF.
C	             = 2---F(X) IS THE EXPONENTIAL PDF.
C	             = 3---F(X) IS THE CAUCHY PDF.
C	             = 4---F(X) IS THE UNIFORM PDF.
C	             = 5---F(X) IS USER SUPPLIED.
C	      U    - WHEN IFCOD IS 1 OR 2, U IS THE MEAN OF THE DENSITY
C	             GIVEN ABOVE.
C	             WHEN IFCOD IS 3, U IS THE MEDIAN OF THE CAUCHY
C	             DENSITY.
C	             WHEN IFCOD IS 4, U IS THE LEFT ENDPOINT OF THE
C	             UNIFORM DENSITY.
C	             WHEN IFCOD IS 5, U IS USER SPECIFIED.
C	      S    - WHEN IFCOD IS 1 OR 2, S IS THE STANDARD DEVIATION OF
C	             DENSITY GIVEN ABOVE, AND SHOULD BE POSITIVE.
C	             WHEN IFCOD IS 3, U - S SPECIFIES THE FIRST QUARTILE
C	             OF THE CAUCHY DENSITY.  S SHOULD BE NON-ZERO.
C	             IF IFCOD IS 4, S IS THE RIGHT ENDPOINT OF THE UNIFORM
C	             DENSITY.  S SHOULD BE GREATER THAN U.
C	             IF IFCOD IS 5, S IS USER SPECIFIED.
C	      IER  - ERROR INDICATOR WHICH IS NON-ZERO IF S VIOLATES ABOVE
C	             CONVENTIONS.  ON RETURN NO TEST HAS BEEN MADE, AND X
C	             AND Y HAVE BEEN SORTED INTO MONOTONIC NON-DECREASING
C	             SEQUENCES.  IER IS SET TO ZERO ON ENTRY TO KOLMO.
C	             IER IS CURRENTLY SET TO ONE IF THE USER-SUPPLIED PDF
C	             IS REQUESTED FOR TESTING.  THIS SHOULD BE CHANGED
C	             (SEE REMARKS) WHEN SOME PDF IS SUPPLIED BY THE USER.
C
C	   REMARKS
C	      N SHOULD BE GREATER THAN OR EQUAL TO 100.  (SEE THE
C	      MATHEMATICAL DESCRIPTION GIVEN FOR THE PROGRAM SMIRN,
C	      CONCERNING ASYMPTOTIC FORMULAE)  ALSO, PROBABILITY LEVELS
C	      DETERMINED BY THIS PROGRAM WILL NOT BE CORRECT IF THE
C	      SAME SAMPLES ARE USED TO ESTIMATE PARAMETERS FOR THE
C	      CONTINUOUS DISTRIBUTIONS WHICH ARE USED IN THIS TEST.
C	      (SEE THE MATHEMATICAL DESCRIPTION FOR THIS PROGRAM)
C	      F(X) SHOULD BE A CONTINUOUS FUNCTION.
C	      ANY USER SUPPLIED CUMULATIVE PROBABILITY DISTRIBUTION
C	      FUNCTION SHOULD BE CODED BEGINNING WITH STATEMENT 26 BELOW,
C	      AND SHOULD RETURN TO STATEMENT 27.
C
C	      DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL
C	      WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY.
C	      IF ONE WISHES TO COMMUNICATE WITH KOLMO IN A DOUBLE
C	      PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED
C	      PROGRAM SNGL(X) PRIOR TO CALLING KOLMO, AND CALL THE
C	      FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLMO.
C	      (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION
C	      CAPABILITY AS SUPPLIED BY THIS PACKAGE.)
C
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SMIRN, NDTR, AND ANY USER SUPPLIED SUBROUTINES REQUIRED.
C
C	   METHOD
C	      FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV
C	      LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS--
C	      ANNALS OF MATH. STAT., 19, 1948.  177-189,
C	      (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT
C	      OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19,
C	      1948.  279-281.
C	      (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND
C	      STATISTICS--ACADEMIC PRESS, NEW YORK, 1964.  490-493,
C	      (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA
C	      PUBLISHING COMPANY, NEW YORK, 1962.  384-401.
C
C	..................................................................
C
	SUBROUTINE KOLMO(X,N,Z,PROB,IFCOD,U,S,IER)
	DIMENSION X(1)
C
C	     NON DECREASING ORDERING OF X(I)'S  (DUBY METHOD)
C
	IER=0
	DO 5 I=2,N
	IF(X(I)-X(I-1))1,5,5
1	TEMP=X(I)
	IM=I-1
	DO 3 J=1,IM
	L=I-J
	IF(TEMP-X(L))2,4,4
2	X(L+1)=X(L)
3	CONTINUE
	X(1)=TEMP
	GO TO 5
4	X(L+1)=TEMP
5	CONTINUE
C
C	      COMPUTES MAXIMUM DEVIATION DN IN ABSOLUTE VALUE BETWEEN
C	      EMPIRICAL AND THEORETICAL DISTRIBUTIONS
C
	NM1=N-1
	XN=N
	DN=0.0
	FS=0.0
	IL=1
6	DO 7  I=IL,NM1
	J=I
	IF(X(J)-X(J+1))9,7,9
7	CONTINUE
8	J=N
9	IL=J+1
	FI=FS
	FS=FLOAT(J)/XN
	IF(IFCOD-2)10,13,17
10	IF(S)11,11,12
11	IER=1
	GO TO 29
12	Z =(X(J)-U)/S
	CALL NDTR(Z,Y,D)
	GO TO 27
13	IF(S)11,11,14
14	Z=(X(J)-U)/S+1.0
	IF(Z)15,15,16
15	Y=0.0
	GO TO 27
16	Y=1.-EXP(-Z)
	GO TO 27
17	IF(IFCOD-4)18,20,26
18	IF(S)19,11,19
19	Y=ATAN((X(J)-U)/S)*0.3183099+0.5
	GO TO 27
20	IF(S-U)11,11,21
21	IF(X(J)-U)22,22,23
22	Y=0.0
	GO TO 27
23	IF(X(J)-S)25,25,24
24	Y=1.0
	GO TO 27
25	Y=(X(J)-U)/(S-U)
	GO TO 27
26	IER=1
	GO TO 29
27	EI=ABS(Y-FI)
	ES=ABS(Y-FS)
	DN=AMAX1(DN,EI,ES)
	IF(IL-N)6,8,28
C
C	      COMPUTES Z=DN*SQRT(N)  AND  PROBABILITY
C
28	Z=DN*SQRT(XN)
	CALL SMIRN(Z,PROB)
	PROB=1.0-PROB
29	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE KRANK
C
C	   PURPOSE
C	      TEST CORRELATION BETWEEN TWO VARIABLES BY MEANS OF KENDALL
C	      RANK CORRELATION COEFFICIENT
C
C	   USAGE
C	      CALL KRANK(A,B,R,N,TAU,SD,Z,NR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - INPUT VECTOR OF N OBSERVATIONS FOR FIRST VARIABLE
C	      B   - INPUT VECTOR OF N OBSERVATIONS FOR SECOND VARIABLE
C	      R   - OUTPUT VECTOR OF RANKED DATA OF LENGTH 2*N. SMALLEST
C	            OBSERVATION IS RANKED 1, LARGEST IS RANKED N. TIES
C	            ARE ASSIGNED AVERAGE OF TIED RANKS.
C	      N   - NUMBER OF OBSERVATIONS
C	      TAU - KENDALL RANK CORRELATION COEFFICIENT (OUTPUT)
C	      SD  - STANDARD DEVIATION (OUTPUT)
C	      Z   - TEST OF SIGNIFICANCE OF TAU IN TERMS OF NORMAL
C	            DISTRIBUTION (OUTPUT)
C	      NR  - CODE, 0 FOR UNRANKED DATA IN A AND B, 1 FOR RANKED
C	            DATA IN A AND B (INPUT)
C
C	   REMARKS
C	      SD AND Z ARE SET TO ZERO IF N IS LESS THAN TEN
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANK
C	      TIE
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 9
C
C	..................................................................
C
	SUBROUTINE KRANK(A,B,R,N,TAU,SD,Z,NR)
	DIMENSION A(1),B(1),R(1)
C
	SD=0.0
	Z=0.0
	FN=N
	FN1=N*(N-1)
C
C	   DETERMINE WHETHER DATA IS RANKED
C
	IF(NR-1) 5, 10, 5
C
C	   RANK DATA IN A AND B VECTORS AND ASSIGN TIED OBSERVATIONS
C	   AVERAGE OF TIED RANKS
C
5	CALL RANK (A,R,N)
	CALL RANK (B,R(N+1),N)
	GO TO 40
C
C	   MOVE RANKED DATA TO R VECTOR
C
10	DO 20 I=1,N
20	R(I)=A(I)
	DO 30 I=1,N
	J=I+N
30	R(J)=B(I)
C
C	   SORT RANK VECTOR R IN SEQUENCE OF VARIABLE A
C
40	ISORT=0
	DO 50 I=2,N
	IF(R(I)-R(I-1)) 45,50,50
45	ISORT=ISORT+1
	RSAVE=R(I)
	R(I)=R(I-1)
	R(I-1)=RSAVE
	I2=I+N
	SAVER=R(I2)
	R(I2)=R(I2-1)
	R(I2-1)=SAVER
50	CONTINUE
	IF(ISORT) 40,55,40
C
C	   COMPUTE S ON VARIABLE B. STARTING WITH THE FIRST RANK, ADD 1
C	   TO S FOR EACH LARGER RANK TO ITS RIGHT AND SUBTRACT 1 FOR EACH
C	   SMALLER RANK.  REPEAT FOR ALL RANKS.
C
55	S=0.0
	NM=N-1
	DO 60 I=1,NM
	J=N+I
	DO 60 L=I,N
	K=N+L
	IF(R(I)-R(L))58,60,58
58	  IF(R(K)-R(J)) 56,60,57
56	S=S-1.0
	GO TO 60
57	S=S+1.0
60	CONTINUE
C
C	   COMPUTE TIED SCORE INDEX FOR BOTH VARIABLES
C
	KT=2
	CALL TIE(R,N,KT,TA)
	CALL TIE(R(N+1),N,KT,TB)
C
C	   COMPUTE TAU
C
	IF(TA) 70,65,70
65	IF(TB) 70,67,70
67	TAU=S/(0.5*FN1)
	GO TO 80
70	TAU=S/((SQRT(0.5*FN1-TA))*(SQRT(0.5*FN1-TB)))
C
C	COMPUTE STANDARD DEVIATION AND Z IF N IS 10 OR LARGER
C
80	IF(N-10) 90,85,85
85	SD=(SQRT((2.0*(FN+FN+5.0))/(9.0*FN1)))
	Z=TAU/SD
90	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LAP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE LAGUERRE POLYNOMIALS L(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL LAP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF LAGUERRE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF LAGUERRE POLYNOMIAL
C	      N     - ORDER OF LAGUERRE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      LAGUERRE POLYNOMIALS L(N,X)
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE L(0,X)=1, L(1,X)=1.-X.
C
C	..................................................................
C
	SUBROUTINE LAP(Y,X,N)
C
	DIMENSION Y(1)
C
C	   TEST OF ORDER
	Y(1)=1.
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=1.-X
	IF(N-1)1,1,3
C
C	   INITIALIZATION
3	T=1.+X
C
	DO 4 I=2,N
4	Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/FLOAT(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LAPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LAGUERRE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL LAPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	      X     - ARGUMENT VALUE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR LAGUERRE POLYNOMIALS
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1).
C
C	..................................................................
C
	SUBROUTINE LAPS(Y,X,C,N)
C
	DIMENSION C(1)
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.
	H1=1.-X
	T=1.+X
C
	DO 4 I=2,N
	H2=H1-H0+H1-(T*H1-H0)/FLOAT(I)
	H0=H1
	H1=H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LBVP
C
C	   PURPOSE
C	      TO SOLVE A LINEAR BOUNDARY VALUE PROBLEM, WHICH CONSISTS OF
C	      A SYSTEM OF NDIM LINEAR FIRST ORDER DIFFERENTIAL EQUATIONS
C	             DY/DX=A(X)*Y(X)+F(X)
C	      AND NDIM LINEAR BOUNDARY CONDITIONS
C	             B*Y(XL)+C*Y(XU)=R.
C
C	   USAGE
C	      CALL LBVP (PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
C	                 AUX,A)
C	      PARAMETERS AFCT,FCT,DFCT,OUTP REQUIRE AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      PRMT   - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER
C	               OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF
C	               THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR
C	               COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED
C	               BY THE USER) AND SUBROUTINE LBVP.
C	               THE COMPONENTS ARE
C	      PRMT(1)- LOWER BOUND XL OF THE INTERVAL (INPUT),
C	      PRMT(1)- UPPER BOUND XU OF THE INTERVAL (INPUT),
C	      PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE
C	               (INPUT),
C	      PRMT(4)- UPPER ERROR BOUND (INPUT). IF RELATIVE ERROR IS
C	               GREATER THAN PRMT(4), INCREMENT GETS HALVED.
C	               IF INCREMENT IS LESS THAN PRMT(3) AND RELATIVE
C	               ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED.
C	               THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS
C	               OUTPUT SUBROUTINE.
C	      PRMT(5)- NO INPUT PARAMETER. SUBROUTINE LBVP INITIALIZES
C	               PRMT(5)=0. IF THE USER WANTS TO TERMINATE
C	               SUBROUTINE LBVP AT ANY OUTPUT POINT, HE HAS TO
C	               CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE
C	               OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE
C	               FEASIBLE IF ITS DIMENSION IS DEFINED GREATER
C	               THAN 5. HOWEVER SUBROUTINE LBVP DOES NOT REQUIRE
C	               AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL
C	               FOR HANDING RESULT VALUES TO THE MAIN PROGRAM
C	               (CALLING LBVP) WHICH ARE OBTAINED BY SPECIAL
C	               MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP.
C	      B      - AN NDIM BY NDIM INPUT MATRIX.  (DESTROYED)
C	               IT IS THE COEFFICIENT MATRIX OF Y(XL) IN
C	               THE BOUNDARY CONDITIONS.
C	      C      - AN NDIM BY NDIM INPUT MATRIX (POSSIBLY DESTROYED).
C	               IT IS THE COEFFICIENT MATRIX OF Y(XU) IN
C	               THE BOUNDARY CONDITIONS.
C	      R      - AN INPUT VECTOR WITH DIMENSION NDIM.  (DESTROYED)
C	               IT SPECIFIES THE RIGHT HAND SIDE OF THE
C	               BOUNDARY CONDITIONS.
C	      Y      - AN AUXILIARY VECTOR WITH DIMENSION NDIM.
C	               IT IS USED AS STORAGE LOCATION FOR THE RESULTING
C	               VALUES OF DEPENDENT VARIABLES COMPUTED AT
C	               INTERMEDIATE POINTS.
C	      DERY   - INPUT VECTOR OF ERROR WEIGHTS.  (DESTROYED)
C	               ITS MAXIMAL COMPONENT SHOULD BE EQUAL TO 1.
C	               LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH
C	               BELONG TO FUNCTION VALUES Y AT INTERMEDIATE POINTS.
C	      NDIM   - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               DIFFERENTIAL EQUATIONS IN THE SYSTEM.
C	      IHLF   - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF
C	               BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS
C	               GREATER THAN 10, SUBROUTINE LBVP RETURNS WITH
C	               ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM.
C	               ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE
C	               PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)-
C	               PRMT(1)) RESPECTIVELY. FINALLY ERROR MESSAGE
C	               IHLF=14 INDICATES, THAT THERE IS NO SOLUTION OR
C	               THAT THERE ARE MORE THAN ONE SOLUTION OF THE
C	               PROBLEM.
C	               A NEGATIVE VALUE OF IHLF HANDED TO SUBROUTINE OUTP
C	               TOGETHER WITH INITIAL VALUES OF FINALLY GENERATED
C	               INITIAL VALUE PROBLEM INDICATES, THAT THERE WAS
C	               POSSIBLE LOSS OF SIGNIFICANCE IN THE SOLUTION OF
C	               THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS FOR
C	               THESE INITIAL VALUES. THE ABSOLUTE VALUE OF IHLF
C	               SHOWS, AFTER WHICH ELIMINATION STEP OF GAUSS
C	               ALGORITHM POSSIBLE LOSS OF SIGNIFICANCE WAS
C	               DETECTED.
C	      AFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES THE COEFFICIENT MATRIX A OF VECTOR Y ON
C	               THE RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
C	               EQUATIONS FOR A GIVEN X-VALUE. ITS PARAMETER LIST
C	               MUST BE X,A. SUBROUTINE AFCT SHOULD NOT DESTROY X.
C	      FCT    - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE
C	               RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL
C	               EQUATIONS) FOR A GIVEN X-VALUE. ITS PARAMETER LIST
C	               MUST BE X,F. SUBROUTINE FCT SHOULD NOT DESTROY X.
C	      DFCT   - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT
C	               COMPUTES VECTOR DF (DERIVATIVE OF THE INHOMOGENEOUS
C	               PART ON THE RIGHT HAND SIDE OF THE SYSTEM OF
C	               DIFFERENTIAL EQUATIONS) FOR A GIVEN X-VALUE. ITS
C	               PARAMETER LIST MUST BE X,DF. SUBROUTINE DFCT
C	               SHOULD NOT DESTROY X.
C	      OUTP   - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED.
C	               ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT.
C	               NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY,
C	               PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY
C	               SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO,
C	               SUBROUTINE LBVP IS TERMINATED.
C	      AUX    - AN AUXILIARY STORAGE ARRAY WIRH 20 ROWS AND
C	               NDIM COLUMNS.
C	      A      - AN NDIM BY NDIM MATRIX, WHICH IS USED AS AUXILIARY
C	               STORAGE ARRAY.
C
C	   REMARKS
C	      THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF
C	      (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE
C	          NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE
C	          IHLF=11),
C	      (2) INITIAL INCREMENT IS EQUAL TO 0 OR IF IT HAS WRONG SIGN
C	          (ERROR MESSAGES IHLF=12 OR IHLF=13),
C	      (3) THERE IS NO OR MORE THAN ONE SOLUTION OF THE PROBLEM
C	          (ERROR MESSAGE IHLF=14),
C	      (4) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH,
C	      (5) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SUBROUTINE GELG     SYSTEM OF LINEAR EQUATIONS.
C	      THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F), DFCT(X,DF),
C	      AND OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE USING THE METHOD OF ADJOINT EQUATIONS.
C	      HAMMINGS FOURTH ORDER MODIFIED PREDICTOR-CORRECTOR METHOD
C	      IS USED TO SOLVE THE ADJOINT INITIAL VALUE PROBLEMS AND FI-
C	      NALLY TO SOLVE THE GENERATED INITIAL VALUE PROBLEM FOR Y(X).
C	      THE INITIAL INCREMENT PRMT(3) IS AUTOMATICALLY ADJUSTED.
C	      FOR COMPUTATION OF INTEGRAL SUM, A FOURTH ORDER HERMITEAN
C	      INTEGRATION FORMULA IS USED.
C	      FOR REFERENCE, SEE
C	      (1) LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
C	          ILIFFE, LONDON, 1960, PP.64-67.
C	      (2) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL
C	          COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109.
C	      (3) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS,
C	          MTAC, VOL.16, ISS.80 (1962), PP.431-437.
C	      (4) ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-232.
C
C	..................................................................
C
	SUBROUTINE LBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP,
     1AUX,A)
C
	DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1)
C
C	ERROR TEST
	IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3
1	IHLF=12
	RETURN
2	IHLF=13
	RETURN
C
C	SEARCH FOR ZERO-COLUMNS IN MATRICES B AND C
3	KK=-NDIM
	IB=0
	IC=0
	DO 7 K=1,NDIM
	AUX(15,K)=DERY(K)
	AUX(1,K)=1.
	AUX(17,K)=1.
	KK=KK+NDIM
	DO 4 I=1,NDIM
	II=KK+I
	IF(B(II))5,4,5
4	CONTINUE
	IB=IB+1
	AUX(1,K)=0.
5	DO 6 I=1,NDIM
	II=KK+I
	IF(C(II))7,6,7
6	CONTINUE
	IC=IC+1
	AUX(17,K)=0.
7	CONTINUE
C
C	DETERMINATION OF LOWER AND UPPER BOUND
	IF(IC-IB)8,11,11
8	H=PRMT(2)
	PRMT(2)=PRMT(1)
	PRMT(1)=H
	PRMT(3)=-PRMT(3)
	DO 9 I=1,NDIM
9	AUX(17,I)=AUX(1,I)
	II=NDIM*NDIM
	DO 10 I=1,II
	H=B(I)
	B(I)=C(I)
10	C(I)=H
C
C	PREPARATIONS FOR CONSTRUCTION OF ADJOINT INITIAL VALUE PROBLEMS
11	X=PRMT(2)
	CALL FCT(X,Y)
	CALL DFCT(X,DERY)
	DO 12 I=1,NDIM
	AUX(18,I)=Y(I)
12	AUX(19,I)=DERY(I)
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	THE FOLLOWING PART OF SUBROUTINE LBVP UNTIL NEXT BREAK-POINT FOR
C	LINKAGE HAS TO REMAIN IN CORE DURING THE WHOLE REST OF THE
C	COMPUTATIONS
C
C	START LOOP FOR GENERATING ADJOINT INITIAL VALUE PROBLEMS
	K=0
	KK=0
100	K=K+1
	IF(AUX(17,K))108,108,101
C
C	INITIALIZATION OF ADJOINT INITIAL VALUE PROBLEM
101	X=PRMT(2)
	CALL AFCT(X,A)
	SUM=0.
	GL=AUX(18,K)
	DGL=AUX(19,K)
	II=K
	DO 104 I=1,NDIM
	H=-A(II)
	DERY(I)=H
	AUX(20,I)=R(I)
	Y(I)=0.
	IF(I-K)103,102,103
102	Y(I)=1.
103	DGL=DGL+H*AUX(18,I)
104	II=II+NDIM
	XEND=PRMT(1)
	H=.0625*(XEND-X)
	ISW=0
	GOTO 400
C	THIS IS BRANCH TO ADJOINT LINEAR INITIAL VALUE PROBLEM
C
C	THIS IS RETURN FROM ADJOINT LINEAR INITIAL VALUE PROBLEM
105	IF(IHLF-10)106,106,117
C
C	UPDATING OF COEFFICIENT MATRIX B AND VECTOR R
106	DO 107 I=1,NDIM
	KK=KK+1
	H=C(KK)
	R(I)=AUX(20,I)+H*SUM
	II=I
	DO 107 J=1,NDIM
	B(II)=B(II)+H*Y(J)
107	II=II+NDIM
	GOTO 109
108	KK=KK+NDIM
109	IF(K-NDIM)100,110,110
C
C	GENERATION OF LAST INITIAL VALUE PROBLEM
110	X=PRMT(4)
	CALL GELG(R,B,NDIM,1,X,I)
	IF(I)111,112,112
111	IHLF=14
	RETURN
C
112	PRMT(5)=0.
	IHLF=-I
	X=PRMT(1)
	XEND=PRMT(2)
	H=PRMT(3)
	DO 113 I=1,NDIM
113	Y(I)=R(I)
	ISW=1
114	ISW2=12
	GOTO 200
115	ISW3=-1
	GOTO 300
116	IF(IHLF)400,400,117
C	THIS WAS BRANCH INTO INITIAL VALUE PROBLEM
C
C	THIS IS RETURN FROM INITIAL VALUE PROBLEM
117	RETURN
C
C	THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE RIGHT
C	HAND SIDE DERY OF THE SYSTEM OF ADJOINT LINEAR DIFFERENTIAL
C	EQUATIONS (IN CASE ISW=0) OR OF THE GIVEN SYSTEM (IN CASE ISW=1).
200	CALL AFCT(X,A)
	IF(ISW)201,201,205
C
C	ADJOINT SYSTEM
201	LL=0
	DO 203 M=1,NDIM
	HS=0.
	DO 202 L=1,NDIM
	LL=LL+1
202	HS=HS-A(LL)*Y(L)
203	DERY(M)=HS
204	GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2
C
C	GIVEN SYSTEM
205	CALL FCT(X,DERY)
	DO 207 M=1,NDIM
	LL=M-NDIM
	HS=0.
	DO 206 L=1,NDIM
	LL=LL+NDIM
206	HS=HS+A(LL)*Y(L)
207	DERY(M)=HS+DERY(M)
	GOTO 204
C
C	THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE VALUE OF
C	INTEGRAL SUM, WHICH IS A PART OF THE OUTPUT OF ADJOINT INITIAL
C	VALUE PROBLEM (IN CASE ISW=0) OR RECORDS RESULT VALUES OF THE
C	FINAL INITIAL VALUE PROBLEM (IN CASE ISW=1).
300	IF(ISW)301,301,305
C
C	ADJOINT PROBLEM
301	CALL FCT(X,R)
	GU=0.
	DGU=0.
	DO 302 L=1,NDIM
	GU=GU+Y(L)*R(L)
302	DGU=DGU+DERY(L)*R(L)
	CALL DFCT(X,R)
	DO 303 L=1,NDIM
303	DGU=DGU+Y(L)*R(L)
	SUM=SUM+.5*H*((GL+GU)+.1666667*H*(DGL-DGU))
	GL=GU
	DGL=DGU
304	IF(ISW3)116,422,618
C
C	GIVEN PROBLEM
305	CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT)
	IF(PRMT(5))117,304,117
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	THE FOLLOWING PART OF SUBROUTINE LBVP SOLVES IN CASE ISW=0 THE
C	ADJOINT INITIAL VALUE PROBLEM. IT COMPUTES INTEGRAL SUM AND
C	THE VECTOR Y OF DEPENDENT VARIABLES AT THE LOWER BOUND PRMT(1).
C	IN CASE ISW=1 IT SOLVES FINALLY GENERATED INITIAL VALUE PROBLEM.
400	N=1
	XST=X
	IHLF=0
	DO 401 I=1,NDIM
	AUX(16,I)=0.
	AUX(1,I)=Y(I)
401	AUX(8,I)=DERY(I)
	ISW1=1
	GOTO 500
C
402	X=X+H
	DO 403 I=1,NDIM
403	AUX(2,I)=Y(I)
C
C	INCREMENT H IS TESTED BY MEANS OF BISECTION
404	IHLF=IHLF+1
	X=X-H
	DO 405 I=1,NDIM
405	AUX(4,I)=AUX(2,I)
	H=.5*H
	N=1
	ISW1=2
	GOTO 500
C
406	X=X+H
	ISW2=4
	GOTO 200
407	N=2
	DO 408 I=1,NDIM
	AUX(2,I)=Y(I)
408	AUX(9,I)=DERY(I)
	ISW1=3
	GOTO 500
C
C	TEST ON SATISFACTORY ACCURACY
409	DO 414 I=1,NDIM
	Z=ABS(Y(I))
	IF(Z-1.)410,411,411
410	Z=1.
411	DELT=.06666667*ABS(Y(I)-AUX(4,I))
	IF(ISW)413,413,412
412	DELT=AUX(15,I)*DELT
413	IF(DELT-Z*PRMT(4))414,414,429
414	CONTINUE
C
C	SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS
	X=X+H
	ISW2=5
	GOTO 200
415	DO 416 I=1,NDIM
	AUX(3,I)=Y(I)
416	AUX(10,I)=DERY(I)
	N=3
	ISW1=4
	GOTO 500
C
417	N=1
	X=X+H
	ISW2=6
	GOTO 200
418	X=XST
	DO 419 I=1,NDIM
	AUX(11,I)=DERY(I)
  419	Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I)
     1-.2083333*AUX(10,I)+.04166667*DERY(I))
420	X=X+H
	N=N+1
	ISW2=11
	GOTO 200
421	ISW3=0
	GOTO 300
422	IF(N-4)423,600,600
423	DO 424 I=1,NDIM
	AUX(N,I)=Y(I)
424	AUX(N+7,I)=DERY(I)
	IF(N-3)425,427,600
C
425	DO 426 I=1,NDIM
	DELT=AUX(9,I)+AUX(9,I)
	DELT=DELT+DELT
426	Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I))
	GOTO 420
C
427	DO 428 I=1,NDIM
	DELT=AUX(9,I)+AUX(10,I)
	DELT=DELT+DELT+DELT
428	Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I))
	GOTO 420
C
C	NO SATISFACTORY ACCURACY. H MUST BE HALVED.
429	IF(IHLF-10)404,430,430
C
C	NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE.
430	IHLF=11
	X=X+H
	IF(ISW)105,105,114
C
C	THIS PART OF LINEAR INITIAL VALUE PROBLEM COMPUTES
C	STARTING VALUES BY MEANS OF RUNGE-KUTTA METHOD.
500	Z=X
	DO 501 I=1,NDIM
	X=H*AUX(N+7,I)
	AUX(5,I)=X
501	Y(I)=AUX(N,I)+.4*X
C
	X=Z+.4*H
	ISW2=1
	GOTO 200
502	DO 503 I=1,NDIM
	X=H*DERY(I)
	AUX(6,I)=X
503	Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X
C
	X=Z+.4557372*H
	ISW2=2
	GOTO 200
504	DO 505 I=1,NDIM
	X=H*DERY(I)
	AUX(7,I)=X
505	Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X
C
	X=Z+H
	ISW2=3
	GOTO 200
506	DO 507 I=1,NDIM
  507	Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I)
     1+1.205536*AUX(7,I)+.1711848*H*DERY(I)
	X=Z
	GOTO(402,406,409,417),ISW1
C
C	POSSIBLE BREAK-POINT FOR LINKAGE
C
C	STARTING VALUES ARE COMPUTED.
C	NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD.
600	ISTEP=3
601	IF(N-8)604,602,604
C
C	N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS
602	DO 603 N=2,7
	DO 603 I=1,NDIM
	AUX(N-1,I)=AUX(N,I)
603	AUX(N+6,I)=AUX(N+7,I)
	N=7
C
C	N LESS THAN 8 CAUSES N+1 TO GET N
604	N=N+1
C
C	COMPUTATION OF NEXT VECTOR Y
	DO 605 I=1,NDIM
	AUX(N-1,I)=Y(I)
605	AUX(N+6,I)=DERY(I)
	X=X+H
606	ISTEP=ISTEP+1
	DO 607 I=1,NDIM
	DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+
     1AUX(N+4,I)+AUX(N+4,I))
	Y(I)=DELT-.9256198*AUX(16,I)
607	AUX(16,I)=DELT
C	PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR
C	IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE.
C
	ISW2=7
	GOTO 200
C	DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY.
C
608	DO 609 I=1,NDIM
	DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+
     1AUX(N+6,I)-AUX(N+5,I)))
	AUX(16,I)=AUX(16,I)-DELT
609	Y(I)=DELT+.07438017*AUX(16,I)
C
C	TEST WHETHER H MUST BE HALVED OR DOUBLED
	DELT=0.
	DO 616 I=1,NDIM
	Z=ABS(Y(I))
	IF(Z-1.)610,611,611
610	Z=1.
611	Z=ABS(AUX(16,I))/Z
	IF(ISW)613,613,612
612	Z=AUX(15,I)*Z
613	IF(Z-PRMT(4))614,614,628
614	IF(DELT-Z)615,616,616
615	DELT=Z
616	CONTINUE
C
C	H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD.
	ISW2=8
	GOTO 200
617	ISW3=1
	GOTO 300
618	IF(H*(X-XEND))619,621,621
619	IF(ABS(X-XEND)-.1*ABS(H))621,620,620
620	IF(DELT-.02*PRMT(4))622,622,601
621	IF(ISW)105,105,117
C
C
C	H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE
C	AVAILABLE.
622	IF(IHLF)601,601,623
623	IF(N-7)601,624,624
624	IF(ISTEP-4)601,625,625
625	IMOD=ISTEP/2
	IF(ISTEP-IMOD-IMOD)601,626,601
626	H=H+H
	IHLF=IHLF-1
	ISTEP=0
	DO 627 I=1,NDIM
	AUX(N-1,I)=AUX(N-2,I)
	AUX(N-2,I)=AUX(N-4,I)
	AUX(N-3,I)=AUX(N-6,I)
	AUX(N+6,I)=AUX(N+5,I)
	AUX(N+5,I)=AUX(N+3,I)
	AUX(N+4,I)=AUX(N+1,I)
	DELT=AUX(N+6,I)+AUX(N+5,I)
	DELT=DELT+DELT+DELT
  627	AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT
     1+AUX(N+4,I))
	GOTO 601
C
C
C	H MUST BE HALVED
628	IHLF=IHLF+1
	IF(IHLF-10)630,630,629
629	IF(ISW)105,105,114
630	H=.5*H
	ISTEP=0
	DO 631 I=1,NDIM
	Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+
     1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H
	AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+
     1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)-
     29.*AUX(N+4,I))*H
	AUX(N-3,I)=AUX(N-2,I)
631	AUX(N+4,I)=AUX(N+5,I)
	DELT=X-H
	X=DELT-(H+H)
	ISW2=9
	GOTO 200
632	DO 633 I=1,NDIM
	AUX(N-2,I)=Y(I)
	AUX(N+5,I)=DERY(I)
633	Y(I)=AUX(N-4,I)
	X=X-(H+H)
	ISW2=10
	GOTO 200
634	X=DELT
	DO 635 I=1,NDIM
	DELT=AUX(N+5,I)+AUX(N+4,I)
	DELT=DELT+DELT+DELT
	AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT
     1+DERY(I))
635	AUX(N+3,I)=DERY(I)
	GOTO 606
C
C	END OF INITIAL VALUE PROBLEM
	END
C
C	..................................................................
C
C	   SUBROUTINE LEP
C
C	   PURPOSE
C	      COMPUTE THE VALUES OF THE LEGENDRE POLYNOMIALS P(N,X)
C	      FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N.
C
C	   USAGE
C	      CALL LEP(Y,X,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES
C	              OF LEGENDRE POLYNOMIALS OF ORDER 0 UP TO N
C	              FOR GIVEN ARGUMENT X.
C	              VALUES ARE ORDERED FROM LOW TO HIGH ORDER
C	      X     - ARGUMENT OF LEGENDRE POLYNOMIAL
C	      N     - ORDER OF LEGENDRE POLYNOMIAL
C
C	   REMARKS
C	      N LESS THAN 0 IS TREATED AS IF N WERE 0
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      LEGENDRE POLYNOMIALS P(N,X)
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE ORDER,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
C
C	..................................................................
C
	SUBROUTINE LEP(Y,X,N)
C
	DIMENSION Y(1)
C
C	   TEST OF ORDER
	Y(1)=1.
	IF(N)1,1,2
1	RETURN
C
2	Y(2)=X
	IF(N-1)1,1,3
C
3	DO 4 I=2,N
	G=X*Y(I)
4	Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/FLOAT(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LEPS
C
C	   PURPOSE
C	      COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LEGENDRE
C	      POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X.
C
C	   USAGE
C	      CALL LEPS(Y,X,C,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - RESULT VALUE
C	      X     - ARGUMENT VALUE
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR C
C
C	   REMARKS
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      Y=SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
C	      EVALUATION IS DONE BY MEANS OF UPWARD RECURSION
C	      USING THE RECURRENCE EQUATION FOR LEGENDRE POLYNOMIALS
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1).
C
C	..................................................................
C
	SUBROUTINE LEPS(Y,X,C,N)
C
	DIMENSION C(1)
C
C	   TEST OF DIMENSION
	IF(N)1,1,2
1	RETURN
C
2	Y=C(1)
	IF(N-2)1,3,3
C
C	   INITIALIZATION
3	H0=1.
	H1=X
C
	DO 4 I=2,N
	H2=X*H1
	H2=H2-H0+H2-(H2-H0)/FLOAT(I)
	H0=H1
	H1=H2
4	Y=Y+C(I)*H0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LLSQ
C
C	   PURPOSE
C	      TO SOLVE LINEAR LEAST SQUARES PROBLEMS, I.E. TO MINIMIZE
C	      THE EUCLIDEAN NORM OF B-A*X, WHERE A IS A M BY N MATRIX
C	      WITH M NOT LESS THAN N. IN THE SPECIAL CASE M=N SYSTEMS OF
C	      LINEAR EQUATIONS MAY BE SOLVED.
C
C	   USAGE
C	      CALL LLSQ (A,B,M,N,L,X,IPIV,EPS,IER,AUX)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - M BY N COEFFICIENT MATRIX (DESTROYED).
C	      B      - M BY L RIGHT HAND SIDE MATRIX (DESTROYED).
C	      M      - ROW NUMBER OF MATRICES A AND B.
C	      N      - COLUMN NUMBER OF MATRIX A, ROW NUMBER OF MATRIX X.
C	      L      - COLUMN NUMBER OF MATRICES B AND X.
C	      X      - N BY L SOLUTION MATRIX.
C	      IPIV   - INTEGER OUTPUT VECTOR OF DIMENSION N WHICH
C	               CONTAINS INFORMATIONS ON COLUMN INTERCHANGES
C	               IN MATRIX A. (SEE REMARK NO.3).
C	      EPS    - INPUT PARAMETER WHICH SPECIFIES A RELATIVE
C	               TOLERANCE FOR DETERMINATION OF RANK OF MATRIX A.
C	      IER    - A RESULTING ERROR PARAMETER.
C	      AUX    - AUXILIARY STORAGE ARRAY OF DIMENSION MAX(2*N,L).
C	               ON RETURN FIRST L LOCATIONS OF AUX CONTAIN THE
C	               RESULTING LEAST SQUARES.
C
C	   REMARKS
C	      (1) NO ACTION BESIDES ERROR MESSAGE IER=-2 IN CASE
C	          M LESS THAN N.
C	      (2) NO ACTION BESIDES ERROR MESSAGE IER=-1 IN CASE
C	          OF A ZERO-MATRIX A.
C	      (3) IF RANK K OF MATRIX A IS FOUND TO BE LESS THAN N BUT
C	          GREATER THAN 0, THE PROCEDURE RETURNS WITH ERROR CODE
C	          IER=K INTO CALLING PROGRAM. THE LAST N-K ELEMENTS OF
C	          VECTOR IPIV DENOTE THE USELESS COLUMNS IN MATRIX A.
C	          THE REMAINING USEFUL COLUMNS FORM A BASE OF MATRIX A.
C	      (4) IF THE PROCEDURE WAS SUCCESSFUL, ERROR PARAMETER IER
C	          IS SET TO 0.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      HOUSEHOLDER TRANSFORMATIONS ARE USED TO TRANSFORM MATRIX A
C	      TO UPPER TRIANGULAR FORM. AFTER HAVING APPLIED THE SAME
C	      TRANSFORMATION TO THE RIGHT HAND SIDE MATRIX B, AN
C	      APPROXIMATE SOLUTION OF THE PROBLEM IS COMPUTED BY
C	      BACK SUBSTITUTION. FOR REFERENCE, SEE
C	      G. GOLUB, NUMERICAL METHODS FOR SOLVING LINEAR LEAST
C	      SQUARES PROBLEMS, NUMERISCHE MATHEMATIK, VOL.7,
C	      ISS.3 (1965), PP.206-216.
C
C	..................................................................
C
	SUBROUTINE LLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX)
C
	DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1)
C
C	ERROR TEST
	IF(M-N)30,1,1
C
C	GENERATION OF INITIAL VECTOR S(K) (K=1,2,...,N) IN STORAGE
C	LOCATIONS AUX(K) (K=1,2,...,N)
1	PIV=0.
	IEND=0
	DO 4 K=1,N
	IPIV(K)=K
	H=0.
	IST=IEND+1
	IEND=IEND+M
	DO 2 I=IST,IEND
2	H=H+A(I)*A(I)
	AUX(K)=H
	IF(H-PIV)4,4,3
3	PIV=H
	KPIV=K
4	CONTINUE
C
C	ERROR TEST
	IF(PIV)31,31,5
C
C	DEFINE TOLERANCE FOR CHECKING RANK OF A
5	SIG=SQRT(PIV)
	TOL=SIG*ABS(EPS)
C
C
C	DECOMPOSITION LOOP
	LM=L*M
	IST=-M
	DO 21 K=1,N
	IST=IST+M+1
	IEND=IST+M-K
	I=KPIV-K
	IF(I)8,8,6
C
C	INTERCHANGE K-TH COLUMN OF A WITH KPIV-TH IN CASE KPIV.GT.K
6	H=AUX(K)
	AUX(K)=AUX(KPIV)
	AUX(KPIV)=H
	ID=I*M
	DO 7 I=IST,IEND
	J=I+ID
	H=A(I)
	A(I)=A(J)
7	A(J)=H
C
C	COMPUTATION OF PARAMETER SIG
8	IF(K-1)11,11,9
9	SIG=0.
	DO 10 I=IST,IEND
10	SIG=SIG+A(I)*A(I)
	SIG=SQRT(SIG)
C
C	TEST ON SINGULARITY
	IF(SIG-TOL)32,32,11
C
C	GENERATE CORRECT SIGN OF PARAMETER SIG
11	H=A(IST)
	IF(H)12,13,13
12	SIG=-SIG
C
C	SAVE INTERCHANGE INFORMATION
13	IPIV(KPIV)=IPIV(K)
	IPIV(K)=KPIV
C
C	GENERATION OF VECTOR UK IN K-TH COLUMN OF MATRIX A AND OF
C	PARAMETER BETA
	BETA=H+SIG
	A(IST)=BETA
	BETA=1./(SIG*BETA)
	J=N+K
	AUX(J)=-SIG
	IF(K-N)14,19,19
C
C	TRANSFORMATION OF MATRIX A
14	PIV=0.
	ID=0
	JST=K+1
	KPIV=JST
	DO 18 J=JST,N
	ID=ID+M
	H=0.
	DO 15 I=IST,IEND
	II=I+ID
15	H=H+A(I)*A(II)
	H=BETA*H
	DO 16 I=IST,IEND
	II=I+ID
16	A(II)=A(II)-A(I)*H
C
C	UPDATING OF ELEMENT S(J) STORED IN LOCATION AUX(J)
	II=IST+ID
	H=AUX(J)-A(II)*A(II)
	AUX(J)=H
	IF(H-PIV)18,18,17
17	PIV=H
	KPIV=J
18	CONTINUE
C
C	TRANSFORMATION OF RIGHT HAND SIDE MATRIX B
19	DO 21 J=K,LM,M
	H=0.
	IEND=J+M-K
	II=IST
	DO 20 I=J,IEND
	H=H+A(II)*B(I)
20	II=II+1
	H=BETA*H
	II=IST
	DO 21 I=J,IEND
	B(I)=B(I)-A(II)*H
21	II=II+1
C	END OF DECOMPOSITION LOOP
C
C
C	BACK SUBSTITUTION AND BACK INTERCHANGE
	IER=0
	I=N
	LN=L*N
	PIV=1./AUX(2*N)
	DO 22 K=N,LN,N
	X(K)=PIV*B(I)
22	I=I+M
	IF(N-1)26,26,23
23	JST=(N-1)*M+N
	DO 25 J=2,N
	JST=JST-M-1
	K=N+N+1-J
	PIV=1./AUX(K)
	KST=K-N
	ID=IPIV(KST)-KST
	IST=2-J
	DO 25 K=1,L
	H=B(KST)
	IST=IST+N
	IEND=IST+J-2
	II=JST
	DO 24 I=IST,IEND
	II=II+M
24	H=H-A(II)*X(I)
	I=IST-1
	II=I+ID
	X(I)=X(II)
	X(II)=PIV*H
25	KST=KST+M
C
C
C	COMPUTATION OF LEAST SQUARES
26	IST=N+1
	IEND=0
	DO 29 J=1,L
	IEND=IEND+M
	H=0.
	IF(M-N)29,29,27
27	DO 28 I=IST,IEND
28	H=H+B(I)*B(I)
	IST=IST+M
29	AUX(J)=H
	RETURN
C
C	ERROR RETURN IN CASE M LESS THAN N
30	IER=-2
	RETURN
C
C	ERROR RETURN IN CASE OF ZERO-MATRIX A
31	IER=-1
	RETURN
C
C	ERROR RETURN IN CASE OF RANK OF MATRIX A LESS THAN N
32	IER=K-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE LOAD
C
C	   PURPOSE
C	      COMPUTE A FACTOR MATRIX (LOADING) FROM EIGENVALUES AND
C	      ASSOCIATED EIGENVECTORS.  THIS SUBROUTINE NORMALLY OCCURS
C	      IN A SEQUENCE OF CALLS TO SUBROUTINES CORRE, EIGEN, TRACE,
C	      LOAD, AND VARMX IN THE PERFORMANCE OF A FACTOR ANALYSIS.
C
C	   USAGE
C	      CALL LOAD (M,K,R,V)
C
C	   DESCRIPTION OF PARAMETERS
C	      M     - NUMBER OF VARIABLES.
C	      K     - NUMBER OF FACTORS. K MUST BE GREATER THAN OR EQUAL
C	              TO 1 AND LESS THAN OR EQUAL TO M.
C	      R     - A MATRIX (SYMMETRIC AND STORED IN COMPRESSED FORM
C	              WITH ONLY UPPER TRIANGLE BY COLUMN IN CORE) CON-
C	              TAINING EIGENVALUES IN DIAGONAL.  EIGENVALUES ARE
C	              ARRANGED IN DESCENDING ORDER, AND FIRST K
C	              EIGENVALUES ARE USED BY THIS SUBROUTINE.  THE ORDER
C	              OF MATRIX R IS M BY M.  ONLY M*(M+1)/2 ELEMENTS ARE
C	              IN STORAGE.  (STORAGE MODE OF 1)
C	      V     - WHEN THIS SUBROUTINE IS CALLED, MATRIX V (M X M)
C	              CONTAINS EIGENVECTORS COLUMNWISE.  UPON RETURNING TO
C	              THE CALLING PROGRAM, MATRIX V CONTAINS A FACTOR
C	              MATRIX (M X K).
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      NORMALIZED EIGENVECTORS ARE CONVERTED TO THE FACTOR PATTERN
C	      BY MULTIPLYING THE ELEMENTS OF EACH VECTOR BY THE SQUARE
C	      ROOT OF THE CORRESPONDING EIGENVALUE.
C
C	..................................................................
C
	SUBROUTINE LOAD (M,K,R,V)
	DIMENSION R(1),V(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION R,V,SQ
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENT
C	   150 MUST BE CHANGED TO DSQRT.
C
C	   ...............................................................
C
	L=0
	JJ=0
	DO 160 J=1,K
	JJ=JJ+J
150	SQ= SQRT(R(JJ))
	DO 160 I=1,M
	L=L+1
160	V(L)=SQ*V(L)
	RETURN
	END
C
C     ..................................................................
C
C        SUBROUTINE LOC
C
C        PURPOSE
C           COMPUTE A VECTOR SUBSCRIPT FOR AN ELEMENT IN A MATRIX OF
C           SPECIFIED STORAGE MODE
C
C        USAGE
C           CALL LOC (I,J,IR,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           I   - ROW NUMBER OF ELEMENT
C           J   - COLUMN NUMBER  OF ELEMENT
C           IR  - RESULTANT VECTOR SUBSCRIPT
C           N   - NUMBER OF ROWS IN MATRIX
C           M   - NUMBER OF COLUMNS IN MATRIX
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           MS=0   SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N*M ELEMENTS
C                  IN STORAGE (GENERAL MATRIX)
C           MS=1   SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N*(N+1)/2 IN
C                  STORAGE (UPPER TRIANGLE OF SYMMETRIC MATRIX). IF
C                  ELEMENT IS IN LOWER TRIANGULAR PORTION, SUBSCRIPT IS
C                  CORRESPONDING ELEMENT IN UPPER TRIANGLE.
C           MS=2   SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N ELEMENTS
C                  IN STORAGE (DIAGONAL ELEMENTS OF DIAGONAL MATRIX).
C                  IF ELEMENT IS NOT ON DIAGONAL (AND THEREFORE NOT IN
C                  STORAGE), IR IS SET TO ZERO.
C
C     ..................................................................
C
      SUBROUTINE LOC(I,J,IR,N,M,MS)
C
      IX=I
      JX=J
      IF(MS-1) 10,20,30
   10 IRX=N*(JX-1)+IX
      GO TO 36
   20 IF(IX-JX) 22,24,24
   22 IRX=IX+(JX*JX-JX)/2
      GO TO 36
   24 IRX=JX+(IX*IX-IX)/2
      GO TO 36
   30 IRX=0
      IF(IX-JX) 36,32,36
   32 IRX=IX
   36 IR=IRX
      RETURN
      END
C
C	..................................................................
C
C	   SUBROUTINE MADD
C
C	   PURPOSE
C	      ADD TWO MATRICES ELEMENT BY ELEMENT TO FORM RESULTANT
C	      MATRIX
C
C	   USAGE
C	      CALL MADD(A,B,R,N,M,MSA,MSB)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      B - NAME OF INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A,B,R
C	      M - NUMBER OF COLUMNS IN A,B,R
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSB - SAME AS MSA EXCEPT FOR MATRIX B
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      STORAGE MODE OF OUTPUT MATRIX IS FIRST DETERMINED. ADDITION
C	      OF CORRESPONDING ELEMENTS IS THEN PERFORMED.
C	      THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT
C	      MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES
C	                    A                B                 R
C	                 GENERAL          GENERAL          GENERAL
C	                 GENERAL          SYMMETRIC        GENERAL
C	                 GENERAL          DIAGONAL         GENERAL
C	                 SYMMETRIC        GENERAL          GENERAL
C	                 SYMMETRIC        SYMMETRIC        SYMMETRIC
C	                 SYMMETRIC        DIAGONAL         SYMMETRIC
C	                 DIAGONAL         GENERAL          GENERAL
C	                 DIAGONAL         SYMMETRIC        SYMMETRIC
C	                 DIAGONAL         DIAGONAL         DIAGONAL
C
C	..................................................................
C
	SUBROUTINE MADD(A,B,R,N,M,MSA,MSB)
	DIMENSION A(1),B(1),R(1)
C
C	   DETERMINE STORAGE MODE OF OUTPUT MATRIX
C
	IF(MSA-MSB) 7,5,7
5	CALL LOC(N,M,NM,N,M,MSA)
	GO TO 100
7	MTEST=MSA*MSB
	MSR=0
	IF(MTEST) 20,20,10
10	MSR=1
20	IF(MTEST-2) 35,35,30
30	MSR=2
C
C	   LOCATE ELEMENTS AND PERFORM ADDITION
C
35	DO 90 J=1,M
	DO 90 I=1,N
	CALL LOC(I,J,IJR,N,M,MSR)
	IF(IJR) 40,90,40
40	CALL LOC(I,J,IJA,N,M,MSA)
	AEL=0.0
	IF(IJA) 50,60,50
50	AEL=A(IJA)
60	CALL LOC(I,J,IJB,N,M,MSB)
	BEL=0.0
	IF(IJB) 70,80,70
70	BEL=B(IJB)
80	R(IJR)=AEL+BEL
90	CONTINUE
	RETURN
C
C	   ADD MATRICES FOR OTHER CASES
C
100	DO 110 I=1,NM
110	R(I)=A(I)+B(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MATA
C
C	   PURPOSE
C	      PREMULTIPLY A MATRIX BY ITS TRANSPOSE TO FORM A
C	      SYMMETRIC MATRIX
C
C	   USAGE
C	      CALL MATA(A,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - NAME OF INPUT MATRIX
C	      R  - NAME OF OUTPUT MATRIX
C	      N  - NUMBER OF ROWS IN A
C	      M  - NUMBER OF COLUMNS IN A. ALSO NUMBER OF ROWS AND
C	           NUMBER OF COLUMNS OF R.
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX R IS ALWAYS A SYMMETRIC MATRIX WITH A STORAGE MODE=1
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      CALCULATION OF (A TRANSPOSE A) RESULTS IN A SYMMETRIC MATRIX
C	      REGARDLESS OF THE STORAGE MODE OF THE INPUT MATRIX. THE
C	      ELEMENTS OF MATRIX A ARE NOT CHANGED.
C
C	..................................................................
C
	SUBROUTINE MATA(A,R,N,M,MS)
	DIMENSION A(1),R(1)
C
	DO 60 K=1,M
	KX=(K*K-K)/2
	DO 60 J=1,M
	IF(J-K) 10,10,60
10	IR=J+KX
	R(IR)=0
	DO 60 I=1,N
	IF(MS) 20,40,20
20	CALL LOC(I,J,IA,N,M,MS)
	CALL LOC(I,K,IB,N,M,MS)
	IF(IA) 30,60,30
30	IF(IB) 50,60,50
40	IA=N*(J-1)+I
	IB=N*(K-1)+I
50	R(IR)=R(IR)+A(IA)*A(IB)
60	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MATIN
C
C	   PURPOSE
C	      READS CONTROL CARD AND MATRIX DATA ELEMENTS FROM LOGICAL
C	      UNIT 5
C
C	   USAGE
C	      CALL MATIN(ICODE,A,ISIZE,IROW,ICOL,IS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      ICODE-UPON RETURN, ICODE WILL CONTAIN FOUR DIGIT
C	            IDENTIFICATION CODE FROM MATRIX PARAMETER CARD
C	      A    -DATA AREA FOR INPUT MATRIX
C	      ISIZE-NUMBER OF ELEMENTS DIMENSIONED BY USER FOR AREA A
C	      IROW -UPON RETURN, IROW WILL CONTAIN ROW DIMENSION FROM
C	            MATRIX PARAMETER CARD
C	      ICOL -UPON RETURN, ICOL WILL CONTAIN COLUMN DIMENSION FROM
C	            MATRIX PARAMETER CARD
C	      IS   -UPON RETURN, IS WILL CONTAIN STORAGE MODE CODE FROM
C	            MATRIX PARAMETER CARD WHERE
C	            IS=0 GENERAL MATRIX
C	            IS=1 SYMMETRIC MATRIX
C	            IS=2 DIAGONAL MATRIX
C	      IER  -UPON RETURN, IER WILL CONTAIN AN ERROR CODE WHERE
C	            IER=0   NO ERROR
C	            IER=1   ISIZE IS LESS THAN NUMBER OF ELEMENTS IN
C	                    INPUT MATRIX
C	            IER=2   INCORRECT NUMBER OF DATA CARDS
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      SUBROUTINE ASSUMES THAT INPUT MATRIX CONSISTS OF PARAMETER
C	      CARD FOLLOWED BY DATA CARDS
C	      PARAMETER CARD HAS THE FOLLOWING FORMAT
C	        COL. 1- 2 BLANK
C	        COL. 3- 6 UP TO FOUR DIGIT IDENTIFICATION CODE
C	        COL. 7-10 NUMBER OF ROWS IN MATRIX
C	        COL.11-14 NUMBER OF COLUMNS IN MATRIX
C	        COL.15-16 STORAGE MODE OF MATRIX WHERE
C	            0 - GENERAL MATRIX
C	            1 - SYMMETRIC MATRIX
C	            2 - DIAGONAL MATRIX
C	      DATA CARDS ARE ASSUMED TO HAVE SEVEN FIELDS OF TEN COLUMNS
C	      EACH.  DECIMAL POINT MAY APPEAR ANYWHERE IN A FIELD.  IF NO
C	      DECIMAL POINT IS INCLUDED, IT IS ASSUMED THAT THE DECIMAL
C	      POINT IS AT THE END OF THE 10 COLUMN FIELD. NUMBER IN EACH
C	      FIELD MAY BE PRECEDED BY BLANKS.  DATA ELEMENTS MUST BE
C	      PUNCHED BY ROW.  A ROW MAY CONTINUE FROM CARD TO CARD.
C	      HOWEVER EACH NEW ROW MUST START IN THE FIRST FIELD OF THE
C	      NEXT CARD.  ONLY THE UPPER TRIANGULAR PORTION OF A SYMMETRIC
C	      OR THE DIAGONAL ELEMENTS OF A DIAGONAL MATRIX ARE CONTAINED
C	      ON DATA CARDS.  THE FIRST ELEMENT OF EACH NEW ROW WILL BE
C	      THE DIAGONAL ELEMENT FOR A MATRIX WITH  SYMMETRIC OR
C	      DIAGONAL STORAGE MODE. COLUMNS 71-80 OF DATA CARDS MAY BE
C	      USED FOR IDENTIFICATION, SEQUENCE NUMBERING, ETC..
C	      THE LAST DATA CARD FOR ANY MATRIX MUST BE FOLLOWED BY A CARD
C	      WITH A 9 PUNCH IN COLUMN 1.
C
C.......................................................................
C
	SUBROUTINE MATIN(ICODE,   A,ISIZE,IROW,ICOL,IS,IER)
	DIMENSION A(1)
	DIMENSION CARD(8)
	LOGICAL EOF
1	FORMAT(7F10.0)
2	FORMAT(I6,2I4,I2)
C
	IDC=7
	IER=0
	CALL CHKEOF (EOF)
	READ( 5,2)ICODE,IROW,ICOL,IS
	IF (EOF) GOTO 999
	CALL LOC(IROW,ICOL,ICNT,IROW,ICOL,IS)
	IF(ISIZE-ICNT)6,7,7
6	IER=1
7	IF (ICNT)38,38,8
8	ICOLT=ICOL
	IROCR=1
C
C	   COMPUTE NUMBER OF CARDS FOR THIS ROW
C
11	IRCDS=(ICOLT-1)/IDC+1
	IF(IS-1)15,15,12
12	IRCDS=1
C
C	   SET UP LOOP FOR NUMBER OF CARDS IN ROW
C
15	DO 31 K=1,IRCDS
	READ(5,1)(CARD(I),I=1,IDC)
C
C	   SKIP THROUGH DATA CARDS IF INPUT AREA TOO SMALL
C
	IF(IER)16,16,31
16	L=0
C
C	   COMPUTE COLUMN NUMBER FOR FIRST FIELD IN CURRENT CARD
C
	JS=(K-1)*IDC+ICOL-ICOLT+1
	JE=JS+IDC-1
	IF(IS-1)19,19,17
17	JE=JS
C
C	   SET UP LOOP FOR DATA ELEMENTS  WITHIN CARD
C
19	DO 30 J=JS,JE
	IF(J-ICOL)20,20,31
20	CALL LOC(IROCR ,J,IJ,IROW,ICOL,IS)
	L=L+1
30	A(IJ)=CARD(L)
31	CONTINUE
	IROCR=IROCR+1
	IF(IROW-IROCR) 38,35,35
35	IF(IS-1)37,36,36
36	ICOLT=ICOLT-1
37	GO TO 11
38	READ(5,1) CARD(1)
	CALL CHKEOF (EOF)
	IF (EOF) GOTO 999
	IF(CARD(1)-9.E9)39,40,39
39	IER=2
40	RETURN
999	STOP
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR CANONICAL CORRELATION - MCANO
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD FOR A CANONICAL
C	      CORRELATION, (2) CALL TWO SUBROUTINES TO CALCULATE SIMPLE
C	      CORRELATIONS, CANONICAL CORRELATIONS, CHI-SQUARES, DEGREES
C	      OF FREEDOM FOR CHI-SQUARES, AND COEFFICIENTS FOR LEFT AND
C	      RIGHT HAND VARIABLES, NAMELY CANONICAL VARIATES, AND (3)
C	      PRINT THE RESULTS.
C
C	   REMARKS
C	      THE NUMBER OF LEFT HAND VARIABLES MUST BE GREATER THAN
C	      OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      CORRE  (WHICH, IN TURN, CALLS THE INPUT SUBROUTINE NAMED
C	             DATA.)
C	      CANOR  (WHICH, IN TURN, CALLS THE SUBROUTINES MINV AND
C	             NROOT.  NROOT, IN TURN, CALLS THE SUBROUTINE EIGEN.)
C
C	   METHOD
C	      REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-
C	      CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,
C	      1962, CHAPTER 3.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
C	TOTAL NUMBER OF VARIABLES M (M=MP+MQ, WHERE MP IS THE NUMBER OF
C	LEFT HAND VARIABLES, AND MQ IS THE NUMBER OF RIGHT HAND VARI-
C	ABLES)..
cC
c	   DIMENSION XBAR(20),STD(20),CANR(20),CHISQ(20),NDF(20)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*M..
cC
c	   DIMENSION RX(400)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
cC	(M+1)*M/2..
cC
c	   DIMENSION R(210)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF MP*MQ..
cC
c	   DIMENSION COEFL(400)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF MQ*MQ..
cC
c	   DIMENSION COEFR(400)
cC
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION XBAR,STD,RX,R,CANR,CHISQ,COEFL,COEFR
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	   ...............................................................
cC
c1	FORMAT(A4,A2,I5,2I2)
c2	FORMAT(27H1CANONICAL CORRELATION.....,A4,A2//22H   NO. OF OBSERVAT
c     1IONS,8X,I4/29H   NO. OF LEFT HAND VARIABLES,I5/30H   NO. OF RIGHT
c     3HAND VARIABLES,I4/)
c3	FORMAT(6H0MEANS/(8F15.5))
c4	FORMAT(20H0STANDARD DEVIATIONS/(8F15.5))
c5	FORMAT(25H0CORRELATION COEFFICIENTS)
c6	FORMAT(4H0ROW,I3/(10F12.5))
c7	FORMAT(1H0//12H   NUMBER OF, 7X,7HLARGEST,7X,13HCORRESPONDING,31X,
c     17HDEGREES/13H  EIGENVALUES,5X,10HEIGENVALUE,7X,9HCANONICAL,7X,
c     26HLAMBDA,5X,10HCHI-SQUARE,7X,2H0F/4X,7HREMOVED,7X,9HREMAINING,7X,
c     311HCORRELATION,32X,7HFREEDOM/)
c8	FORMAT(1H ,I7,F19.5,F16.5,2F14.5,5X,I5)
c9	FORMAT(1H0/22H CANONICAL CORRELATION,F12.5)
c10	FORMAT(39H0  COEFFICIENTS FOR LEFT HAND VARIABLES/(8F15.5))
c11	FORMAT(40H0  COEFFICIENTS FOR RIGHT HAND VARIABLES/(8F15.5))
cC	DOUBLE PRECISION TMPFIL,FILE
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC	FILE = TMPFIL('SSP')
cC	OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
cC	1	DISPOSE='DELETE')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR,PR1,N,MP,MQ
c	IF (EOF) GOTO 999
cC	   PR.......PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	   PR1......PROBLEM NUMBER (CONTINUED)
cC	   N........NUMBER OF OBSERVATIONS
cC	   MP.......NUMBER OF LEFT HAND VARIABLES
cC	   MQ.......NUMBER OF RIGHT HAND VARIABLES
cC
c	WRITE (6,2) PR,PR1,N,MP,MQ
cC
c	M=MP+MQ
c	IO=0
c	X=0.0
cC
c	CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,CANR,CHISQ,COEFL)
cC
cC	PRINT MEANS, STANDARD DEVIATIONS, AND CORRELATION
cC	COEFFICIENTS OF ALL VARIABLES
cC
c	WRITE (6,3) (XBAR(I),I=1,M)
c	WRITE (6,4) (STD(I),I=1,M)
c	WRITE (6,5)
c	DO 160 I=1,M
c	DO 150 J=1,M
c	IF(I-J) 120, 130, 130
c120	L=I+(J*J-J)/2
c	GO TO 140
c130	L=J+(I*I-I)/2
c140	CANR(J)=R(L)
c150	CONTINUE
c160	WRITE (6,6) I,(CANR(J),J=1,M)
cC
c	CALL CANOR (N,MP,MQ,R,XBAR,STD,CANR,CHISQ,NDF,COEFR,COEFL,RX)
cC
cC	PRINT EIGENVALUES, CANONICAL CORRELATIONS, LAMBDA, CHI-SQUARES,
cC	DEGREES OF FREEDOMS
cC
c	WRITE (6,7)
c	DO 170 I=1,MQ
c	N1=I-1
cC
cC	   TEST WHETHER EIGENVALUE IS GREATER THAN ZERO
cC
c	IF(XBAR(I)) 165, 165, 170
c165	MM=N1
c	GO TO 175
c170	WRITE (6,8) N1,XBAR(I),CANR(I),STD(I),CHISQ(I),NDF(I)
c	MM=MQ
cC
cC	PRINT CANONICAL COEFFICIENTS
cC
c175	N1=0
c	N2=0
c	DO 200 I=1,MM
c	WRITE (6,9) CANR(I)
c	DO 180 J=1,MP
c	N1=N1+1
c180	XBAR(J)=COEFL(N1)
c	WRITE (6,10) (XBAR(J),J=1,MP)
c	DO 190 J=1,MQ
c	N2=N2+1
c190	XBAR(J)=COEFR(N2)
c	WRITE (6,11) (XBAR(J),J=1,MQ)
c200	CONTINUE
c	GO TO 100
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE MCHB
C
C	   PURPOSE
C	      FOR A GIVEN POSITIVE-DEFINITE M BY M MATRIX A WITH SYMMETRIC
C	      BAND STRUCTURE AND - IF NECESSARY - A GIVEN GENERAL M BY N
C	      MATRIX R, THE FOLLOWING CALCULATIONS (DEPENDENT ON THE
C	      VALUE OF THE DECISION PARAMETER IOP) ARE PERFORMED
C	      (1) MATRIX A IS FACTORIZED (IF IOP IS NOT NEGATIVE), THAT
C	          MEANS BAND MATRIX TU WITH UPPER CODIAGONALS ONLY IS
C	          GENERATED ON THE LOCATIONS OF A SUCH THAT
C	          TRANSPOSE(TU)*TU=A.
C	      (2) MATRIX R IS MULTIPLIED ON THE LEFT BY INVERSE(TU)
C	          AND/OR INVERSE(TRANSPOSE(TU)) AND THE RESULT IS STORED
C	          IN THE LOCATIONS OF R.
C	      THIS SUBROUTINE ESPECIALLY CAN BE USED TO SOLVE THE SYSTEM
C	      OF SIMULTANEOUS LINEAR EQUATIONS A*X=R WITH POSITIVE-
C	      DEFINITE COEFFICIENT MATRIX A OF SYMMETRIC BAND STRUCTURE.
C
C	   USAGE
C	      CALL MCHB (R,A,M,N,MUD,IOP,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      R      - INPUT IN CASES IOP=-3,-2,-1,1,2,3  M BY N RIGHT
C	                     HAND SIDE MATRIX,
C	                     IN CASE IOP=0  IRRELEVANT.
C	               OUTPUT IN CASES IOP=1,-1  INVERSE(A)*R,
C	                      IN CASES IOP=2,-2  INVERSE(TU)*R,
C	                      IN CASES IOP=3,-3  INVERSE(TRANSPOSE(TU))*R,
C	                      IN CASE  IOP=0     UNCHANGED.
C	      A      - INPUT IN CASES IOP=0,1,2,3 M BY M POSITIVE-DEFINITE
C	                     COEFFICIENT MATRIX OF SYMMETRIC BAND STRUC-
C	                     TURE STORED IN COMPRESSED FORM (SEE REMARKS),
C	                     IN CASES IOP=-1,-2,-3  M BY M BAND MATRIX TU
C	                     WITH UPPER CODIAGONALS ONLY, STORED IN
C	                     COMPRESSED FORM (SEE REMARKS).
C	               OUTPUT IN ALL CASES  BAND MATRIX TU WITH UPPER
C	                      CODIAGONALS ONLY, STORED IN COMPRESSED FORM
C	                      (THAT MEANS UNCHANGED IF IOP=-1,-2,-3).
C	      M      - INPUT VALUE SPECIFYING THE NUMBER OF ROWS AND
C	               COLUMNS OF A AND THE NUMBER OF ROWS OF R.
C	      N      - INPUT VALUE SPECIFYING THE NUMBER OF COLUMNS OF R
C	               (IRRELEVANT IN CASE IOP=0).
C	      MUD    - INPUT VALUE SPECIFYING THE NUMBER OF UPPER
C	               CODIAGONALS OF A.
C	      IOP    - ONE OF THE VALUES -3,-2,-1,0,1,2,3 GIVEN AS INPUT
C	               AND USED AS DECISION PARAMETER.
C	      EPS    - INPUT VALUE USED AS RELATIVE TOLERANCE FOR TEST ON
C	               LOSS OF SIGNIFICANT DIGITS.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0  - NO ERROR,
C	                IER=-1 - NO RESULT BECAUSE OF WRONG INPUT
C	                         PARAMETERS M,MUD,IOP (SEE REMARKS),
C	                         OR BECAUSE OF A NONPOSITIVE RADICAND AT
C	                         SOME FACTORIZATION STEP,
C	                         OR BECAUSE OF A ZERO DIAGONAL ELEMENT
C	                         AT SOME DIVISION STEP.
C	                IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C	                         CANCE INDICATED AT FACTORIZATION STEP K+1
C	                         WHERE RADICAND WAS NO LONGER GREATER
C	                         THAN EPS*A(K+1,K+1).
C
C	   REMARKS
C	      UPPER PART OF SYMMETRIC BAND MATRIX A CONSISTING OF MAIN
C	      DIAGONAL AND MUD UPPER CODIAGONALS (RESP. BAND MATRIX TU
C	      CONSISTING OF MAIN DIAGONAL AND MUD UPPER CODIAGONALS)
C	      IS ASSUMED TO BE STORED IN COMPRESSED FORM, I.E. ROWWISE
C	      IN TOTALLY NEEDED M+MUD*(2M-MUD-1)/2 SUCCESSIVE STORAGE
C	      LOCATIONS. ON RETURN UPPER BAND FACTOR TU (ON THE LOCATIONS
C	      OF A) IS STORED IN THE SAME WAY.
C	      RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE
C	      IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN RESULT MATRIX
C	      INVERSE(A)*R OR INVERSE(TU)*R OR INVERSE(TRANSPOSE(TU))*R
C	      IS STORED COLUMNWISE TOO ON THE LOCATIONS OF R.
C	      INPUT PARAMETERS M, MUD, IOP SHOULD SATISFY THE FOLLOWING
C	      RESTRICTIONS     MUD NOT LESS THAN ZERO,
C	                       1+MUD NOT GREATER THAN M,
C	                       ABS(IOP) NOT GREATER THAN 3.
C	      NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE
C	      RESTRICTIONS ARE NOT SATISFIED.
C	      THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT
C	      PARAMETERS ARE SATISFIED, IF RADICANDS AT ALL FACTORIZATION
C	      STEPS ARE POSITIVE AND/OR IF ALL DIAGONAL ELEMENTS OF
C	      UPPER BAND FACTOR TU ARE NONZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      FACTORIZATION IS DONE USING CHOLESKY-S SQUARE-ROOT METHOD,
C	      WHICH GENERATES THE UPPER BAND MATRIX TU SUCH THAT
C	      TRANSPOSE(TU)*TU=A. TU IS RETURNED AS RESULT ON THE
C	      LOCATIONS OF A. FURTHER, DEPENDENT ON THE ACTUAL VALUE OF
C	      IOP, DIVISION OF R BY TRANSPOSE(TU) AND/OR TU IS PERFORMED
C	      AND THE RESULT IS RETURNED ON THE LOCATIONS OF R.
C	      FOR REFERENCE, SEE H. RUTISHAUSER, ALGORITHMUS 1 - LINEARES
C	      GLEICHUNGSSYSTEM MIT SYMMETRISCHER POSITIV-DEFINITER
C	      BANDMATRIX NACH CHOLESKY - , COMPUTING (ARCHIVES FOR
C	      ELECTRONIC COMPUTING), VOL.1, ISS.1 (1966), PP.77-78.
C
C	..................................................................
C
	SUBROUTINE MCHB(R,A,M,N,MUD,IOP,EPS,IER)
C
C
	DIMENSION R(1),A(1)
	DOUBLE PRECISION TOL,SUM,PIV
C
C	   TEST ON WRONG INPUT PARAMETERS
	IF(IABS(IOP)-3)1,1,43
1	IF(MUD)43,2,2
2	MC=MUD+1
	IF(M-MC)43,3,3
3	MR=M-MUD
	IER=0
C
C	   MC IS THE MAXIMUM NUMBER OF ELEMENTS IN THE ROWS OF ARRAY A
C	   MR IS THE INDEX OF THE LAST ROW IN ARRAY A WITH MC ELEMENTS
C
C	******************************************************************
C
C	   START FACTORIZATION OF MATRIX A
	IF(IOP)24,4,4
4	IEND=0
	LLDST=MUD
	DO 23 K=1,M
	IST=IEND+1
	IEND=IST+MUD
	J=K-MR
	IF(J)6,6,5
5	IEND=IEND-J
6	IF(J-1)8,8,7
7	LLDST=LLDST-1
8	LMAX=MUD
	J=MC-K
	IF(J)10,10,9
9	LMAX=LMAX-J
10	ID=0
	TOL=A(IST)*EPS
C
C	   START FACTORIZATION-LOOP OVER K-TH ROW
	DO 23 I=IST,IEND
	SUM=0.D0
	IF(LMAX)14,14,11
C
C	   PREPARE INNER LOOP
11	LL=IST
	LLD=LLDST
C
C	   START INNER LOOP
	DO 13 L=1,LMAX
	LL=LL-LLD
	LLL=LL+ID
	SUM=SUM+A(LL)*A(LLL)
	IF(LLD-MUD)12,13,13
12	LLD=LLD+1
13	CONTINUE
C	   END OF INNER LOOP
C
C	   TRANSFORM ELEMENT A(I)
14	SUM=DBLE(A(I))-SUM
	IF(I-IST)15,15,20
C
C	   A(I) IS DIAGONAL ELEMENT. ERROR TEST.
15	IF(SUM)43,43,16
C
C	   TEST ON LOSS OF SIGNIFICANT DIGITS AND WARNING
16	IF(SUM-TOL)17,17,19
17	IF(IER)18,18,19
18	IER=K-1
C
C	   COMPUTATION OF PIVOT ELEMENT
19	PIV=DSQRT(SUM)
	A(I)=PIV
	PIV=1.D0/PIV
	GO TO 21
C
C	   A(I) IS NOT DIAGONAL ELEMENT
20	A(I)=SUM*PIV
C
C	   UPDATE ID AND LMAX
21	ID=ID+1
	IF(ID-J)23,23,22
22	LMAX=LMAX-1
23	CONTINUE
C
C	   END OF FACTORIZATION-LOOP OVER K-TH ROW
C	   END OF FACTORIZATION OF MATRIX A
C
C	******************************************************************
C
C	   PREPARE MATRIX DIVISIONS
	IF(IOP)24,44,24
24	ID=N*M
	IEND=IABS(IOP)-2
	IF(IEND)25,35,25
C
C	******************************************************************
C
C	   START DIVISION BY TRANSPOSE OF MATRIX TU (TU IS STORED IN
C	   LOCATIONS OF A)
25	IST=1
	LMAX=0
	J=-MR
	LLDST=MUD
	DO 34 K=1,M
	PIV=A(IST)
	IF(PIV)26,43,26
26	PIV=1.D0/PIV
C
C	   START BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R
	DO 30 I=K,ID,M
	SUM=0.D0
	IF(LMAX)30,30,27
C
C	   PREPARE INNER LOOP
27	LL=IST
	LLL=I
	LLD=LLDST
C
C	   START INNER LOOP
	DO 29 L=1,LMAX
	LL=LL-LLD
	LLL=LLL-1
	SUM=SUM+A(LL)*R(LLL)
	IF(LLD-MUD)28,29,29
28	LLD=LLD+1
29	CONTINUE
C	   END OF INNER LOOP
C
C	   TRANSFORM ELEMENT R(I)
30	R(I)=PIV*(DBLE(R(I))-SUM)
C	   END OF BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R
C
C	   UPDATE PARAMETERS LMAX, IST AND LLDST
	IF(MC-K)32,32,31
31	LMAX=K
32	IST=IST+MC
	J=J+1
	IF(J)34,34,33
33	IST=IST-J
	LLDST=LLDST-1
34	CONTINUE
C
C	   END OF DIVISION BY TRANSPOSE OF MATRIX TU
C
C	******************************************************************
C
C	   START DIVISION BY MATRIX TU (TU IS STORED ON LOCATIONS OF A)
	IF(IEND)35,35,44
35	IST=M+(MUD*(M+M-MC))/2+1
	LMAX=0
	K=M
36	IEND=IST-1
	IST=IEND-LMAX
	PIV=A(IST)
	IF(PIV)37,43,37
37	PIV=1.D0/PIV
	L=IST+1
C
C	   START BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R
	DO 40 I=K,ID,M
	SUM=0.D0
	IF(LMAX)40,40,38
38	LLL=I
C
C	   START INNER LOOP
	DO 39 LL=L,IEND
	LLL=LLL+1
39	SUM=SUM+A(LL)*R(LLL)
C	   END OF INNER LOOP
C
C	   TRANSFORM ELEMENT R(I)
40	R(I)=PIV*(DBLE(R(I))-SUM)
C	   END OF BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R
C
C
C	   UPDATE PARAMETERS LMAX AND K
	IF(K-MR)42,42,41
41	LMAX=LMAX+1
42	K=K-1
	IF(K)44,44,36
C
C	   END OF DIVISION BY MATRIX TU
C
C	******************************************************************
C
C	   ERROR EXIT IN CASE OF WRONG INPUT PARAMETERS OR PIVOT ELEMENT
C	   LESS THAN OR EQUAL TO ZERO
43	IER=-1
44	RETURN
	END
C
C	   ...............................................................
C
C	   SUBROUTINE MCPY
C
C	   PURPOSE
C	      COPY ENTIRE MATRIX
C
C	   USAGE
C	      CALL MCPY (A,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A OR R
C	      M - NUMBER OF COLUMNS IN A OR R
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      EACH ELEMENT OF MATRIX A IS MOVED TO THE CORRESPONDING
C	      ELEMENT OF MATRIX R
C
C	..................................................................
C
	SUBROUTINE MCPY(A,R,N,M,MS)
	DIMENSION A(1),R(1)
C
C	   COMPUTE VECTOR LENGTH, IT
C
	CALL LOC(N,M,IT,N,M,MS)
C
C	   COPY MATRIX
C
	DO 1 I=1,IT
1	R(I)=A(I)
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR DISCRIMINANT ANALYSIS - MDISC
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD AND DATA FOR DISCRIMI-
C	      NANT ANALYSIS, (2) CALL THREE SUBROUTINES TO CALCULATE VARI-
C	      ABLE MEANS IN EACH GROUP, POOLED DISPERSION MATRIX, COMMON
C	      MEANS OF VARIABLES, GENERALIZED MAHALANOBIS D SQUARE,
C	      COEFFICIENTS OF DISCRIMINANT FUNCTIONS, AND PROBABILITY
C	      ASSOCIATED WITH LARGEST DISCRIMINANT FUNCTION OF EACH
C	      CASE IN EACH GROUP, AND (3) PRINT THE RESULTS.
C
C	   REMARKS
C	      THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO
C	      THE NUMBER OF GROUPS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      DMATX
C	      MINV
C	      DISCR
C
C	   METHOD
C	      REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.
C	      DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO
C	      MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS,
C	      1958, SECTION 6.6-6.8.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C	NUMBER OF GROUPS, K..
cC
c	   DIMENSION N(5)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	NUMBER OF VARIABLES, M..
cC
c	   DIMENSION CMEAN(10)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*K..
cC
c	   DIMENSION XBAR(50)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF (M+1)*K..
cC
c	   DIMENSION C(55)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*M..
cC
c	   DIMENSION D(100)
cC
cC	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
cC	TOTAL OF SAMPLE SIZES OF K GROUPS COMBINED, T (T = N(1)+N(2)+...
cC	+N(K))..
cC
c	   DIMENSION P(250),LG(250)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	TOTAL DATA POINTS WHICH IS EQUAL TO THE PRODUCT OF T*M..
cC
c	   DIMENSION X(2500)
cC
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION CMEAN,XBAR,D,DET,C,V,P
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	   ...............................................................
cC
c1	FORMAT(A4,A2,2I2,12I5/(14I5))
c2	FORMAT(27H1DISCRIMINANT ANALYSIS.....,A4,A2/19H0  NUMBER OF GROUPS
c     1,7X,I3/22H   NUMBER OF VARIABLES,I7/17H   SAMPLE SIZES../12X,5HGRO
c     2UP)
c3	FORMAT(12X,I3,8X,I4)
c4	FORMAT(1H0)
c5	FORMAT(12F6.0)
c6	FORMAT(6H0GROUP,I3,7H  MEANS/(8F15.5))
c7	FORMAT(1H0/25H POOLED DISPERSION MATRIX)
c8	FORMAT(4H0ROW,I3/(8F15.5))
c9	FORMAT(1H0//13H COMMON MEANS/(8F15.5))
c10	FORMAT(1H///33H GENERALIZED MAHALANOBIS D-SQUARE,F15.5//)
c11	FORMAT(22H0DISCRIMINANT FUNCTION,I3/1H ,6X,27HCONSTANT   *   COEFF
c     1ICIENTS/1H F14.5,7H   *   ,7F14.5/(22X,7F14.5))
c12	FORMAT(1H0//60H EVALUATION OF CLASSIFICATION FUNCTIONS FOR EACH OB
c     1SERVATION)
c13	FORMAT(6H0GROUP,I3/19X,27HPROBABILITY ASSOCIATED WITH,11X,7HLARGES
c     1T/13H  OBSERVATION,5X,29HLARGEST DISCRIMINANT FUNCTION,8X,12HFUNCT
c     2ION NO.)
c14	FORMAT(1H ,I7,20X,F8.5,20X,I6)
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR,PR1,K,M,(N(I),I=1,K)
c	IF (EOF) GOTO 999
cC	   PR.......PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	   PR1......PROBLEM NUMBER (CONTINUED)
cC	   K........NUMBER OF GROUPS
cC	   M........NUMBER OF VARIABLES
cC	   N........VECTOR OF LENGTH K CONTAINING SAMPLE SIZES
cC
c	WRITE (6,2) PR,PR1,K,M
c	DO 110 I=1,K
c110	WRITE (6,3) I,N(I)
c	WRITE (6,4)
cC
cC	READ DATA
cC
c	L=0
c	DO 130 I=1,K
c	N1=N(I)
c	DO 120 J=1,N1
c	READ (5,5) (CMEAN(IJ),IJ=1,M)
c	L=L+1
c	N2=L-N1
c	DO 120 IJ=1,M
c	N2=N2+N1
c120	X(N2)=CMEAN(IJ)
c130	L=N2
cC
c	CALL DMATX (K,M,N,X,XBAR,D,CMEAN)
cC
cC	PRINT MEANS AND POOLED DISPERSION MATRIX
cC
c	L=0
c	DO 150 I=1,K
c	DO 140 J=1,M
c	L=L+1
c140	CMEAN(J)=XBAR(L)
c150	WRITE (6,6) I,(CMEAN(J),J=1,M)
c	WRITE (6,7)
c	DO 170 I=1,M
c	L=I-M
c	DO 160 J=1,M
c	L=L+M
c160	CMEAN(J)=D(L)
c170	WRITE (6,8) I,(CMEAN(J),J=1,M)
cC
c	CALL MINV (D,M,DET,CMEAN,C)
cC
c	CALL DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG)
cC
cC	PRINT COMMON MEANS
cC
c	WRITE (6,9) (CMEAN(I),I=1,M)
cC
cC	PRINT GENERALIZED MAHALANOBIS D-SQUARE
cC
c	WRITE (6,10) V
cC
cC	PRINT CONSTANTS AND COEFFICIENTS OF DISCRIMINANT FUNCTIONS
cC
c	N1=1
c	N2=M+1
c	DO 180 I=1,K
c	WRITE (6,11) I,(C(J),J=N1,N2)
c	N1=N1+(M+1)
c180	N2=N2+(M+1)
cC
cC	PRINT EVALUATION OF CALSSIFICATION FUNCTIONS FOR EACH OBSERVATION
cC
c	WRITE (6,12)
c	N1=1
c	N2=N(1)
c	DO 210 I=1,K
c	WRITE (6,13) I
c	L=0
c	DO 190 J=N1,N2
c	L=L+1
c190	WRITE (6,14) L,P(J),LG(J)
c	IF(I-K) 200, 100, 100
c200	N1=N1+N(I)
c	N2=N2+N(I+1)
c210	CONTINUE
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE MEANQ
C
C	   PURPOSE
C	      COMPUTE SUM OF SQUARES, DEGREES OF FREEDOM, AND MEAN SQUARE
C	      USING THE MEAN SQUARE OPERATOR.  THIS SUBROUTINE NORMALLY
C	      FOLLOWS CALLS TO AVDAT AND AVCAL SUBROUTINES IN THE PER-
C	      FORMANCE OF ANALYSIS OF VARIANCE FOR A COMPLETE FACTORIAL
C	      DESIGN.
C
C	   USAGE
C	      CALL MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,MSTEP,KOUNT,
C	                   LASTS)
C
C	   DESCRIPTION OF PARAMETERS
C	      K     - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE.
C	      LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE-
C	              GORIES) WITHIN EACH VARIABLE.
C	      X     - INPUT VECTOR CONTAINING THE RESULT OF THE SIGMA AND
C	              DELTA OPERATORS. THE LENGTH OF X IS
C	              (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).
C	      GMEAN - OUTPUT VARIABLE CONTAINING GRAND MEAN.
C	      SUMSQ - OUTPUT VECTOR CONTAINING SUMS OF SQUARES.  THE
C	              LENGTH OF SUMSQ IS 2 TO THE K-TH POWER MINUS ONE,
C	              (2**K)-1.
C	      NDF   - OUTPUT VECTOR CONTAINING DEGREES OF FREEDOM.  THE
C	              LENGTH OF NDF IS 2 TO THE K-TH POWER MINUS ONE,
C	              (2**K)-1.
C	      SMEAN - OUTPUT VECTOR CONTAINING MEAN SQUARES.  THE
C	              LENGTH OF SMEAN IS 2 TO THE K-TH POWER MINUS ONE,
C	              (2**K)-1.
C	      MSTEP - WORKING VECTOR OF LENGTH K.
C	      KOUNT - WORKING VECTOR OF LENGTH K.
C	      LASTS - WORKING VECTOR OF LENGTH K.
C
C	   REMARKS
C	      THIS SUBROUTINE MUST FOLLOW SUBROUTINE AVCAL
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O.
C	      HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS',
C	      EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS,
C	      1962, CHAPTER 20.
C
C	..................................................................
C
	SUBROUTINE MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,MSTEP,KOUNT,
     1                  LASTS)
	DIMENSION LEVEL(1),X(1),SUMSQ(1),NDF(1),SMEAN(1),MSTEP(1),
     1          KOUNT(1),LASTS(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION X,GMEAN,SUMSQ,SMEAN,FN1
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	CALCULATE TOTAL NUMBER OF DATA
C
	N=LEVEL(1)
	DO 150 I=2,K
150	N=N*LEVEL(I)
C
C	SET UP CONTROL FOR MEAN SQUARE OPERATOR
C
	LASTS(1)=LEVEL(1)
	DO 178 I=2,K
178	LASTS(I)=LEVEL(I)+1
	NN=1
C
C	CLEAR THE AREA TO STORE SUMS OF SQUARES
C
	LL=(2**K)-1
	MSTEP(1)=1
	DO 180 I=2,K
180	MSTEP(I)=MSTEP(I-1)*2
	DO 185 I=1,LL
185	SUMSQ(I)=0.0
C
C	PERFORM MEAN SQUARE OPERATOR
C
	DO 190 I=1,K
190	KOUNT(I)=0
200	L=0
	DO 260 I=1,K
	IF(KOUNT(I)-LASTS(I)) 210, 250, 210
210	IF(L) 220, 220, 240
220	KOUNT(I)=KOUNT(I)+1
	IF(KOUNT(I)-LEVEL(I)) 230, 230, 250
230	L=L+MSTEP(I)
	GO TO 260
240	IF(KOUNT(I)-LEVEL(I)) 230, 260, 230
250	KOUNT(I)=0
260	CONTINUE
	IF(L) 285, 285, 270
270	SUMSQ(L)=SUMSQ(L)+X(NN)*X(NN)
	NN=NN+1
	GO TO 200
C
C	CALCULATE THE GRAND MEAN
C
285	FN=N
	GMEAN=X(NN)/FN
C
C	CALCULATE FIRST DIVISOR REQUIRED TO FORM SUM OF SQUARES AND SECOND
C	DIVISOR, WHICH IS EQUAL TO DEGREES OF FREEDOM, REQUIRED TO FORM
C	MEAN SQUARES
C
	DO 310 I=2,K
310	MSTEP(I)=0
	NN=0
	MSTEP(1)=1
320	ND1=1
	ND2=1
	DO 340 I=1,K
	IF(MSTEP(I)) 330, 340, 330
330	ND1=ND1*LEVEL(I)
	ND2=ND2*(LEVEL(I)-1)
340	CONTINUE
	FN1=N*ND1
	FN2=ND2
	NN=NN+1
	SUMSQ(NN)=SUMSQ(NN)/FN1
	NDF(NN)=ND2
	SMEAN(NN)=SUMSQ(NN)/FN2
	IF(NN-LL) 345, 370, 370
345	DO 360 I=1,K
	IF(MSTEP(I)) 347, 350, 347
347	MSTEP(I)=0
	GO TO 360
350	MSTEP(I)=1
	GO TO 320
360	CONTINUE
370	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MFGR
C
C	   PURPOSE
C	      FOR A GIVEN M BY N MATRIX THE FOLLOWING CALCULATIONS
C	      ARE PERFORMED
C	      (1) DETERMINE RANK AND LINEARLY INDEPENDENT ROWS AND
C	          COLUMNS (BASIS).
C	      (2) FACTORIZE A SUBMATRIX OF MAXIMAL RANK.
C	      (3) EXPRESS NON-BASIC ROWS IN TERMS OF BASIC ONES.
C	      (4) EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES.
C
C	   USAGE
C	      CALL MFGR(A,M,N,EPS,IRANK,IROW,ICOL)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - GIVEN MATRIX WITH M ROWS AND N COLUMNS.
C	               ON RETURN A CONTAINS THE FIVE SUBMATRICES
C	               L, R, H, D, O.
C	      M      - NUMBER OF ROWS OF MATRIX A.
C	      N      - NUMBER OF COLUMNS OF MATRIX A.
C	      EPS    - TESTVALUE FOR ZERO AFFECTED BY ROUNDOFF NOISE.
C	      IRANK  - RESULTANT RANK OF GIVEN MATRIX.
C	      IROW   - INTEGER VECTOR OF DIMENSION M CONTAINING THE
C	               SUBSCRIPTS OF BASIC ROWS IN IROW(1),...,IROW(IRANK)
C	      ICOL   - INTEGER VECTOR OF DIMENSION N CONTAINING THE
C	               SUBSCRIPTS OF BASIC COLUMNS IN ICOL(1) UP TO
C	               ICOL(IRANK).
C
C	   REMARKS
C	      THE LEFT HAND TRIANGULAR FACTOR IS NORMALIZED SUCH THAT
C	      THE DIAGONAL CONTAINS ALL ONES THUS ALLOWING TO STORE ONLY
C	      THE SUBDIAGONAL PART.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      GAUSSIAN ELIMINATION TECHNIQUE IS USED FOR CALCULATION
C	      OF THE TRIANGULAR FACTORS OF A GIVEN MATRIX.
C	      COMPLETE PIVOTING IS BUILT IN.
C	      IN CASE OF A SINGULAR MATRIX ONLY THE TRIANGULAR FACTORS
C	      OF A SUBMATRIX OF MAXIMAL RANK ARE RETAINED.
C	      THE REMAINING PARTS OF THE RESULTANT MATRIX GIVE THE
C	      DEPENDENCIES OF ROWS AND THE SOLUTION OF THE HOMOGENEOUS
C	      MATRIX EQUATION A*X=0.
C
C	..................................................................
C
	SUBROUTINE MFGR(A,M,N,EPS,IRANK,IROW,ICOL)
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),IROW(1),ICOL(1)
C
C	  TEST OF SPECIFIED DIMENSIONS
	IF(M)2,2,1
1	IF(N)2,2,4
2	IRANK=-1
3	RETURN
C	  RETURN IN CASE OF FORMAL ERRORS
C
C
C	   INITIALIZE COLUMN INDEX VECTOR
C	   SEARCH FIRST PIVOT ELEMENT
4	IRANK=0
	PIV=0.
	JJ=0
	DO 6 J=1,N
	ICOL(J)=J
	DO 6 I=1,M
	JJ=JJ+1
	HOLD=A(JJ)
	IF(ABS(PIV)-ABS(HOLD))5,6,6
5	PIV=HOLD
	IR=I
	IC=J
6	CONTINUE
C
C	   INITIALIZE ROW INDEX VECTOR
	DO 7 I=1,M
7	IROW(I)=I
C
C	   SET UP INTERNAL TOLERANCE
	TOL=ABS(EPS*PIV)
C
C	   INITIALIZE ELIMINATION LOOP
	NM=N*M
	DO 19 NCOL=M,NM,M
C
C	   TEST FOR FEASIBILITY OF PIVOT ELEMENT
8	IF(ABS(PIV)-TOL)20,20,9
C
C	   UPDATE RANK
9	IRANK=IRANK+1
C
C	   INTERCHANGE ROWS IF NECESSARY
	JJ=IR-IRANK
	IF(JJ)12,12,10
10	DO 11 J=IRANK,NM,M
	I=J+JJ
	SAVE=A(J)
	A(J)=A(I)
11	A(I)=SAVE
C
C	   UPDATE ROW INDEX VECTOR
	JJ=IROW(IR)
	IROW(IR)=IROW(IRANK)
	IROW(IRANK)=JJ
C
C	   INTERCHANGE COLUMNS IF NECESSARY
12	JJ=(IC-IRANK)*M
	IF(JJ)15,15,13
13	KK=NCOL
	DO 14 J=1,M
	I=KK+JJ
	SAVE=A(KK)
	A(KK)=A(I)
	KK=KK-1
14	A(I)=SAVE
C
C	   UPDATE COLUMN INDEX VECTOR
	JJ=ICOL(IC)
	ICOL(IC)=ICOL(IRANK)
	ICOL(IRANK)=JJ
15	KK=IRANK+1
	MM=IRANK-M
	LL=NCOL+MM
C
C	   TEST FOR LAST ROW
	IF(MM)16,25,25
C
C	   TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT
16	JJ=LL
	SAVE=PIV
	PIV=0.
	DO 19 J=KK,M
	JJ=JJ+1
	HOLD=A(JJ)/SAVE
	A(JJ)=HOLD
	L=J-IRANK
C
C	   TEST FOR LAST COLUMN
	IF(IRANK-N)17,19,19
17	II=JJ
	DO 19 I=KK,N
	II=II+M
	MM=II-L
	A(II)=A(II)-HOLD*A(MM)
	IF(ABS(A(II))-ABS(PIV))19,19,18
18	PIV=A(II)
	IR=J
	IC=I
19	CONTINUE
C
C	   SET UP MATRIX EXPRESSING ROW DEPENDENCIES
20	IF(IRANK-1)3,25,21
21	IR=LL
	DO 24 J=2,IRANK
	II=J-1
	IR=IR-M
	JJ=LL
	DO 23 I=KK,M
	HOLD=0.
	JJ=JJ+1
	MM=JJ
	IC=IR
	DO 22 L=1,II
	HOLD=HOLD+A(MM)*A(IC)
	IC=IC-1
22	MM=MM-M
23	A(MM)=A(MM)-HOLD
24	CONTINUE
C
C	   TEST FOR COLUMN REGULARITY
25	IF(N-IRANK)3,3,26
C
C	   SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE
C	  PARAMETERS (HOMOGENEOUS SOLUTION).
26	IR=LL
	KK=LL+M
	DO 30 J=1,IRANK
	DO 29 I=KK,NM,M
	JJ=IR
	LL=I
	HOLD=0.
	II=J
27	II=II-1
	IF(II)29,29,28
28	HOLD=HOLD-A(JJ)*A(LL)
	JJ=JJ-M
	LL=LL-1
	GOTO 27
29	A(LL)=(HOLD-A(LL))/A(JJ)
30	IR=IR-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MFSD
C
C	   PURPOSE
C	      FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX
C
C	   USAGE
C	      CALL MFSD(A,N,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A      - UPPER TRIANGULAR PART OF THE GIVEN SYMMETRIC
C	               POSITIVE DEFINITE N BY N COEFFICIENT MATRIX.
C	               ON RETURN A CONTAINS THE RESULTANT UPPER
C	               TRIANGULAR MATRIX.
C	      N      - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX.
C	      EPS    - AN INPUT CONSTANT WHICH IS USED AS RELATIVE
C	               TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE.
C	      IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C	               IER=0  - NO ERROR
C	               IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME-
C	                        TER N OR BECAUSE SOME RADICAND IS NON-
C	                        POSITIVE (MATRIX A IS NOT POSITIVE
C	                        DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI-
C	                        FICANCE)
C	               IER=K  - WARNING WHICH INDICATES LOSS OF SIGNIFI-
C	                        CANCE. THE RADICAND FORMED AT FACTORIZA-
C	                        TION STEP K+1 WAS STILL POSITIVE BUT NO
C	                        LONGER GREATER THAN ABS(EPS*A(K+1,K+1)).
C
C	   REMARKS
C	      THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE
C	      STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS.
C	      IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU-
C	      LAR MATRIX IS STORED COLUMNWISE TOO.
C	      THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL
C	      CALCULATED RADICANDS ARE POSITIVE.
C	      THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE
C	      SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY.
C	      THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR
C	      MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF
C	      THE RETURNED RIGHT HAND FACTOR.
C
C	..................................................................
C
	SUBROUTINE MFSD(A,N,EPS,IER)
C
C
	DIMENSION A(1)
	DOUBLE PRECISION DPIV,DSUM
C
C	   TEST ON WRONG INPUT PARAMETER N
	IF(N-1) 12,1,1
1	IER=0
C
C	   INITIALIZE DIAGONAL-LOOP
	KPIV=0
	DO 11 K=1,N
	KPIV=KPIV+K
	IND=KPIV
	LEND=K-1
C
C	   CALCULATE TOLERANCE
	TOL=ABS(EPS*A(KPIV))
C
C	   START FACTORIZATION-LOOP OVER K-TH ROW
	DO 11 I=K,N
	DSUM=0.D0
	IF(LEND) 2,4,2
C
C	   START INNER LOOP
2	DO 3 L=1,LEND
	LANF=KPIV-L
	LIND=IND-L
3	DSUM=DSUM+DBLE(A(LANF)*A(LIND))
C	   END OF INNER LOOP
C
C	   TRANSFORM ELEMENT A(IND)
4	DSUM=DBLE(A(IND))-DSUM
	IF(I-K) 10,5,10
C
C	   TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE
5	IF(SNGL(DSUM)-TOL) 6,6,9
6	IF(DSUM) 12,12,7
7	IF(IER) 8,8,9
8	IER=K-1
C
C	   COMPUTE PIVOT ELEMENT
9	DPIV=DSQRT(DSUM)
	A(KPIV)=DPIV
	DPIV=1.D0/DPIV
	GO TO 11
C
C	   CALCULATE TERMS IN ROW
10	A(IND)=DSUM*DPIV
11	IND=IND+I
C
C	   END OF DIAGONAL-LOOP
	RETURN
12	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MFSS
C
C	   PURPOSE
C	      GIVEN A SYMMETRIC POSITIVE SEMI DEFINITE MATRIX , MFSS WILL
C	      (1) DETERMINE THE RANK AND LINEARLY INDEPENDENT ROWS AND
C	          COLUMNS
C	      (2) FACTOR A SYMMETRIC SUBMATRIX OF MAXIMAL RANK
C	      (3) EXPRESS NONBASIC ROWS IN TERMS OF BASIC ONES,
C	          EXPRESS NONBASIC COLUMNS IN TERMS OF BASIC ONES
C	          EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES
C	      SUBROUTINE MFSS MAY BE USED AS A PREPARATORY STEP FOR THE
C	      CALCULATION OF THE LEAST SQUARES SOLUTION OF MINIMAL
C	      LENGTH OF A SYSTEM OF LINEAR EQUATIONS WITH SYMMETRIC
C	      POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX
C
C	   USAGE
C	      CALL MFSS(A,N,EPS,IRANK,TRAC)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - UPPER TRIANGULAR PART OF GIVEN SYMMETRIC SEMI-
C	              DEFINITE MATRIX STORED COLUMNWISE IN COMPRESSED FORM
C	              ON RETURN A CONTAINS THE MATRIX T AND, IF IRANK IS
C	              LESS THAN N, THE MATRICES U AND TU
C	      N     - DIMENSION OF GIVEN MATRIX A
C	      EPS   - TESTVALUE FOR ZERO AFFECTED BY ROUND-OFF NOISE
C	      IRANK - RESULTANT VARIABLE, CONTAINING THE RANK OF GIVEN
C	              MATRIX A IF A IS SEMI-DEFINITE
C	              IRANK = 0 MEANS A HAS NO POSITIVE DIAGONAL ELEMENT
C	                        AND/OR EPS IS NOT ABSOLUTELY LESS THAN ONE
C	              IRANK =-1 MEANS DIMENSION N IS NOT POSITIVE
C	              IRANK =-2 MEANS COMPLETE FAILURE, POSSIBLY DUE TO
C	                        INADEQUATE RELATIVE TOLERANCE EPS
C	      TRAC  - VECTOR OF DIMENSION N CONTAINING THE
C	              SOURCE INDEX OF THE I-TH PIVOT ROW IN ITS I-TH
C	              LOCATION, THIS MEANS THAT TRAC CONTAINS THE
C	              PRODUCT REPRESENTATION OF THE PERMUTATION WHICH
C	              IS APPLIED TO ROWS AND COLUMNS OF A IN TERMS OF
C	              TRANSPOSITIONS
C
C	   REMARKS
C	      EPS MUST BE ABSOLUTELY LESS THAN ONE. A SENSIBLE VALUE IS
C	      SOMEWHERE IN BETWEEN 10**(-4) AND 10**(-6)
C	      THE ABSOLUTE VALUE OF INPUT PARAMETER EPS IS USED AS
C	      RELATIVE TOLERANCE.
C	      IN ORDER TO PRESERVE SYMMETRY ONLY PIVOTING ALONG THE
C	      DIAGONAL IS BUILT IN.
C	      ALL PIVOTELEMENTS MUST BE GREATER THAN THE ABSOLUTE VALUE
C	      OF EPS TIMES ORIGINAL DIAGONAL ELEMENT
C	      OTHERWISE THEY ARE TREATED AS IF THEY WERE ZERO
C	      MATRIX A REMAINS UNCHANGED IF THE RESULTANT VALUE IRANK
C	      EQUALS ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE SQUARE ROOT METHOD WITH DIAGONAL PIVOTING IS USED FOR
C	      CALCULATION OF THE RIGHT HAND TRIANGULAR FACTOR.
C	      IN CASE OF AN ONLY SEMI-DEFINITE MATRIX THE SUBROUTINE
C	      RETURNS THE IRANK X IRANK UPPER TRIANGULAR FACTOR T OF A
C	      SUBMATRIX OF MAXIMAL RANK, THE IRANK X (N-IRANK) MATRIX U
C	      AND THE (N-IRANK) X (N-IRANK) UPPER TRIANGULAR TU SUCH
C	      THAT TRANSPOSE(TU)*TU=I+TRANSPOSE(U)*U
C
C	..................................................................
C
	SUBROUTINE MFSS(A,N,EPS,IRANK,TRAC)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),TRAC(1)
	DOUBLE PRECISION SUM
C
C	   TEST OF SPECIFIED DIMENSION
	IF(N)36,36,1
C
C	   INITIALIZE TRIANGULAR FACTORIZATION
1	IRANK=0
	ISUB=0
	KPIV=0
	J=0
	PIV=0.
C
C	   SEARCH FIRST PIVOT ELEMENT
	DO 3 K=1,N
	J=J+K
	TRAC(K)=A(J)
	IF(A(J)-PIV)3,3,2
2	PIV=A(J)
	KSUB=J
	KPIV=K
3	CONTINUE
C
C	   START LOOP OVER ALL ROWS OF A
	DO 32 I=1,N
	ISUB=ISUB+I
	IM1=I-1
4	KMI=KPIV-I
	IF(KMI)35,9,5
C
C	   PERFORM PARTIAL COLUMN INTERCHANGE
5	JI=KSUB-KMI
	IDC=JI-ISUB
	JJ=ISUB-IM1
	DO 6 K=JJ,ISUB
	KK=K+IDC
	HOLD=A(K)
	A(K)=A(KK)
6	A(KK)=HOLD
C
C	   PERFORM PARTIAL ROW INTERCHANGE
	KK=KSUB
	DO 7 K=KPIV,N
	II=KK-KMI
	HOLD=A(KK)
	A(KK)=A(II)
	A(II)=HOLD
7	KK=KK+K
C
C	   PERFORM REMAINING INTERCHANGE
	JJ=KPIV-1
	II=ISUB
	DO 8 K=I,JJ
	HOLD=A(II)
	A(II)=A(JI)
	A(JI)=HOLD
	II=II+K
8	JI=JI+1
9	IF(IRANK)22,10,10
C
C	   RECORD INTERCHANGE IN TRANSPOSITION VECTOR
10	TRAC(KPIV)=TRAC(I)
	TRAC(I)=KPIV
C
C	   MODIFY CURRENT PIVOT ROW
	KK=IM1-IRANK
	KMI=ISUB-KK
	PIV=0.
	IDC=IRANK+1
	JI=ISUB-1
	JK=KMI
	JJ=ISUB-I
	DO 19 K=I,N
	SUM=0.D0
C
C	   BUILD UP SCALAR PRODUCT IF NECESSARY
	IF(KK)13,13,11
11	DO 12 J=KMI,JI
	SUM=SUM-A(J)*A(JK)
12	JK=JK+1
13	JJ=JJ+K
	IF(K-I)14,14,16
14	SUM=A(ISUB)+SUM
C
C	   TEST RADICAND FOR LOSS OF SIGNIFICANCE
	IF(SUM-ABS(A(ISUB)*EPS))20,20,15
15	A(ISUB)=DSQRT(SUM)
	KPIV=I+1
	GOTO 19
16	SUM=(A(JK)+SUM)/A(ISUB)
	A(JK)=SUM
C
C	   SEARCH FOR NEXT PIVOT ROW
	IF(A(JJ))19,19,17
17	TRAC(K)=TRAC(K)-SUM*SUM
	HOLD=TRAC(K)/A(JJ)
	IF(PIV-HOLD)18,19,19
18	PIV=HOLD
	KPIV=K
	KSUB=JJ
19	JK=JJ+IDC
	GOTO 32
C
C	   CALCULATE MATRIX OF DEPENDENCIES U
20	IF(IRANK)21,21,37
21	IRANK=-1
	GOTO 4
22	IRANK=IM1
	II=ISUB-IRANK
	JI=II
	DO 26 K=1,IRANK
	JI=JI-1
	JK=ISUB-1
	JJ=K-1
	DO 26 J=I,N
	IDC=IRANK
	SUM=0.D0
	KMI=JI
	KK=JK
	IF(JJ)25,25,23
23	DO 24 L=1,JJ
	IDC=IDC-1
	SUM=SUM-A(KMI)*A(KK)
	KMI=KMI-IDC
24	KK=KK-1
25	A(KK)=(SUM+A(KK))/A(KMI)
26	JK=JK+J
C
C	   CALCULATE I+TRANSPOSE(U)*U
	JJ=ISUB-I
	PIV=0.
	KK=ISUB-1
	DO 31 K=I,N
	JJ=JJ+K
	IDC=0
	DO 28 J=K,N
	SUM=0.D0
	KMI=JJ+IDC
	DO 27 L=II,KK
	JK=L+IDC
27	SUM=SUM+A(L)*A(JK)
	A(KMI)=SUM
28	IDC=IDC+J
	A(JJ)=A(JJ)+1.D0
	TRAC(K)=A(JJ)
C
C	   SEARCH NEXT DIAGONAL ELEMENT
	IF(PIV-A(JJ))29,30,30
29	KPIV=K
	KSUB=JJ
	PIV=A(JJ)
30	II=II+K
	KK=KK+K
31	CONTINUE
	GOTO 4
32	CONTINUE
33	IF(IRANK)35,34,35
34	IRANK=N
35	RETURN
C
C	   ERROR RETURNS
C
C	   RETURN IN CASE OF ILLEGAL DIMENSION
36	IRANK=-1
	RETURN
C
C	   INSTABLE FACTORIZATION OF I+TRANSPOSE(U)*U
37	IRANK=-2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MFUN
C
C	   PURPOSE
C	      APPLY A FUNCTION TO EACH ELEMENT OF A MATRIX TO FORM A
C	      RESULTANT MATRIX
C
C	   USAGE
C	      CALL MFUN (A,F,R,N,M,MS)
C	      AN EXTERNAL STATEMENT MUST PRECEDE CALL STATEMENT IN ORDER
C	      TO IDENTIFY PARAMETER F AS THE NAME OF A FUNCTION
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      F - NAME OF FORTRAN-FURNISHED OR USER FUNCTION SUBPROGRAM
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN MATRIX A AND R
C	      M - NUMBER OF COLUMNS IN MATRIX A AND R
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      PRECISION IS DEPENDENT UPON PRECISION OF FUNCTION USED
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      FUNCTION F IS APPLIED TO EACH ELEMENT OF MATRIX A
C	      TO FORM MATRIX R
C
C	..................................................................
C
	SUBROUTINE MFUN(A,F,R,N,M,MS)
	DIMENSION A(1),R(1)
C
C	   COMPUTE VECTOR LENGTH, IT
C
	CALL LOC(N,M,IT,N,M,MS)
C
C	   BUILD MATRIX R FOR ANY STORAGE MODE
C
	DO 5 I=1,IT
5	R(I)=F(A(I))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MINV
C
C	   PURPOSE
C	      INVERT A MATRIX
C
C	   USAGE
C	      CALL MINV(A,N,D,L,M)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY
C	          RESULTANT INVERSE.
C	      N - ORDER OF MATRIX A
C	      D - RESULTANT DETERMINANT
C	      L - WORK VECTOR OF LENGTH N
C	      M - WORK VECTOR OF LENGTH N
C
C	   REMARKS
C	      MATRIX A MUST BE A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT
C	      IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT
C	      THE MATRIX IS SINGULAR.
C
C	..................................................................
C
	SUBROUTINE MINV(A,N,D,L,M)
	DIMENSION A(1),L(1),M(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION A,D,BIGA,HOLD
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  ABS IN STATEMENT
C	   10 MUST BE CHANGED TO DABS.
C
C	   ...............................................................
C
C	   SEARCH FOR LARGEST ELEMENT
C
	D=1.0
	NK=-N
	DO 80 K=1,N
	NK=NK+N
	L(K)=K
	M(K)=K
	KK=NK+K
	BIGA=A(KK)
	DO 20 J=K,N
	IZ=N*(J-1)
	DO 20 I=K,N
	IJ=IZ+I
10	IF( ABS(BIGA)- ABS(A(IJ))) 15,20,20
15	BIGA=A(IJ)
	L(K)=I
	M(K)=J
20	CONTINUE
C
C	   INTERCHANGE ROWS
C
	J=L(K)
	IF(J-K) 35,35,25
25	KI=K-N
	DO 30 I=1,N
	KI=KI+N
	HOLD=-A(KI)
	JI=KI-K+J
	A(KI)=A(JI)
30	A(JI) =HOLD
C
C	   INTERCHANGE COLUMNS
C
35	I=M(K)
	IF(I-K) 45,45,38
38	JP=N*(I-1)
	DO 40 J=1,N
	JK=NK+J
	JI=JP+J
	HOLD=-A(JK)
	A(JK)=A(JI)
40	A(JI) =HOLD
C
C	   DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS
C	   CONTAINED IN BIGA)
C
45	IF(BIGA) 48,46,48
46	D=0.0
	RETURN
48	DO 55 I=1,N
	IF(I-K) 50,55,50
50	IK=NK+I
	A(IK)=A(IK)/(-BIGA)
55	CONTINUE
C
C	   REDUCE MATRIX
C
	DO 65 I=1,N
	IK=NK+I
	HOLD=A(IK)
	IJ=I-N
	DO 65 J=1,N
	IJ=IJ+N
	IF(I-K) 60,65,60
60	IF(J-K) 62,65,62
62	KJ=IJ-I+K
	A(IJ)=HOLD*A(KJ)+A(IJ)
65	CONTINUE
C
C	   DIVIDE ROW BY PIVOT
C
	KJ=K-N
	DO 75 J=1,N
	KJ=KJ+N
	IF(J-K) 70,75,70
70	A(KJ)=A(KJ)/BIGA
75	CONTINUE
C
C	   PRODUCT OF PIVOTS
C
	D=D*BIGA
C
C	   REPLACE PIVOT BY RECIPROCAL
C
	A(KK)=1.0/BIGA
80	CONTINUE
C
C	   FINAL ROW AND COLUMN INTERCHANGE
C
	K=N
100	K=(K-1)
	IF(K) 150,150,105
105	I=L(K)
	IF(I-K) 120,120,108
108	JQ=N*(K-1)
	JR=N*(I-1)
	DO 110 J=1,N
	JK=JQ+J
	HOLD=A(JK)
	JI=JR+J
	A(JK)=-A(JI)
110	A(JI) =HOLD
120	J=M(K)
	IF(J-K) 100,100,125
125	KI=K-N
	DO 130 I=1,N
	KI=KI+N
	HOLD=A(KI)
	JI=KI-K+J
	A(KI)=-A(JI)
130	A(JI) =HOLD
	GO TO 100
150	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MISR
C
C	   PURPOSE
C	      COMPUTE MEANS, STANDARD DEVIATIONS, SKEWNESS AND KURTOSIS,
C	      CORRELATION COEFFICIENTS, REGRESSION COEFFICIENTS, AND
C	      STANDARD ERRORS OF REGRESSION COEFFICIENTS WHEN THERE ARE
C	      MISSING DATA POINTS.  THE USER IDENTIFIES THE MISSING DATA
C	      BY MEANS OF A NUMERIC CODE.  THOSE VALUES HAVING THIS CODE
C	      ARE SKIPPED IN COMPUTING THE STATISTICS.  IN THE CASE OF THE
C	      CORRELATION COEFFICIENTS, ANY PAIR OF VALUES ARE SKIPPED IF
C	      EITHER ONE OF THEM ARE MISSING.
C
C	   USAGE
C	      CALL MISR (NO,M,X,CODE,XBAR,STD,SKEW,CURT,R,N,A,B,S,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      NO   - NUMBER OF OBSERVATIONS
C	      M    - NUMBER OF VARIABLES
C	      X    - INPUT DATA MATRIX OF SIZE NO X M.
C	      CODE - INPUT VECTOR OF LENGTH M, WHICH CONTAINS A NUMERIC
C	             MISSING DATA CODE FOR EACH VARIABLE. ANY OBSERVATION
C	             FOR A GIVEN VARIABLE HAVING A VALUE EQUAL TO THE CODE
C	             WILL BE DROPPED FOR THE COMPUTATIONS.
C	      XBAR - OUTPUT VECTOR OF LENGTH M CONTAINING MEANS
C	      STD  - OUTPUT VECTOR OF LENGTH M CONTAINING STANDARD DEVI-
C	             ATIONS
C	      SKEW - OUTPUT VECTOR OF LENGTH M CONTAINING SKEWNESS
C	      CURT - OUTPUT VECTOR OF LENGTH M CONTAINING KURTOSIS
C	      R    - OUTPUT MATRIX OF PRODUCT-MOMENT CORRELATION
C	             COEFFICIENTS.  THIS WILL BE THE UPPER TRIANGULAR
C	             MATRIX ONLY, SINCE THE M X M MATRIX OF COEFFICIENTS
C	             IS SYMMETRIC. (STORAGE MODE 1)
C	      N    - OUTPUT MATRIX OF NUMBER OF PAIRS OF OBSERVATIONS USED
C	             IN COMPUTING THE CORRELATION COEFFICIENTS.  ONLY THE
C	             UPPER TRIANGULAR PORTION OF THE MATRIX IS GIVEN.
C	             (STORAGE MODE 1)
C	      A    - OUTPUT MATRIX (M BY M)  CONTAINING INTERCEPTS OF
C	             REGRESSION LINES (A) OF THE FORM Y=A+BX.  THE FIRST
C	             SUBSCRIPT OF THIS MATRIX REFERS TO THE INDEPENDENT
C	             VARIABLE AND THE SECOND TO THE DEPENDENT VARIABLE.
C	             FOR EXAMPLE, A(1,3) CONTAINS THE INTERCEPT OF THE
C	             REGRESSION LINE FOR TWO VARIABLES WHERE VARIABLE 1
C	             IS INDEPENDENT AND VARIABLE 3 IS DEPENDENT.  NOTE
C	             THAT MATRIX A IS STORED IN A VECTOR FORM.
C	      B    - OUTPUT MATRIX (M BY M)  CONTAINING REGRESSION
C	             COEFFICIENTS (B) CORRESPONDING TO THE VALUES OF
C	             INTERCEPTS CONTAINED IN THE OUTPUT MATRIX A.
C	      S    - OUTPUT MATRIX (M BY M)  CONTAINING STANDARD ERRORS
C	             OF REGRESSION COEFFICIENTS CORRESPONDING TO THE
C	             COEFFICIENTS CONTAINED IN THE OUTPUT MATRIX B.
C	      IER  - 0, NO ERROR.
C	             1, IF NUMBER OF NON-MISSING DATA ELEMENTS FOR J-TH
C	                VARIABLE IS TWO OR LESS.  IN THIS CASE, STD(J),
C	                SKEW(J), AND CURT(J) ARE SET TO 10**75.  ALL
C	                VALUES OF R, A, B, AND S RELATED TO THIS VARIABLE
C	                ARE ALSO SET TO 10**75.
C	             2, IF VARIANCE OF J-TH VARIABLE IS LESS THAN
C	                10**(-20).  IN THIS CASE, STD(J), SKEW(J), AND
C	                CURT(J) ARE SET TO 10**75.  ALL VALUES OF R, A,
C	                B, AND S RELATED TO THIS VARIABLE ARE ALSO SET TO
C	                10**75.
C
C	   REMARKS
C	      THIS SUBROUTINE CANNOT DISTINGUISH A BLANK AND A ZERO.
C	      THEREFORE, IF A BLANK IS SPECIFIED AS A MISSING DATA CODE IN
C	      INPUT CARDS, IT WILL BE TREATED AS 0 (ZERO).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      LEAST SQUARES REGRESSION LINES AND PRODUCT-MOMENT CORRE-
C	      LATION COEFFICIENTS ARE COMPUTED.
C
C	..................................................................
C
	SUBROUTINE MISR (NO,M,X,CODE,XBAR,STD,SKEW,CURT,R,N,A,B,S,IER)
C
	DIMENSION X(1),CODE(1),XBAR(1),STD(1),SKEW(1),CURT(1),R(1),N(1)
	DIMENSION A(1),B(1),S(1)
C
C	   COMPUTE MEANS
C
	IER=0
	L=0
	DO 20 J=1,M
	FN=0.0
	XBAR(J)=0.0
	DO 15 I=1,NO
	L=L+1
	IF(X(L)-CODE(J)) 12, 15, 12
12	FN=FN+1.0
	XBAR(J)=XBAR(J)+X(L)
15	CONTINUE
	IF(FN) 16, 16, 17
16	XBAR(J)=0.0
	GO TO 20
17	XBAR(J)=XBAR(J)/FN
20	CONTINUE
C
C	   SET-UP WORK AREAS AND TEST WHETHER DATA IS MISSING
C
	L=0
	DO 55 J=1,M
	LJJ=NO*(J-1)
	SKEW(J)=0.0
	CURT(J)=0.0
	KI=M*(J-1)
	KJ=J-M
	DO 54 I=1,J
	KI=KI+1
	KJ=KJ+M
	SUMX=0.0
	SUMY=0.0
	TI=0.0
	TJ=0.0
	TII=0.0
	TJJ=0.0
	TIJ=0.0
	NIJ=0
	LI=NO*(I-1)
	LJ=LJJ
	L=L+1
	DO 38 K=1,NO
	LI=LI+1
	LJ=LJ+1
	IF(X(LI)-CODE(I)) 30, 38, 30
30	IF(X(LJ)-CODE(J)) 35, 38, 35
C
C	   BOTH DATA ARE PRESENT
C
35	XX=X(LI)-XBAR(I)
	YY=X(LJ)-XBAR(J)
	TI=TI+XX
	TII=TII+XX**2
	TJ=TJ+YY
	TJJ=TJJ+YY**2
	TIJ=TIJ+XX*YY
	NIJ=NIJ+1
	SUMX=SUMX+X(LI)
	SUMY=SUMY+X(LJ)
	IF(I-J) 38, 37, 37
37	SKEW(J)=SKEW(J)+YY**3
	CURT(J)=CURT(J)+YY**4
38	CONTINUE
C
C	   COMPUTE SUM OF CROSS-PRODUCTS OF DEVIATIONS
C
	IF(NIJ) 40, 40, 39
39	FN=NIJ
	R(L)=TIJ-TI*TJ/FN
	N(L)=NIJ
	TII=TII-TI*TI/FN
	TJJ=TJJ-TJ*TJ/FN
C
C	   COMPUTE STANDARD DEVIATION, SKEWNESS, AND KURTOSIS
C
40	IF(I-J) 47, 41, 47
41	IF(NIJ-2) 42,42,43
42	IER=1
	R(L)=1.7E38
	A(KI)=1.7E38
	B(KI)=1.7E38
	S(KI)=1.7E38
	GO TO 45
C
43	STD(J)=R(L)
	R(L)=1.0
	A(KI)=0.0
	B(KI)=1.0
	S(KI)=0.0
C
	IF(STD(J)-(1.0E-20)) 44,44,46
44	IER=2
45	STD(J)=1.7E38
	SKEW(J)=1.7E38
	CURT(J)=1.7E38
	GO TO 55
C
46	WORK=STD(J)/FN
	SKEW(J)=(SKEW(J)/FN)/(WORK*SQRT(WORK))
	CURT(J)=((CURT(J)/FN)/WORK**2)-3.0
	STD(J)=SQRT(STD(J)/(FN-1.0))
	GO TO 55
C
C	   COMPUTE REGRESSION COEFFICIENTS
C
47	IF(NIJ-2) 48,48,50
48	IER=1
49	R(L)=1.7E38
	A(KI)=1.7E38
	B(KI)=1.7E38
	S(KI)=1.7E38
	A(KJ)=1.7E38
	B(KJ)=1.7E38
	S(KJ)=1.7E38
	GO TO 54
C
50	IF(TII-(1.0E-20)) 52,52,51
51	IF(TJJ-(1.0E-20)) 52,52,53
52	IER=2
	GO TO 49
C
53	SUMX=SUMX/FN
	SUMY=SUMY/FN
	B(KI)=R(L)/TII
	A(KI)=SUMY-B(KI)*SUMX
	B(KJ)=R(L)/TJJ
	A(KJ)=SUMX-B(KJ)*SUMY
C
C	   COMPUTE CORRELATION COEFFICIENTS
C
	R(L)=R(L)/(SQRT(TII)*SQRT(TJJ))
C
C	   COMPUTE STANDARD ERRORS OF REGRESSION COEFFICIENTS
C
	RR=R(L)**2
	SUMX=(TJJ-TJJ*RR)/(FN-2)
	S(KI)=SQRT(SUMX/TII)
	SUMY=(TII-TII*RR)/(FN-2)
	S(KJ)=SQRT(SUMY/TJJ)
C
54	CONTINUE
55	CONTINUE
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MLSS
C
C	   PURPOSE
C	      SUBROUTINE MLSS IS THE SECOND STEP IN THE PROCEDURE FOR
C	      CALCULATING THE LEAST SQUARES SOLUTION OF MINIMAL LENGTH
C	      OF A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH SYMMETRIC
C	      POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX.
C
C	   USAGE
C	      CALL MLSS(A,N,IRANK,TRAC,INC,RHS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - COEFFICIENT MATRIX IN FACTORED FORM AS GENERATED
C	              BY SUBROUTINE MFSS FROM INITIALLY GIVEN SYMMETRIC
C	              COEFFICIENT MATRIX A STORED IN N*(N+1)/2 LOCATIONS
C	              A REMAINS UNCHANGED
C	      N     - DIMENSION OF COEFFICIENT MATRIX
C	      IRANK - RANK OF COEFFICIENT MATRIX, CALCULATED BY MEANS OF
C	              SUBROUTINE MFSS
C	      TRAC  - VECTOR OF DIMENSION N CONTAINING THE
C	              SUBSCRIPTS OF PIVOT ROWS AND COLUMNS, I.E. THE
C	              PRODUCT REPRESENTATION IN TRANSPOSITIONS OF THE
C	              PERMUTATION WHICH WAS APPLIED TO ROWS AND COLUMNS
C	              OF A IN THE FACTORIZATION PROCESS
C	              TRAC IS A RESULTANT ARRAY OF SUBROUTINE MFSS
C	      INC   - INPUT VARIABLE WHICH SHOULD CONTAIN THE VALUE ZERO
C	              IF THE SYSTEM OF SIMULTANEOUS EQUATIONS IS KNOWN
C	              TO BE COMPATIBLE AND A NONZERO VALUE OTHERWISE
C	      RHS   - VECTOR OF DIMENSION N CONTAINING THE RIGHT HAND SIDE
C	              ON RETURN RHS CONTAINS THE MINIMAL LENGTH SOLUTION
C	      IER   - RESULTANT ERROR PARAMETER
C	              IER = 0 MEANS NO ERRORS
C	              IER =-1 MEANS N AND/OR IRANK IS NOT POSITIVE AND/OR
C	                      IRANK IS GREATER THAN N
C	              IER = 1 MEANS THE FACTORIZATION CONTAINED IN A HAS
C	                      ZERO DIVISORS AND/OR TRAC CONTAINS
C	                      VALUES OUTSIDE THE FEASIBLE RANGE 1 UP TO N
C
C	   REMARKS
C	      THE MINIMAL LENGTH SOLUTION IS PRODUCED IN THE STORAGE
C	      LOCATIONS OCCUPIED BY THE RIGHT HAND SIDE.
C	      SUBROUTINE MLSS DOES TAKE CARE OF THE PERMUTATION
C	      WHICH WAS APPLIED TO ROWS AND COLUMNS OF A.
C	      OPERATION IS BYPASSED IN CASE OF A NON POSITIVE VALUE
C	      OF IRANK
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      LET T, U, TU BE THE COMPONENTS OF THE FACTORIZATION OF A,
C	      AND LET THE RIGHT HAND SIDE BE PARTITIONED INTO A FIRST
C	      PART X1 OF DIMENSION IRANK AND A SECOND PART X2 OF DIMENSION
C	      N-IRANK. THEN THE FOLLOWING OPERATIONS ARE APPLIED IN
C	      SEQUENCE
C	      (1) INTERCHANGE RIGHT HAND SIDE
C	      (2) X1 = X1 + U * X2
C	      (3) X2 =-TRANSPOSE(U) * X1
C	      (4) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
C	      (5) X1 = X1 + U * X2
C	      (6) X1 = INVERSE(T) * INVERSE(TRANSPOSE(T)) * X1
C	      (7) X2 =-TRANSPOSE(U) * X1
C	      (8) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2
C	      (9) X1 = X1 + U * X2
C	      (10)X2 = TRANSPOSE(U) * X1
C	      (11) REINTERCHANGE CALCULATED SOLUTION
C	      IF THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS IS SPECIFIED
C	      TO BE COMPATIBLE THEN STEPS (2), (3), (4) AND (5) ARE
C	      CANCELLED.
C	      IF THE COEFFICIENT MATRIX HAS RANK N, THEN THE ONLY STEPS
C	      PERFORMED ARE (1), (6) AND (11).
C
C	..................................................................
C
	SUBROUTINE MLSS(A,N,IRANK,TRAC,INC,RHS,IER)
C
C
C	   DIMENSIONED DUMMY VARIABLES
	DIMENSION A(1),TRAC(1),RHS(1)
	DOUBLE PRECISION SUM
C
C	   TEST OF SPECIFIED DIMENSIONS
	IDEF=N-IRANK
	IF(N)33,33,1
1	IF(IRANK)33,33,2
2	IF(IDEF)33,3,3
C
C	   CALCULATE AUXILIARY VALUES
3	ITE=IRANK*(IRANK+1)/2
	IX2=IRANK+1
	NP1=N+1
	IER=0
C
C	   INTERCHANGE RIGHT HAND SIDE
	JJ=1
	II=1
4	DO 6 I=1,N
	J=TRAC(II)
	IF(J)31,31,5
5	HOLD=RHS(II)
	RHS(II)=RHS(J)
	RHS(J)=HOLD
6	II=II+JJ
	IF(JJ)32,7,7
C
C	   PERFORM STEP 2 IF NECESSARY
7	ISW=1
	IF(INC*IDEF)8,28,8
C
C	   CALCULATE X1 = X1 + U * X2
8	ISTA=ITE
	DO 10 I=1,IRANK
	ISTA=ISTA+1
	JJ=ISTA
	SUM=0.D0
	DO 9 J=IX2,N
	SUM=SUM+A(JJ)*RHS(J)
9	JJ=JJ+J
10	RHS(I)=RHS(I)+SUM
	GOTO(11,28,11),ISW
C
C	   CALCULATE X2 = TRANSPOSE(U) * X1
11	ISTA=ITE
	DO 15 I=IX2,N
	JJ=ISTA
	SUM=0.D0
	DO 12 J=1,IRANK
	JJ=JJ+1
12	SUM=SUM+A(JJ)*RHS(J)
	GOTO(13,13,14),ISW
13	SUM=-SUM
14	RHS(I)=SUM
15	ISTA=ISTA+I
	GOTO(16,29,30),ISW
C
C	   INITIALIZE STEP (4) OR STEP (8)
16	ISTA=IX2
	IEND=N
	JJ=ITE+ISTA
C
C	   DIVISION OF X1 BY TRANSPOSE OF TRIANGULAR MATRIX
17	SUM=0.D0
	DO 20 I=ISTA,IEND
	IF(A(JJ))18,31,18
18	RHS(I)=(RHS(I)-SUM)/A(JJ)
	IF(I-IEND)19,21,21
19	JJ=JJ+ISTA
	SUM=0.D0
	DO 20 J=ISTA,I
	SUM=SUM+A(JJ)*RHS(J)
20	JJ=JJ+1
C
C	   DIVISION OF X1 BY TRIANGULAR MATRIX
21	SUM=0.D0
	II=IEND
	DO 24 I=ISTA,IEND
	RHS(II)=(RHS(II)-SUM)/A(JJ)
	IF(II-ISTA)25,25,22
22	KK=JJ-1
	SUM=0.D0
	DO 23 J=II,IEND
	SUM=SUM+A(KK)*RHS(J)
23	KK=KK+J
	JJ=JJ-II
24	II=II-1
25	IF(IDEF)26,30,26
26	GOTO(27,11,8),ISW
C
C	   PERFORM STEP (5)
27	ISW=2
	GOTO 8
C
C	   PERFORM STEP (6)
28	ISTA=1
	IEND=IRANK
	JJ=1
	ISW=2
	GOTO 17
C
C	   PERFORM STEP (8)
29	ISW=3
	GOTO 16
C
C	   REINTERCHANGE CALCULATED SOLUTION
30	II=N
	JJ=-1
	GOTO 4
C
C	   ERROR RETURN IN CASE OF ZERO DIVISOR
31	IER=1
32	RETURN
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSION
33	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MOMEN
C
C	   PURPOSE
C	      TO FIND THE THE FIRST FOUR MOMENTS FOR GROUPED DATA ON
C	      EQUAL CLASS INTERVALS.
C
C	   USAGE
C	      CALL MOMEN (F,UBO,NOP,ANS)
C
C	   DESCRIPTION OF PARAMETERS
C	      F   - GROUPED DATA (FREQUENCIES).  GIVEN AS A VECTOR OF
C	            LENGTH (UBO(3)-UBO(1))/UBO(2)
C	      UBO - 3 CELL VECTOR, UBO(1) IS LOWER BOUND AND UBO(3) UPPER
C	            BOUND ON DATA.  UBO(2) IS CLASS INTERVAL.  NOTE THAT
C	            UBO(3) MUST BE GREATER THAN UBO(1).
C	      NOP - OPTION PARAMETER.  IF NOP = 1, ANS(1) = MEAN.  IF
C	            NOP = 2, ANS(2) = SECOND MOMENT.  IF NOP = 3, ANS(3) =
C	            THIRD MOMENT.  IF NOP = 4, ANS(4) = FOURTH MOMENT.
C	            IF NOP = 5, ALL FOUR MOMENTS ARE FILLED IN.
C	      ANS - OUTPUT VECTOR OF LENGTH 4 INTO WHICH MOMENTS ARE PUT.
C
C	   REMARKS
C	      NOTE THAT THE FIRST MOMENT IS NOT CENTRAL BUT THE VALUE OF
C	      THE MEAN ITSELF.  THE MEAN IS ALWAYS CALCULATED.  MOMENTS
C	      ARE BIASED AND NOT CORRECTED FOR GROUPING.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO M. G. KENDALL, 'THE ADVANCED THEORY OF STATISTICS',
C	      V.1, HAFNER PUBLISHING COMPANY, 1958, CHAPTER 3.
C
C	..................................................................
C
	SUBROUTINE MOMEN (F,UBO,NOP,ANS)
	DIMENSION F(1),UBO(1),ANS(1)
C
	DO 100 I=1,4
100	ANS(I)=0.0
C
C	CALCULATE THE NUMBER OF CLASS INTERVALS
C
	N=(UBO(3)-UBO(1))/UBO(2)+0.5
C
C	CALCULATE TOTAL FREQUENCY
C
	T=0.0
	DO 110 I=1,N
110	T=T+F(I)
C
	IF(NOP-5) 130, 120, 115
115	NOP=5
120	JUMP=1
	GO TO 150
130	JUMP=2
C
C	   FIRST MOMENT
C
150	DO 160 I=1,N
	FI=I
160	ANS(1)=ANS(1)+F(I)*(UBO(1)+(FI-0.5)*UBO(2))
	ANS(1)=ANS(1)/T
C
	GO TO (350,200,250,300,200), NOP
C
C	   SECOND MOMENT
C
200	DO 210 I=1,N
	FI=I
210	ANS(2)=ANS(2)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**2
	ANS(2)=ANS(2)/T
	GO TO (250,350), JUMP
C
C	   THIRD MOMENT
C
250	DO 260 I=1,N
	FI=I
260	ANS(3)=ANS(3)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**3
	ANS(3)=ANS(3)/T
	GO TO (300,350), JUMP
C
C	   FOURTH MOMENT
C
300	DO 310 I=1,N
	FI=I
310	ANS(4)=ANS(4)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**4
	ANS(4)=ANS(4)/T
350	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MPAIR
C
C	   PURPOSE
C	      PERFORM THE WILCOXON MATCHED-PAIRS SIGNED-RANKS TEST, GIVEN
C	      TWO VECTORS OF N OBSERVATIONS OF THE MATCHED SAMPLES.
C
C	   USAGE
C	      CALL MPAIR (N,A,B,K,T,Z,P,D,E,L,IE)
C
C	   DESCRIPTION OF PARAMETERS
C	      N - NUMBER OF OBSERVATIONS IN THE VECTORS A AND B
C	      A - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE FIRST
C	          SAMPLE
C	      B - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE SECOND
C	          SAMPLE
C	      K - OUTPUT VARIABLE CONTAINING THE NUMBER OF PAIRS OF THE
C	          MATCHED SAMPLES WHOSE DIFFERENCES ARE NON ZERO (0)
C	      T - OUTPUT VARIABLE CONTAINING THE SUM OF THE RANKS OF PLUS
C	          OR MINUS DIFFERENCES, WHICHEVER IS SMALLER
C	      Z - VALUE OF THE STANDARDIZED NORMAL SCORE COMPUTED FOR THE
C	          WILCOXON MATCHED-PAIRS SIGNED-RANKS TEST
C	      P - COMPUTED PROBABILITY OF OBTAINING A VALUE OF Z AS
C	          EXTREME AS THE ONE FOUND BY THE TEST
C	      D - WORKING VECTOR OF LENGTH N
C	      E - WORKING VECTOR OF LENGTH N
C	      L - WORKING VECTOR OF LENGTH N
C	      IE- 1, IF SAMPLES A AND B ARE IDENTICAL.
C	          0 OTHERWISE.  IF IE=1, THEN T=P=0, AND Z=-10**75
C
C	   REMARKS
C	      THE COMPUTED PROBABILTY IS FOR A ONE-TAILED TEST.
C	      MULTIPLYING P BY 2 WILL GIVE THE VALUE FOR A TWO-TAILED
C	      TEST.
C
C	   SUBROUTINES AND FUNCTIONS SUBPROGRAMS REQUIRED
C	      RANK
C	      NDTR
C
C	   METHOD
C	      REFER TO DIXON AND MASSEY, AN INTRODUCTION TO STATISTICAL
C	      ANALYSIS (MC GRAW-HILL, 1957)
C
C	..................................................................
C
	SUBROUTINE MPAIR (N,A,B,K,T,Z,P,D,E,L,IE)
C
	DIMENSION A(1),B(1),D(1),E(1),L(1)
C
	IE=0
	K=N
C
C	   FIND DIFFERENCES OF MATCHED-PAIRS
C
	BIG=0.0
	DO 55 I=1,N
	DIF=A(I)-B(I)
	IF(DIF) 10, 20, 30
C
C	   DIFFERENCE HAS A NEGATIVE SIGN (-)
C
10	L(I)=1
	GO TO 40
C
C	   DIFFERENCE IS ZERO (0)
C
20	L(I)=2
	K=K-1
	GO TO 40
C
C	   DIFFERENCE HAS A POSITIVE SIGN (+)
C
30	L(I)=3
C
40	DIF= ABS(DIF)
	IF(BIG-DIF) 45, 50, 50
45	BIG=DIF
50	D(I)=DIF
C
55	CONTINUE
	IF(K) 57,57,59
57	IE=1
	T=0.0
	Z=-1.7E38
	P=0
	GO TO 100
C
C	   STORE A LARGE VALUE IN PLACE OF 0 DIFFERENCE IN ORDER TO
C	   ASSIGN A LARGE RANK (LARGER THAN K), SO THAT ABSOLUTE VALUES
C	   OF SIGNED DIFFERENCES WILL BE PROPERLY RANKED
C
59	BIG=BIG*2.0
	DO 65 I=1,N
	IF(L(I)-2) 65, 60, 65
60	D(I)=BIG
65	CONTINUE
C
	CALL RANK (D,E,N)
C
C	   FIND SUMS OF RANKS OF (+) DIFFERENCES AND (-) DIFFERENCES
C
	SUMP=0.0
	SUMM=0.0
	DO 80 I=1,N
	IF(L(I)-2) 70, 80, 75
70	SUMM=SUMM+E(I)
	GO TO 80
75	SUMP=SUMP+E(I)
80	CONTINUE
C
C	   SET T = SMALLER SUM
C
	IF(SUMP-SUMM) 85, 85, 90
85	T=SUMP
	GO TO 95
90	T=SUMM
C
C	   COMPUTE MEAN, STANDARD DEVIATION, AND Z
C
95	FK=K
	U=FK*(FK+1.0)/4.0
	S= SQRT((FK*(FK+1.0)*(2.0*FK+1.0))/24.0)
	Z=(T-U)/S
C
C	   COMPUTE THE PROBABILITY OF A VALUE AS EXTREME AS Z
C
	CALL NDTR (Z,P,BIG)
C
100	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MPRC
C
C	   PURPOSE
C	      TO PERMUTE THE ROWS OR COLUMNS OF A GIVEN MATRIX ACCORDING
C	      TO A GIVEN TRANSPOSITION VECTOR OR ITS INVERSE.  (SEE THE
C	      DISCUSSION ON PERMUTATIONS FOR DEFINITIONS AND NOTATION.)
C
C	   USAGE
C	      CALL MPRC(A,M,N,ITRA,INV,IROCO,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - GIVEN M BY N MATRIX AND RESULTING PERMUTED MATRIX
C	      M     - NUMBER OF ROWS OF A
C	      N     - NUMBER OF COLUMNS OF A
C	      ITRA  - GIVEN TRANSPOSITION VECTOR (DIMENSION M IF ROWS ARE
C	              PERMUTED, N IF COLUMNS ARE PERMUTED)
C	      INV   - INPUT PARAMETER
C	              INV NON-ZERO  -  PERMUTE ACCORDING TO ITRA
C	              INV    =   0  -  PERMUTE ACCORDING TO ITRA INVERSE
C	      IROCO - INPUT PARAMETER
C	              IROCO NON-ZERO  -  PERMUTE THE COLUMNS OF A
C	              IROCO    =   0  -  PERMUTE THE ROWS OF A
C	      IER   - RESULTING ERROR PARAMETER
C	              IER = -1  -  M AND N ARE NOT BOTH POSITIVE
C	              IER =  0  -  NO ERROR
C	              IER =  1  -  ITRA IS NOT A TRANSPOSITION VECTOR ON
C	                           1,...,M IF ROWS ARE PERMUTED, 1,...,N
C	                           IF COLUMNS ARE PERMUTED
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE IS NO COMPUTATION.
C	      (2)  IF IER= 1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE
C	           TO ERROR, BUT THE MATRIX A WILL REFLECT THE ROW OR
C	           COLUMN INTERCHANGES PERFORMED BEFORE THE ERROR WAS
C	           DETECTED.
C	      (3)  THE MATRIX A IS ASSUMED TO BE STORED COLUMNWISE.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE ROWS OR COLUMNS ARE PERMUTED ELEMENTWISE, INTERCHANGING
C	      ROW OR COLUMN 1 AND ITRA(1),...,ROW OR COLUMN K AND ITRA(K)
C	      IN THAT ORDER IF INV=0, AND OTHERWISE INTERCHANGING ROW OR
C	      COLUMN K AND ITRA(K),...,ROW OR COLUMN 1 AND ITRA(1), WHERE
C	      K IS M OR N DEPENDING ON WHETHER WE PERMUTE ROWS OR COLUMNS.
C
C	..................................................................
C
	SUBROUTINE MPRC(A,M,N,ITRA,INV,IROCO,IER)
C
C
	DIMENSION A(1),ITRA(1)
C
C	   TEST OF DIMENSIONS
	IF(M)14,14,1
1	IF(N)14,14,2
C
C	   DETERMINE WHICH ARE TO BE PERMUTED-THE ROWS OR THE COLUMNS
2	IF(IROCO)3,4,3
C
C	   INITIALIZE FOR COLUMN INTERCHANGES
3	MM=M
	MMM=-1
	L=M
	LL=N
	GO TO 5
C
C	   INITIALIZE FOR ROW INTERCHANGES
4	MM=1
	MMM=M
	L=N
	LL=M
C
C	   INITIALIZE LOOP OVER ALL ROWS OR COLUMNS
5	IA=1
	ID=1
C
C	   TEST FOR INVERSE OPERATION
	IF(INV)6,7,6
6	IA=LL
	ID=-1
7	DO 12 I=1,LL
	K=ITRA(IA)
	IF(K-IA)8,12,9
8	IF(K)13,13,10
9	IF(LL-K)13,10,10
C
C	   INITIALIZE ROW OR COLUMN INTERCHANGE
10	IL=IA*MM
	K=K*MM
C
C	   PERFORM ROW OR COLUMN INTERCHANGE
	DO 11 J=1,L
	SAVE=A(IL)
	A(IL)=A(K)
	A(K)=SAVE
	K=K+MMM
11	IL=IL+MMM
C
C	   ADDRESS NEXT INTERCHANGE STEP
12	IA=IA+ID
C
C	   NORMAL EXIT
	IER=0
	RETURN
C
C	   ERROR RETURN IN CASE ITRA IS NOT A TRANSPOSITION VECTOR
13	IER=1
	RETURN
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
14	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MPRD
C
C	   PURPOSE
C	      MULTIPLY TWO MATRICES TO FORM A RESULTANT MATRIX
C
C	   USAGE
C	      CALL MPRD(A,B,R,N,M,MSA,MSB,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A AND R
C	      M - NUMBER OF COLUMNS IN A AND ROWS IN B
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSB - SAME AS MSA EXCEPT FOR MATRIX B
C	      L - NUMBER OF COLUMNS IN B AND R
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B
C	      NUMBER OF COLUMNS OF MATRIX A MUST BE EQUAL TO NUMBER OF ROW
C	      OF MATRIX B
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      THE M BY L MATRIX B IS PREMULTIPLIED BY THE N BY M MATRIX A
C	      AND THE RESULT IS STORED IN THE N BY L MATRIX R. THIS IS A
C	      ROW INTO COLUMN PRODUCT.
C	      THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT
C	      MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES
C	                    A                B                R
C	                 GENERAL          GENERAL          GENERAL
C	                 GENERAL          SYMMETRIC        GENERAL
C	                 GENERAL          DIAGONAL         GENERAL
C	                 SYMMETRIC        GENERAL          GENERAL
C	                 SYMMETRIC        SYMMETRIC        GENERAL
C	                 SYMMETRIC        DIAGONAL         GENERAL
C	                 DIAGONAL         GENERAL          GENERAL
C	                 DIAGONAL         SYMMETRIC        GENERAL
C	                 DIAGONAL         DIAGONAL         DIAGONAL
C
C	..................................................................
C
	SUBROUTINE MPRD(A,B,R,N,M,MSA,MSB,L)
	DIMENSION A(1),B(1),R(1)
C
C	   SPECIAL CASE FOR DIAGONAL BY DIAGONAL
C
	MS=MSA*10+MSB
	IF(MS-22) 30,10,30
10	DO 20 I=1,N
20	R(I)=A(I)*B(I)
	RETURN
C
C	   ALL OTHER CASES
C
30	IR=1
	DO 90 K=1,L
	DO 90 J=1,N
	R(IR)=0
	DO 80 I=1,M
	IF(MS) 40,60,40
40	CALL LOC(J,I,IA,N,M,MSA)
	CALL LOC(I,K,IB,M,L,MSB)
	IF(IA) 50,80,50
50	IF(IB) 70,80,70
60	IA=N*(I-1)+J
	IB=M*(K-1)+I
70	R(IR)=R(IR)+A(IA)*B(IB)
80	CONTINUE
90	IR=IR+1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MSTR
C
C	   PURPOSE
C	      CHANGE STORAGE MODE OF A MATRIX
C
C	   USAGE
C	      CALL MSTR(A,R,N,MSA,MSR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS AND COLUMNS IN A AND R
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSR - SAME AS MSA EXCEPT FOR MATRIX R
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX A MUST BE A SQUARE MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      MATRIX A IS RESTRUCTURED TO FORM MATRIX R.
C	       MSA MSR
C	        0   0  MATRIX A IS MOVED TO MATRIX R
C	        0   1  THE UPPER TRIANGLE ELEMENTS OF A GENERAL MATRIX
C	               ARE USED TO FORM A SYMMETRIC MATRIX
C	        0   2  THE DIAGONAL ELEMENTS OF A GENERAL MATRIX ARE USED
C	               TO FORM A DIAGONAL MATRIX
C	        1   0  A SYMMETRIC MATRIX IS EXPANDED TO FORM A GENERAL
C	               MATRIX
C	        1   1  MATRIX A IS MOVED TO MATRIX R
C	        1   2  THE DIAGONAL ELEMENTS OF A SYMMETRIC MATRIX ARE
C	               USED TO FORM A DIAGONAL MATRIX
C	        2   0  A DIAGONAL MATRIX IS EXPANDED BY INSERTING MISSING
C	               ZERO ELEMENTS TO FORM A GENERAL MATRIX
C	        2   1  A DIAGONAL MATRIX IS EXPANDED BY INSERTING MISSING
C	               ZERO ELEMENTS TO FORM A SYMMETRIC MATRIX
C	        2   2  MATRIX A IS MOVED TO MATRIX R
C
C	..................................................................
C
	SUBROUTINE MSTR(A,R,N,MSA,MSR)
	DIMENSION A(1),R(1)
C
C	..................................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION A,R
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	..................................................................
C
	DO 20 I=1,N
	DO 20 J=1,N
C
C	   IF R IS GENERAL, FORM ELEMENT
C
	IF(MSR) 5,10,5
C
C	   IF IN LOWER TRIANGLE OF SYMMETRIC OR DIAGONAL R, BYPASS
C
5	IF(I-J) 10,10,20
10	CALL LOC(I,J,IR,N,N,MSR)
C
C	   IF IN UPPER AND OFF DIAGONAL  OF DIAGONAL R, BYPASS
C
	IF(IR) 20,20,15
C
C	   OTHERWISE, FORM R(I,J)
C
15	R(IR)=0.0
	CALL LOC(I,J,IA,N,N,MSA)
C
C	   IF THERE IS NO A(I,J), LEAVE R(I,J) AT 0.0
C
	IF(IA) 20,20,18
18	R(IR)=A(IA)
20	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MSUB
C
C	   PURPOSE
C	      SUBTRACT TWO MATRICES ELEMENT BY ELEMENT TO FORM RESULTANT
C	      MATRIX
C
C	   USAGE
C	      CALL MSUB(A,B,R,N,M,MSA,MSB)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      B - NAME OF INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A,B,R
C	      M - NUMBER OF COLUMNS IN A,B,R
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSB - SAME AS MSA EXCEPT FOR MATRIX B
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      STRUCTURE OF OUTPUT MATRIX IS FIRST DETERMINED. SUBTRACTION
C	      OF MATRIX B ELEMENTS FROM CORRESPONDING MATRIX A ELEMENTS
C	      IS THEN PERFORMED.
C	      THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT
C	      MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES
C	                    A                B                 R
C	                 GENERAL          GENERAL          GENERAL
C	                 GENERAL          SYMMETRIC        GENERAL
C	                 GENERAL          DIAGONAL         GENERAL
C	                 SYMMETRIC        GENERAL          GENERAL
C	                 SYMMETRIC        SYMMETRIC        SYMMETRIC
C	                 SYMMETRIC        DIAGONAL         SYMMETRIC
C	                 DIAGONAL         GENERAL          GENERAL
C	                 DIAGONAL         SYMMETRIC        SYMMETRIC
C	                 DIAGONAL         DIAGONAL         DIAGONAL
C
C	..................................................................
C
	SUBROUTINE MSUB(A,B,R,N,M,MSA,MSB)
	DIMENSION A(1),B(1),R(1)
C
C	   DETERMINE STORAGE MODE OF OUTPUT MATRIX
C
	IF(MSA-MSB) 7,5,7
5	CALL LOC(N,M,NM,N,M,MSA)
	GO TO 100
7	MTEST=MSA*MSB
	MSR=0
	IF(MTEST) 20,20,10
10	MSR=1
20	IF(MTEST-2) 35,35,30
30	MSR=2
C
C	   LOCATE ELEMENTS AND PERFORM SUBTRACTION
C
35	DO 90 J=1,M
	DO 90 I=1,N
	CALL LOC(I,J,IJR,N,M,MSR)
	IF(IJR) 40,90,40
40	CALL LOC(I,J,IJA,N,M,MSA)
	AEL=0.0
	IF(IJA) 50,60,50
50	AEL=A(IJA)
60	CALL LOC(I,J,IJB,N,M,MSB)
	BEL=0.0
	IF(IJB) 70,80,70
70	BEL=B(IJB)
80	R(IJR)=AEL-BEL
90	CONTINUE
	RETURN
C
C	   SUBTRACT MATRICES FOR OTHER CASES
C
100	DO 110 I=1,NM
110	R(I)=A(I)-B(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MTDS
C
C	   PURPOSE
C	      MULTIPLY A GENERAL MATRIX A ON THE LEFT OR RIGHT BY
C	      INVERSE(T),INVERSE(TRANSPOSE(T)) OR INVERSE(TRANSPOSE(T*T))
C	      THE TRIANGULAR MATRIX T IS STORED COLUMNWISE IN COMPRESSED
C	      FORM, I.E. UPPER TRIANGULAR PART ONLY.
C
C	   USAGE
C	      CALL MTDS(A,M,N,T,IOP,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - GIVEN GENERAL MATRIX WHITH M ROWS AND N COLUMNS.
C	      M     - NUMBER OF ROWS OF MATRIX A
C	      N     - NUMBER OF COLUMNS OF MATRIX A
C	      T     - GIVEN TRIANGULAR MATRIX STORED COLUMNWISE UPPER
C	              TRIANGULAR PART ONLY. ITS NUMBER OF ROWS AND
C	              COLUMNS K IS IMPLIED BY COMPATIBILITY.
C	              K = M IF IOP IS POSITIVE,
C	              K = N IF IOP IS NEGATIVE.
C	              T OCCUPIES K*(K+1)/2 STORAGE POSITIONS.
C	      IOP   - INPUT VARIABLE FOR SELECTION OF OPERATION
C	              IOP = 1 - A IS REPLACED BY INVERSE(T)*A
C	              IOP =-1 - A IS REPLACED BY A*INVERSE(T)
C	              IOP = 2 - A IS REPLACED BY INVERSE(TRANSPOSE(T))*A
C	              IOP =-2 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T))
C	              IOP = 3 - A IS REPLACED BY INVERSE(TRANSPOSE(T)*T)*A
C	              IOP =-3 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)*T)
C	      IER   - RESULTING ERROR PARAMETER
C	              IER =-1 MEANS M AND N ARE NOT BOTH POSITIVE
C	                            AND/OR IOP IS ILLEGAL
C	              IER = 0 MEANS OPERATION WAS SUCCESSFUL
C	              IER = 1 MEANS TRIANGULAR MATRIX T IS SINGULAR
C
C	   REMARKS
C	      SUBROUTINE MTDS MAY BE USED TO CALCULATE THE SOLUTION OF
C	      A SYSTEM OF EQUATIONS WITH SYMMETRIC POSITIVE DEFINITE
C	      COEFFICIENT MATRIX. THE FIRST STEP TOWARDS THE SOLUTION
C	      IS TRIANGULAR FACTORIZATION BY MEANS OF MFSD, THE SECOND
C	      STEP IS APPLICATION OF MTDS.
C	      SUBROUTINES MFSD AND MTDS MAY BE USED IN ORDER TO CALCULATE
C	      THE PRODUCT TRANSPOSE(A)*INVERSE(B)*A WITH GIVEN SYMMETRIC
C	      POSITIVE DEFINITE B AND GIVEN A EFFICIENTLY IN THREE STEPS
C	      1) TRIANGULAR FACTORIZATION OF B (B=TRANSPOSE(T)*T)
C	      2) MULTIPLICATION OF A ON THE LEFT BY INVERSE(TRANSPOSE(T))
C	         A IS REPLACED BY C=INVERSE(TRANSPOSE(T))*A
C	      3) CALCULATION OF THE RESULT FORMING TRANSPOSE(C)*C
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      CALCULATION OF X = INVERSE(T)*A IS DONE USING BACKWARD
C	      SUBSTITUTION TO OBTAIN X FROM T*X = A.
C	      CALCULATION OF Y = INVERSE(TRANSPOSE(T))*A IS DONE USING
C	      FORWARD SUBSTITUTION TO OBTAIN Y FROM TRANSPOSE(T)*Y = A.
C	      CALCULATION OF Z = INVERSE(TRANSPOSE(T)*T)*A IS DONE
C	      SOLVING FIRST TRANSPOSE(T)*Y = A AND THEN T*Z = Y, IE.
C	      USING THE ABOVE TWO STEPS IN REVERSE ORDER
C
C	..................................................................
C
	SUBROUTINE MTDS(A,M,N,T,IOP,IER)
C
C
	DIMENSION A(1),T(1)
	DOUBLE PRECISION DSUM
C
C	   TEST OF DIMENSION
	IF(M)2,2,1
1	IF(N)2,2,4
C
C	   ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS
2	IER=-1
	RETURN
C
C	   ERROR RETURN IN CASE OF SINGULAR MATRIX T
3	IER=1
	RETURN
C
C	   INITIALIZE DIVISION PROCESS
4	MN=M*N
	MM=M*(M+1)/2
	MM1=M-1
	IER=0
	ICS=M
	IRS=1
	IMEND=M
C
C	   TEST SPECIFIED OPERATION
	IF(IOP)5,2,6
5	MM=N*(N+1)/2
	MM1=N-1
	IRS=M
	ICS=1
	IMEND=MN-M+1
	MN=M
6	IOPE=MOD(IOP+3,3)
	IF(IABS(IOP)-3)7,7,2
7	IF(IOPE-1)8,18,8
C
C	   INITIALIZE SOLUTION OF TRANSPOSE(T)*X = A
8	MEND=1
	LLD=IRS
	MSTA=1
	MDEL=1
	MX=1
	LD=1
	LX=0
C
C	   TEST FOR NONZERO DIAGONAL TERM IN T
9	IF(T(MSTA))10,3,10
10	DO 11 I=MEND,MN,ICS
11	A(I)=A(I)/DBLE(T(MSTA))
C
C	   IS M EQUAL 1
	IF(MM1)2,15,12
12	DO 14 J=1,MM1
	MSTA=MSTA+MDEL
	MDEL=MDEL+MX
	DO 14 I=MEND,MN,ICS
	DSUM=0.D0
	L=MSTA
	LDX=LD
	LL=I
	DO 13 K=1,J
	DSUM=DSUM-T(L)*A(LL)
	LL=LL+LLD
	L=L+LDX
13	LDX=LDX+LX
	IF(T(L))14,3,14
14	A(LL)=(DSUM+A(LL))/T(L)
C
C	   TEST END OF OPERATION
15	IF(IER)16,17,16
16	IER=0
	RETURN
17	IF(IOPE)18,18,16
C
C	   INITIALIZE SOLUTION OF T*X = A
18	IER=1
	MEND=IMEND
	MN=M*N
	LLD=-IRS
	MSTA=MM
	MDEL=-1
	MX=0
	LD=-MM1
	LX=1
	GOTO 9
	END
C
C	..................................................................
C
C	   SUBROUTINE MTRA
C
C	   PURPOSE
C	      TRANSPOSE A MATRIX
C
C	   USAGE
C	      CALL MTRA(A,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF MATRIX TO BE TRANSPOSED
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS OF A AND COLUMNS OF R
C	      M - NUMBER OF COLUMNS OF A AND ROWS OF R
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      MCPY
C
C	   METHOD
C	      TRANSPOSE N BY M MATRIX A TO FORM M BY N MATRIX R BY MOVING
C	      EACH ROW OF A INTO THE CORRESPONDING COLUMN OF R. IF MATRIX
C	      A IS SYMMETRIC OR DIAGONAL, MATRIX R IS THE SAME AS A.
C
C	..................................................................
C
	SUBROUTINE MTRA(A,R,N,M,MS)
	DIMENSION A(1),R(1)
C
C	   IF MS IS 1 OR 2, COPY A
C
	IF(MS) 10,20,10
10	CALL MCPY(A,R,N,N,MS)
	RETURN
C
C	   TRANSPOSE GENERAL MATRIX
C
20	IR=0
	DO 30 I=1,N
	IJ=I-N
	DO 30 J=1,M
	IJ=IJ+N
	IR=IR+1
30	R(IR)=A(IJ)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MULTR
C
C	   PURPOSE
C	      PERFORM A MULTIPLE LINEAR REGRESSION ANALYSIS FOR A
C	      DEPENDENT VARIABLE AND A SET OF INDEPENDENT VARIABLES.  THIS
C	      SUBROUTINE IS NORMALLY USED IN THE PERFORMANCE OF MULTIPLE
C	      AND POLYNOMIAL REGRESSION ANALYSES.
C
C	   USAGE
C	      CALL MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS)
C
C	   DESCRIPTION OF PARAMETERS
C	      N     - NUMBER OF OBSERVATIONS.
C	      K     - NUMBER OF INDEPENDENT VARIABLES IN THIS REGRESSION.
C	      XBAR  - INPUT VECTOR OF LENGTH M CONTAINING MEANS OF ALL
C	              VARIABLES. M IS NUMBER OF VARIABLES IN OBSERVATIONS.
C	      STD   - INPUT VECTOR OF LENGTH M CONTAINING STANDARD DEVI-
C	              ATIONS OF ALL VARIABLES.
C	      D     - INPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL OF
C	              THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS
C	              FROM MEANS FOR ALL VARIABLES.
C	      RX    - INPUT MATRIX (K X K) CONTAINING THE INVERSE OF
C	              INTERCORRELATIONS AMONG INDEPENDENT VARIABLES.
C	      RY    - INPUT VECTOR OF LENGTH K CONTAINING INTERCORRELA-
C	              TIONS OF INDEPENDENT VARIABLES WITH DEPENDENT
C	              VARIABLE.
C	      ISAVE - INPUT VECTOR OF LENGTH K+1 CONTAINING SUBSCRIPTS OF
C	              INDEPENDENT VARIABLES IN ASCENDING ORDER.  THE
C	              SUBSCRIPT OF THE DEPENDENT VARIABLE IS STORED IN
C	              THE LAST, K+1, POSITION.
C	      B     - OUTPUT VECTOR OF LENGTH K CONTAINING REGRESSION
C	              COEFFICIENTS.
C	      SB    - OUTPUT VECTOR OF LENGTH K CONTAINING STANDARD
C	              DEVIATIONS OF REGRESSION COEFFICIENTS.
C	      T     - OUTPUT VECTOR OF LENGTH K CONTAINING T-VALUES.
C	      ANS   - OUTPUT VECTOR OF LENGTH 10 CONTAINING THE FOLLOWING
C	              INFORMATION..
C	              ANS(1)  INTERCEPT
C	              ANS(2)  MULTIPLE CORRELATION COEFFICIENT
C	              ANS(3)  STANDARD ERROR OF ESTIMATE
C	              ANS(4)  SUM OF SQUARES ATTRIBUTABLE TO REGRES-
C	                      SION (SSAR)
C	              ANS(5)  DEGREES OF FREEDOM ASSOCIATED WITH SSAR
C	              ANS(6)  MEAN SQUARE OF SSAR
C	              ANS(7)  SUM OF SQUARES OF DEVIATIONS FROM REGRES-
C	                      SION (SSDR)
C	              ANS(8)  DEGREES OF FREEDOM ASSOCIATED WITH SSDR
C	              ANS(9)  MEAN SQUARE OF SSDR
C	              ANS(10) F-VALUE
C
C	   REMARKS
C	      N MUST BE GREATER THAN K+1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE GAUSS-JORDAN METHOD IS USED IN THE SOLUTION OF THE
C	      NORMAL EQUATIONS.  REFER TO W. W. COOLEY AND P. R. LOHNES,
C	      'MULTIVARIATE PROCEDURES FOR THE BEHAVIORAL SCIENCES',
C	      JOHN WILEY AND SONS, 1962, CHAPTER 3, AND B. OSTLE,
C	      'STATISTICS IN RESEARCH', THE IOWA STATE COLLEGE PRESS,
C	      1954, CHAPTER 8.
C
C	..................................................................
C
	SUBROUTINE MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS)
	DIMENSION XBAR(1),STD(1),D(1),RX(1),RY(1),ISAVE(1),B(1),SB(1),
     1          T(1),ANS(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION XBAR,STD,D,RX,RY,B,SB,T,ANS,RM,BO,SSAR,SSDR,SY,
C    1                 FN,FK,SSARM,SSDRM,F
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT AND ABS IN
C	   STATEMENTS 122, 125, AND 135 MUST BE CHANGED TO DSQRT AND DABS.
C
C	   ...............................................................
C
	MM=K+1
C
C	   BETA WEIGHTS
C
	DO 100 J=1,K
100	B(J)=0.0
	DO 110 J=1,K
	L1=K*(J-1)
	DO 110 I=1,K
	L=L1+I
110	B(J)=B(J)+RY(I)*RX(L)
	RM=0.0
	BO=0.0
	L1=ISAVE(MM)
C
C	   COEFFICIENT OF DETERMINATION
C
	DO 120 I=1,K
	RM=RM+B(I)*RY(I)
C
C	   REGRESSION COEFFICIENTS
C
	L=ISAVE(I)
	B(I)=B(I)*(STD(L1)/STD(L))
C
C	   INTERCEPT
C
120	BO=BO+B(I)*XBAR(L)
	BO=XBAR(L1)-BO
C
C	   SUM OF SQUARES ATTRIBUTABLE TO REGRESSION
C
	SSAR=RM*D(L1)
C
C	   MULTIPLE CORRELATION COEFFICIENT
C
122	RM= SQRT( ABS(RM))
C
C	   SUM OF SQUARES OF DEVIATIONS FROM REGRESSION
C
	SSDR=D(L1)-SSAR
C
C	   VARIANCE OF ESTIMATE
C
	FN=N-K-1
	SY=SSDR/FN
C
C	   STANDARD DEVIATIONS OF REGRESSION COEFFICIENTS
C
	DO 130 J=1,K
	L1=K*(J-1)+J
	L=ISAVE(J)
125	SB(J)= SQRT( ABS((RX(L1)/D(L))*SY))
C
C	   COMPUTED T-VALUES
C
130	T(J)=B(J)/SB(J)
C
C	   STANDARD ERROR OF ESTIMATE
C
135	SY= SQRT( ABS(SY))
C
C	   F VALUE
C
	FK=K
	SSARM=SSAR/FK
	SSDRM=SSDR/FN
	F=SSARM/SSDRM
C
	ANS(1)=BO
	ANS(2)=RM
	ANS(3)=SY
	ANS(4)=SSAR
	ANS(5)=FK
	ANS(6)=SSARM
	ANS(7)=SSDR
	ANS(8)=FN
	ANS(9)=SSDRM
	ANS(10)=F
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE MXOUT
C
C	   PURPOSE
C	      PRODUCES AN OUTPUT LISTING OF ANY SIZED ARRAY ON
C	      LOGICAL UNIT 6
C
C	   USAGE
C	      CALL MXOUT(ICODE,A,N,M,MS,LINS,IPOS,ISP)
C
C	   DESCRIPTION OF PARAMETERS
C	      ICODE- INPUT CODE NUMBER TO BE PRINTED ON EACH OUTPUT PAGE
C	      A-NAME OF OUTPUT MATRIX
C	      N-NUMBER OF ROWS IN A
C	      M-NUMBER OF COLUMNS IN A
C	      MS-STORAGE MODE OF A WHERE MS=
C	             0-GENERAL
C	             1-SYMMETRIC
C	             2-DIAGONAL
C	      LINS-NUMBER OF PRINT LINES ON THE PAGE (USUALLY 60)
C	      IPOS-NUMBER OF PRINT POSITIONS ACROSS THE PAGE (USUALLY 132)
C	      ISP-LINE SPACING CODE, 1 FOR SINGLE SPACE, 2 FOR DOUBLE
C	          SPACE
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      THIS SUBROUTINE CREATES A STANDARD OUTPUT LISTING OF ANY
C	      SIZED ARRAY WITH ANY STORAGE MODE. EACH PAGE IS HEADED WITH
C	      THE CODE NUMBER,DIMENSIONS AND STORAGE MODE OF THE ARRAY.
C	      EACH COLUMN AND ROW IS ALSO HEADED WITH ITS RESPECTIVE
C	      NUMBER.
C
C	..................................................................
C
	SUBROUTINE MXOUT (ICODE,A,N,M,MS,LINS,IPOS,ISP)
	DIMENSION A(1),B(8)
1	FORMAT(1H1,5X, 7HMATRIX ,I5,6X,I3,5H ROWS,6X,I3,8H COLUMNS,
     18X,13HSTORAGE MODE ,I1,8X,5HPAGE ,I2,/)
2	FORMAT(12X,8HCOLUMN  ,7(3X,I3,10X))
3	FORMAT(1H )
4	FORMAT(1H ,7X,4HROW ,I3,7(E16.6))
5	FORMAT(1H0,7X,4HROW ,I3,7(E16.6))
C
	J=1
C
C	   WRITE HEADING
C
	NEND=IPOS/16-1
	LEND=(LINS/ISP)-2
	IPAGE=1
10	LSTRT=1
20	WRITE(6,1)ICODE,N,M,MS,IPAGE
	JNT=J+NEND-1
	IPAGE=IPAGE+1
31	IF(JNT-M)33,33,32
32	JNT=M
33	CONTINUE
	WRITE(6,2)(JCUR,JCUR=J,JNT)
	IF(ISP-1) 35,35,40
35	WRITE(6,3)
40	LTEND=LSTRT+LEND-1
	DO 80 L=LSTRT,LTEND
C
C	   FORM OUTPUT ROW LINE
C
	DO 55 K=1,NEND
	KK=K
	JT = J+K-1
	CALL LOC(L,JT,IJNT,N,M,MS)
	B(K)=0.0
	IF(IJNT)50,50,45
45	B(K)=A(IJNT)
50	CONTINUE
C
C	   CHECK IF LAST COLUMN.  IF YES GO TO 60
C
	IF(JT-M) 55,60,60
55	CONTINUE
C
C	   END OF LINE, NOW WRITE
C
60	IF(ISP-1)65,65,70
65	WRITE(6,4)L,(B(JW),JW=1,KK)
	GO TO 75
70	WRITE(6,5)L,(B(JW),JW=1,KK)
C
C	   IF END OF ROWS,GO CHECK COLUMNS
C
75	IF(N-L)85,85,80
80	CONTINUE
C
C	   END OF PAGE, NOW CHECK FOR MORE OUTPUT
C
	LSTRT=LSTRT+LEND
	GO TO 20
C
C	   END OF COLUMNS, THEN RETURN
C
85	IF(JT-M)90,95,95
90	J=JT+1
	GO TO 10
95	RETURN
	END
C
C.......................................................................
C
C	   SUBROUTINE NDTR
C
C	   PURPOSE
C	      COMPUTES Y = P(X) = PROBABILITY THAT THE RANDOM VARIABLE  U,
C	      DISTRIBUTED NORMALLY(0,1), IS LESS THAN OR EQUAL TO X.
C	      F(X), THE ORDINATE OF THE NORMAL DENSITY AT X, IS ALSO
C	      COMPUTED.
C
C	   USAGE
C	      CALL NDTR(X,P,D)
C
C	   DESCRIPTION OF PARAMETERS
C	      X--INPUT SCALAR FOR WHICH P(X) IS COMPUTED.
C	      P--OUTPUT PROBABILITY.
C	      D--OUTPUT DENSITY.
C
C	   REMARKS
C	      MAXIMUM ERROR IS 0.0000007.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BASED ON APPROXIMATIONS IN C. HASTINGS, APPROXIMATIONS FOR
C	      DIGITAL COMPUTERS, PRINCETON UNIV. PRESS, PRINCETON, N.J.,
C	      1955.  SEE EQUATION 26.2.17, HANDBOOK OF MATHEMATICAL
C	      FUNCTIONS, ABRAMOWITZ AND STEGUN, DOVER PUBLICATIONS, INC.,
C	      NEW YORK.
C
C.......................................................................
C
	SUBROUTINE NDTR(X,P,D)
C
	AX=ABS(X)
	T=1.0/(1.0+.2316419*AX)
	D=0.3989423*EXP(-X*X/2.0)
	P = 1.0 - D*T*((((1.330274*T - 1.821256)*T + 1.781478)*T -
     1  0.3565638)*T + 0.3193815)
	IF(X)1,2,2
1	P=1.0-P
2	RETURN
	END
C
C.......................................................................
C
C	   SUBROUTINE NDTRI
C
C	   PURPOSE
C	     COMPUTES X = P**(-1)(Y), THE ARGUMENT X SUCH THAT Y= P(X) =
C	     THE PROBABILITY THAT THE RANDOM VARIABLE U, DISTRIBUTED
C	     NORMALLY(0,1), IS LESS THAN OR EQUAL TO X.  F(X), THE
C	     ORDINATE OF THE NORMAL DENSITY, AT X, IS ALSO COMPUTED.
C
C	   USAGE
C	     CALL NDTRI(P,X,D,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	     P   - INPUT PROBABILITY.
C	     X   - OUTPUT ARGUMENT SUCH THAT P = Y = THE PROBABILITY THAT
C	              U, THE RANDOM VARIABLE, IS LESS THAN OR EQUAL TO X.
C	     D   - OUTPUT DENSITY, F(X).
C	     IER - OUTPUT ERROR CODE
C	           = -1 IF P IS NOT IN THE INTERVAL (0,1), INCLUSIVE.
C	             X=D=.99999E38 IN THIS CASE                          N
C	           = 0 IF THERE IS NO ERROR.  SEE REMARKS, BELOW.
C
C	   REMARKS
C	     MAXIMUM ERROR IS 0.00045.
C	     IF P = 0, X IS SET TO -(10)**74.  D IS SET TO 0.
C	     IF P = 1, X IS SET TO  (10)**74.  D IS SET TO 0.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	     NONE
C
C	   METHOD
C	     BASED ON APPROXIMATIONS IN C. HASTINGS, APPROXIMATIONS FOR
C	     DIGITAL COMPUTERS, PRINCETON UNIV. PRESS, PRINCETON, N.J.,
C	     1955.  SEE EQUATION 26.2.23, HANDBOOK OF MATHEMATICAL
C	     FUNCTIONS, ABRAMOWITZ AND STEGUN, DOVER PUBLICATIONS, INC.,
C	     NEW YORK.
C
C.......................................................................
C
	SUBROUTINE NDTRI(P,X,D,IE)
C
	IE=0
	X=.99999E38
	D=X
	IF(P)1,4,2
1	IE=-1
	GO TO 12
2	IF (P-1.0)7,5,1
4	X=-.999999E38
5	D=0.0
	GO TO 12
C
C
7	D=P
	IF(D-0.5)9,9,8
8	D=1.0-D
9	T2=ALOG(1.0/(D*D))
	T=SQRT(T2)
	X=T-(2.515517+0.802853*T+0.010328*T2)/(1.0+1.432788*T+0.189269*T2
     1  +0.001308*T*T2)
	IF(P-0.5)10,10,11
10	X=-X
11	D=0.3989423*EXP(-X*X/2.0)
12	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE NROOT
C
C	   PURPOSE
C	      COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL NONSYMMETRIC
C	      MATRIX OF THE FORM B-INVERSE TIMES A.  THIS SUBROUTINE IS
C	      NORMALLY CALLED BY SUBROUTINE CANOR IN PERFORMING A
C	      CANONICAL CORRELATION ANALYSIS.
C
C	   USAGE
C	      CALL NROOT (M,A,B,XL,X)
C
C	   DESCRIPTION OF PARAMETERS
C	      M  - ORDER OF SQUARE MATRICES A, B, AND X.
C	      A  - INPUT MATRIX (M X M).
C	      B  - INPUT MATRIX (M X M).
C	      XL - OUTPUT VECTOR OF LENGTH M CONTAINING EIGENVALUES OF
C	           B-INVERSE TIMES A.
C	      X  - OUTPUT MATRIX (M X M) CONTAINING EIGENVECTORS COLUMN-
C	           WISE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      EIGEN
C
C	   METHOD
C	      REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO-
C	      CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS,
C	      1962, CHAPTER 3.
C
C	..................................................................
C
	SUBROUTINE NROOT (M,A,B,XL,X)
	DIMENSION A(1),B(1),XL(1),X(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION A,B,XL,X,SUMV
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
C	   110 AND 175 MUST BE CHANGED TO DSQRT.  ABS IN STATEMENT 110
C	   MUST BE CHANGED TO DABS.
C
C	   ...............................................................
C
C	COMPUTE EIGENVALUES AND EIGENVECTORS OF B
C
	K=1
	DO 100 J=2,M
	L=M*(J-1)
	DO 100 I=1,J
	L=L+1
	K=K+1
100	B(K)=B(L)
C
C	   THE MATRIX B IS A REAL SYMMETRIC MATRIX.
C
	MV=0
	CALL EIGEN (B,X,M,MV)
C
C	FORM RECIPROCALS OF SQUARE ROOT OF EIGENVALUES.  THE RESULTS
C	ARE PREMULTIPLIED BY THE ASSOCIATED EIGENVECTORS.
C
	L=0
	DO 110 J=1,M
	L=L+J
110	XL(J)=1.0/ SQRT( ABS(B(L)))
	K=0
	DO 115 J=1,M
	DO 115 I=1,M
	K=K+1
115	B(K)=X(K)*XL(J)
C
C	FORM (B**(-1/2))PRIME * A * (B**(-1/2))
C
	DO 120 I=1,M
	N2=0
	DO 120 J=1,M
	N1=M*(I-1)
	L=M*(J-1)+I
	X(L)=0.0
	DO 120 K=1,M
	N1=N1+1
	N2=N2+1
120	X(L)=X(L)+B(N1)*A(N2)
	L=0
	DO 130 J=1,M
	DO 130 I=1,J
	N1=I-M
	N2=M*(J-1)
	L=L+1
	A(L)=0.0
	DO 130 K=1,M
	N1=N1+M
	N2=N2+1
130	A(L)=A(L)+X(N1)*B(N2)
C
C	COMPUTE EIGENVALUES AND EIGENVECTORS OF A
C
	CALL EIGEN (A,X,M,MV)
	L=0
	DO 140 I=1,M
	L=L+I
140	XL(I)=A(L)
C
C	COMPUTE THE NORMALIZED EIGENVECTORS
C
	DO 150 I=1,M
	N2=0
	DO 150 J=1,M
	N1=I-M
	L=M*(J-1)+I
	A(L)=0.0
	DO 150 K=1,M
	N1=N1+M
	N2=N2+1
150	A(L)=A(L)+B(N1)*X(N2)
	L=0
	K=0
	DO 180 J=1,M
	SUMV=0.0
	DO 170 I=1,M
	L=L+1
170	SUMV=SUMV+A(L)*A(L)
175	SUMV= SQRT(SUMV)
	DO 180 I=1,M
	K=K+1
180	X(K)=A(K)/SUMV
	RETURN
	END
C	NUMINT
C	NUMERICAL INTEGRATION BY OVERLAPPING PARABOLAS
C	AS MODIFIED FOR PROGRAMMA BY REA
C	ARGUMENTS
C	N	NUMBER OF POINTS IN THE VECTORS
C	A	OUTPUT VECTOR OF INTEGRALS (A(2)=INT(X(1)-X(2)) ETC
C	X	INPUT X-VALUES
C	Y	INPUT Y VALUES
C
C	MARS 74
C	LIMITED TO POSITIVE AREAS
	SUBROUTINE NUMINT(N,X,Y,A)
	DIMENSION X(1),Y(1),A(1)
	N1=N-1
	DO 100 I=2,N1
	HI1=(Y(I+1)-Y(I))/(X(I+1)-X(I))
	HI=(Y(I)-Y(I-1))/(X(I)-X(I-1))
	A(I)=(HI1-HI)/(X(I+1)-X(I-1))
100	CONTINUE
	DO 200 I=2,N
	J=N-I+2
	IF(J.EQ.N)AI=A(N-1)
	IF(J.EQ.2)AI=A(2)
	IF(J.NE.N.AND.J.NE.2)AI=0.5*(A(J)+A(J-1))
160	D=X(J)-X(J-1)
	A(J)=D*(0.5*(Y(J)+Y(J-1))-D*D*AI/6.)
200	IF(A(J).LT.0)A(J)=0
	A(1)=0.
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE ORDER
C
C	   PURPOSE
C	      CONSTRUCT FROM A LARGER MATRIX OF CORRELATION COEFFICIENTS
C	      A SUBSET MATRIX OF INTERCORRELATIONS AMONG INDEPENDENT
C	      VARIABLES AND A VECTOR OF INTERCORRELATIONS OF INDEPENDENT
C	      VARIABLES WITH DEPENDENT VARIABLE.  THIS SUBROUTINE IS
C	      NORMALLY USED IN THE PERFORMANCE OF MULTIPLE AND POLYNOMIAL
C	      REGRESSION ANALYSES.
C
C	   USAGE
C	      CALL ORDER (M,R,NDEP,K,ISAVE,RX,RY)
C
C	   DESCRIPTION OF PARAMETERS
C	      M     - NUMBER OF VARIABLES AND ORDER OF MATRIX R.
C	      R     - INPUT MATRIX CONTAINING CORRELATION COEFFICIENTS.
C	              THIS SUBROUTINE EXPECTS ONLY UPPER TRIANGULAR
C	              PORTION OF THE SYMMETRIC MATRIX TO BE STORED (BY
C	              COLUMN) IN R.  (STORAGE MODE OF 1)
C	      NDEP  - THE SUBSCRIPT NUMBER OF THE DEPENDENT VARIABLE.
C	      K     - NUMBER OF INDEPENDENT VARIABLES TO BE INCLUDED
C	              IN THE FORTHCOMING REGRESSION. K MUST BE GREATER
C	              THAN OR EQUAL TO 1.
C	      ISAVE - INPUT VECTOR OF LENGTH K+1 CONTAINING, IN ASCENDING
C	              ORDER, THE SUBSCRIPT NUMBERS OF K INDEPENDENT
C	              VARIABLES TO BE INCLUDED IN THE FORTHCOMING REGRES-
C	              SION.
C	              UPON RETURNING TO THE CALLING ROUTINE, THIS VECTOR
C	              CONTAINS, IN ADDITION, THE SUBSCRIPT NUMBER OF
C	              THE DEPENDENT VARIABLE IN K+1 POSITION.
C	      RX    - OUTPUT MATRIX (K X K) CONTAINING INTERCORRELATIONS
C	              AMONG INDEPENDENT VARIABLES TO BE USED IN FORTH-
C	              COMING REGRESSION.
C	      RY    - OUTPUT VECTOR OF LENGTH K CONTAINING INTERCORRELA-
C	              TIONS OF INDEPENDENT VARIABLES WITH DEPENDENT
C	              VARIABLES.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      FROM THE SUBSCRIPT NUMBERS OF THE VARIABLES TO BE INCLUDED
C	      IN THE FORTHCOMING REGRESSION, THE SUBROUTINE CONSTRUCTS THE
C	      MATRIX RX AND THE VECTOR RY.
C
C	..................................................................
C
	SUBROUTINE ORDER (M,R,NDEP,K,ISAVE,RX,RY)
	DIMENSION R(1),ISAVE(1),RX(1),RY(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION R,RX,RY
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	COPY INTERCORRELATIONS OF INDEPENDENT VARIABLES
C	WITH DEPENDENT VARIABLE
C
	MM=0
	DO 130 J=1,K
	L2=ISAVE(J)
	IF(NDEP-L2) 122, 123, 123
122	L=NDEP+(L2*L2-L2)/2
	GO TO 125
123	L=L2+(NDEP*NDEP-NDEP)/2
125	RY(J)=R(L)
C
C	COPY A SUBSET MATRIX OF INTERCORRELATIONS AMONG
C	INDEPENDENT VARIABLES
C
	DO 130 I=1,K
	L1=ISAVE(I)
	IF(L1-L2) 127, 128, 128
127	L=L1+(L2*L2-L2)/2
	GO TO 129
128	L=L2+(L1*L1-L1)/2
129	MM=MM+1
130	RX(MM)=R(L)
C
C	PLACE THE SUBSCRIPT NUMBER OF THE DEPENDENT
C	VARIABLE IN ISAVE(K+1)
C
	ISAVE(K+1)=NDEP
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PADD
C
C	   PURPOSE
C	      ADD TWO POLYNOMIALS
C
C	   USAGE
C	      CALL PADD(Z,IDIMZ,X,IDIMX,Y,IDIMY)
C
C	   DESCRIPTION OF PARAMETERS
C	      Z     - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMZ - DIMENSION OF Z (CALCULATED)
C	      X     - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1)
C	      Y     - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1)
C
C	   REMARKS
C	      VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR
C	      VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS
C	      THAN THE OTHER INPUT VECTOR
C	      THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE
C	      LARGER OF THE TWO INPUT VECTOR DIMENSIONS. CORRESPONDING
C	      COEFFICIENTS ARE THEN ADDED TO FORM Z.
C
C	..................................................................
C
	SUBROUTINE PADD(Z,IDIMZ,X,IDIMX,Y,IDIMY)
	DIMENSION Z(1),X(1),Y(1)
C
C	TEST DIMENSIONS OF SUMMANDS
C
	NDIM=IDIMX
	IF (IDIMX-IDIMY) 10,20,20
10	NDIM=IDIMY
20	IF(NDIM) 90,90,30
30	DO 80 I=1,NDIM
	IF(I-IDIMX) 40,40,60
40	IF(I-IDIMY) 50,50,70
50	Z(I)=X(I)+Y(I)
	GO TO 80
60	Z(I)=Y(I)
	GO TO 80
70	Z(I)=X(I)
80	CONTINUE
90	IDIMZ=NDIM
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PADDM
C
C	   PURPOSE
C	      ADD COEFFICIENTS OF ONE POLYNOMIAL TO THE PRODUCT OF A
C	      FACTOR BY COEFFICIENTS OF ANOTHER POLYNOMIAL
C
C	   USAGE
C	      CALL PADDM(Z,IDIMZ,X,IDIMX,FACT,Y,IDIMY)
C
C	   DESCRIPTION OF PARAMETERS
C	      Z     - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMZ - DIMENSION OF Z (CALCULATED)
C	      X     - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1)
C	      FACT  - FACTOR TO BE MULTIPLIED BY VECTOR Y
C	      Y     - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1)
C
C	   REMARKS
C	      VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR
C	      VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS
C	      THAN THE OTHER INPUT VECTOR
C	      THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE
C	      LARGER OF THE TWO INPUT VECTOR DIMENSIONS. COEFFICIENT IN
C	      VECTOR X IS THEN ADDED TO COEFFICIENT IN VECTOR Y MULTIPLIED
C	      BY FACTOR TO FORM Z.
C
C	..................................................................
C
	SUBROUTINE PADDM(Z,IDIMZ,X,IDIMX,FACT,Y,IDIMY)
	DIMENSION Z(1),X(1),Y(1)
C
C	TEST DIMENSIONS OF SUMMANDS
C
	NDIM=IDIMX
	IF(IDIMX-IDIMY) 10,20,20
10	NDIM=IDIMY
20	IF(NDIM) 90,90,30
30	DO 80 I=1,NDIM
	IF(I-IDIMX) 40,40,60
40	IF(I-IDIMY) 50,50,70
50	Z(I)=FACT*Y(I)+X(I)
	GO TO 80
60	Z(I)=FACT*Y(I)
	GO TO 80
70	Z(I)=X(I)
80	CONTINUE
90	IDIMZ=NDIM
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PCLA
C
C	   PURPOSE
C	      MOVE POLYNOMIAL X TO Y
C
C	   USAGE
C	      CALL PCLA(Y,IDIMY,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y
C	      X     - VECTOR OF COEFFICIENTS FOR POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IDIMY IS REPLACED BY IDIMX AND VECTOR X IS MOVED TO Y
C
C	..................................................................
C
	SUBROUTINE PCLA (Y,IDIMY,X,IDIMX)
	DIMENSION X(1),Y(1)
C
	IDIMY=IDIMX
	IF(IDIMX) 30,30,10
10	DO 20 I=1,IDIMX
20	Y(I)=X(I)
30	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PCLD
C
C	   PURPOSE
C	      SHIFT OF ORIGIN (COMPLETE LINEAR SYNTHETIC DIVISION)
C
C	   USAGE
C	      CALL PCLD(X,IDIMX,U)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     - VECTOR OF COEFFICIENTS, ORDERED FROM SMALLEST TO
C	              LARGEST POWER. IT IS REPLACED BY VECTOR OF
C	              TRANSFORMED COEFFICIENTS.
C	      IDIMX - DIMENSION OF X
C	      U     - SHIFT PARAMETER
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      COEFFICIENT VECTOR X(I) OF POLYNOMIAL P(Z) IS TRANSFORMED
C	      SUCH THAT Q(Z)=P(Z-U) WHERE Q(Z) DENOTES THE POLYNOMIAL
C	      WITH TRANSFORMED COEFFICIENT VECTOR.
C
C	..................................................................
C
	SUBROUTINE PCLD (X,IDIMX,U)
	DIMENSION X(1)
C
	K=1
1	J=IDIMX
2	IF (J-K) 4,4,3
3	X(J-1)=X(J-1)+U*X(J)
	J=J-1
	GO TO 2
4	K=K+1
	IF (IDIMX-K) 5,5,1
5	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PDER
C
C	   PURPOSE
C	      FIND DERIVATIVE OF A POLYNOMIAL
C
C	   USAGE
C	      CALL PDER(Y,IDIMY,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - VECTOR OF COEFFICIENTS FOR DERIVATIVE, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (EQUAL TO IDIMX-1)
C	      X     - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF Y IS SET AT DIMENSION OF X LESS ONE. DERIVATIVE
C	      IS THEN CALCULATED BY MULTIPLYING COEFFICIENTS BY THEIR
C	      RESPECTIVE EXPONENTS.
C
C	..................................................................
C
	SUBROUTINE PDER(Y,IDIMY,X,IDIMX)
	DIMENSION X(1),Y(1)
C
C	TEST OF DIMENSION
	IF (IDIMX-1) 3,3,1
1	IDIMY=IDIMX-1
	EXPT=0.
	DO 2 I=1,IDIMY
	EXPT=EXPT+1.
2	Y(I)=X(I+1)*EXPT
	GO TO 4
3	IDIMY=0
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PDIV
C
C	   PURPOSE
C	      DIVIDE ONE POLYNOMIAL BY ANOTHER
C
C	   USAGE
C	      CALL PDIV(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      P     - RESULTANT VECTOR OF INTEGRAL PART
C	      IDIMP - DIMENSION OF P
C	      X     - VECTOR OF COEFFICIENTS FOR DIVIDEND POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER. IT IS
C	              REPLACED BY REMAINDER AFTER DIVISION.
C	      IDIMX - DIMENSION OF X
C	      Y     - VECTOR OF COEFFICIENTS FOR DIVISOR POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y
C	      TOL   - TOLERANCE VALUE BELOW WHICH COEFFICIENTS ARE
C	              ELIMINATED DURING NORMALIZATION
C	      IER   - ERROR CODE. 0 IS NORMAL, 1 IS FOR ZERO DIVISOR
C
C	   REMARKS
C	      THE REMAINDER R REPLACES X.
C	      THE DIVISOR Y REMAINS UNCHANGED.
C	      IF DIMENSION OF Y EXCEEDS DIMENSION OF X, IDIMP IS SET TO
C	      ZERO AND CALCULATION IS BYPASSED
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      PNORM
C
C	   METHOD
C	      POLYNOMIAL X IS DIVIDED BY POLYNOMIAL Y GIVING INTEGER PART
C	      P AND REMAINDER R SUCH THAT X = P*Y + R.
C	      DIVISOR Y AND REMAINDER  VECTOR GET NORMALIZED.
C
C	..................................................................
C
	SUBROUTINE PDIV(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER)
	DIMENSION P(1),X(1),Y(1)
C
	CALL PNORM (Y,IDIMY,TOL)
	IF(IDIMY) 50,50,10
10	IDIMP=IDIMX-IDIMY+1
	IF(IDIMP) 20,30,60
C
C	DEGREE OF DIVISOR WAS GREATER THAN DEGREE OF DIVIDEND
C
20	IDIMP=0
30	IER=0
40	RETURN
C
C	Y IS ZERO POLYNOMIAL
C
50	IER=1
	GO TO 40
C
C	START REDUCTION
C
60	IDIMX=IDIMY-1
	I=IDIMP
70	II=I+IDIMX
	P(I)=X(II)/Y(IDIMY)
C
C	SUBTRACT MULTIPLE OF DIVISOR
C
	DO 80 K=1,IDIMX
	J=K-1+I
	X(J)=X(J)-P(I)*Y(K)
80	CONTINUE
	I=I-1
	IF(I) 90,90,70
C
C	NORMALIZE REMAINDER POLYNOMIAL
C
90	CALL PNORM(X,IDIMX,TOL)
	GO TO 30
	END
C
C	..................................................................
C
C	   SUBROUTINE PECN
C
C	   PURPOSE
C	      ECONOMIZE A POLYNOMIAL FOR SYMMETRIC RANGE
C
C	   USAGE
C	      CALL PECN (P,N,BOUND,EPS,TOL,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      P     - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL
C	              ON RETURN P CONTAINS THE ECONOMIZED POLYNOMIAL
C	      N     - DIMENSION OF COEFFICIENT VECTOR P
C	              ON RETURN N CONTAINS DIMENSION OF ECONOMIZED
C	              POLYNOMIAL
C	      BOUND - RIGHT HAND BOUNDARY OF RANGE
C	      EPS   - INITIAL ERROR BOUND
C	              ON RETURN EPS CONTAINS AN ERROR BOUND FOR THE
C	              ECONOMIZED POLYNOMIAL
C	      TOL   - TOLERANCE FOR ERROR
C	              FINAL VALUE OF EPS MUST BE LESS THAN TOL
C	      WORK  - WORKING STORAGE OF DIMENSION N (STARTING VALUE
C	              OF N RATHER THAN FINAL VALUE)
C
C	   REMARKS
C	      THE OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
C	      IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
C	      FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
C	      WITH ARGUMENT X IN POWERS OF T = (X-(XR-XL)/2).
C	      THIS IS ACCOMPLISHED THROUGH SUBROUTINE PCLD.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SUBROUTINE PECN TAKES AN (N-1)ST DEGREE POLYNOMIAL
C	      APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
C	      EPS OVER THE INTERVAL (-BOUND,BOUND) AND REDUCES IT IF
C	      POSSIBLE TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN
C	      THE GIVEN TOLERANCE TOL.
C	      THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE FINAL
C	      VECTOR. THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
C	      ERROR BOUND.
C	      N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
C	      THE COEFFICIENT VECTOR OF THE N-TH CHEBYSHEV POLYNOMIAL
C	      IS CALCULATED FROM THE RECURSION FORMULA
C	      A(K-1)=-A(K+1)*K*L*L*(K-1)/((N+K-2)*(N-K+2))
C	      REFERENCE
C	      K. A. BRONS, ALGORITHM 38, TELESCOPE 2, CACM VOL. 4, 1961,
C	      NO. 3, PP. 151-152.
C
C	..................................................................
C
	SUBROUTINE PECN(P,N,BOUND,EPS,TOL,WORK)
C
	DIMENSION P(1),WORK(1)
	FL=BOUND*BOUND
C
C	TEST OF DIMENSION
C
1	IF(N-1)2,3,6
2	RETURN
3	IF(EPS+ABS(P(1))-TOL)4,4,5
4	N=0
	EPS=EPS+ABS(P(1))
5	RETURN
C
C	CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
C
6	NEND=N-2
	WORK(N)=-P(N)
	DO 7 J=1,NEND,2
	K=N-J
	FN=(NEND-1+K)*(NEND+3-K)
	FK=K*(K-1)
7	WORK(K-1)=-WORK(K+1)*FK*FL/FN
C
C	TEST FOR FEASIBILITY OF REDUCTION
C
	IF(K-2)8,8,9
8	FN=ABS(WORK(1))
	GOTO 10
9	FN=N-1
	FN=ABS(WORK(2)/FN)
10	IF(EPS+FN-TOL)11,11,5
C
C	REDUCE POLYNOMIAL
C
11	EPS=EPS+FN
	N=N-1
	DO 12 J=K,N,2
12	P(J-1)=P(J-1)+WORK(J-1)
	GOTO 1
	END
C
C	..................................................................
C
C	   SUBROUTINE PECS
C
C	   PURPOSE
C	      ECONOMIZATION OF A POLYNOMIAL FOR UNSYMMETRIC RANGE
C
C	   USAGE
C	      CALL PECS (P,N,BOUND,EPS,TOL,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      P     - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL
C	      N     - DIMENSION OF COEFFICIENT VECTOR
C	      BOUND - RIGHT HAND BOUNDARY OF INTERVAL
C	      EPS   - INITIAL ERROR BOUND
C	      TOL   - TOLERANCE FOR ERROR
C	      WORK  - WORKING STORAGE OF DIMENSION N
C
C	   REMARKS
C	      THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE
C	      ECONOMIZED VECTOR.
C	      THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL
C	      ERROR BOUND.
C	      N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL.
C	      IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY
C	      FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL
C	      WITH ARGUMENT X IN POWERS OF T = (X-XL).
C	      THIS IS ACCOMPLISHED THROUGH SUBROUTINE PCLD.
C	      OPERATION IS BYPASSED IN CASE OF N LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      SUBROUTINE PECS TAKES AN (N-1)ST DEGREE POLYNOMIAL
C	      APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE
C	      EPS OVER THE INTERVAL (0,BOUND) AND REDUCES IT IF POSSIBLE
C	      TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN TOLERANCE
C	      TOL.
C	      THE COEFFICIENT VECTOR OF THE N-TH SHIFTED CHEBYSHEV
C	      POLYNOMIAL IS CALCULATED FROM THE RECURSION FORMULA
C	      A(K) = -A(K+1)*K*L*(2*K-1)/(2*(N+K-1)*(N-K+1)).
C	      REFERENCE
C	      K. A. BRONS, ALGORITHM 37, TELESCOPE 1, CACM VOL. 4, 1961,
C	      NO. 3, PP. 151.
C
C	..................................................................
C
	SUBROUTINE PECS(P,N,BOUND,EPS,TOL,WORK)
C
	DIMENSION P(1),WORK(1)
	FL=BOUND*0.5
C
C	TEST OF DIMENSION
C
1	IF(N-1)2,3,6
2	RETURN
3	IF(EPS+ABS(P(1))-TOL)4,4,5
4	N=0
	EPS=EPS+ABS(P(1))
5	RETURN
C
C	CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL
C
6	NEND=N-1
	WORK(N)=-P(N)
	DO 7 J=1,NEND
	K=N-J
	FN=(NEND-1+K)*(N-K)
	FK=K*(K+K-1)
7	WORK(K)=-WORK(K+1)*FK*FL/FN
C
C	   TEST FOR FEASIBILITY OF REDUCTION
C
	FN=ABS(WORK(1))
	IF(EPS+FN-TOL)8,8,5
C
C	REDUCE POLYNOMIAL
C
8	EPS=EPS+FN
	N=NEND
	DO 9 J=1,NEND
9	P(J)=P(J)+WORK(J)
	GOTO 1
	END
C
C	..................................................................
C
C	   SUBROUTINE PERM
C
C	   PURPOSE
C	      TO COMPUTE THE PERMUTATION VECTOR THAT IS INVERSE TO A GIVEN
C	      PERMUTATION VECTOR, THE PERMUTATION VECTOR THAT IS EQUIVA-
C	      LENT TO A GIVEN TRANSPOSITION VECTOR AND A TRANSPOSITION
C	      VECTOR THAT IS EQUIVALENT TO A GIVEN PERMUTATION VECTOR.
C	      (SEE THE GENERAL DISCUSSION FOR DEFINITIONS AND NOTATION.)
C
C	   USAGE
C	      CALL PERM(IP1,IP2,N,IPAR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      IP1  - GIVEN PERMUTATION OR TRANSPOSITION VECTOR
C	             (DIMENSION N)
C	      IP2  - RESULTING PERMUTATION OR TRANSPOSITION VECTOR
C	             (DIMENSION N)
C	      N    - DIMENSION OF VECTORS IP1 AND IP2
C	      IPAR - INPUT PARAMETER
C	             IPAR NEGATIVE - COMPUTE THE PERMUTATION VECTOR IP2
C	                             THAT IS THE INVERSE OF THE PERMUTA-
C	                             TION VECTOR IP1
C	             IPAR  =  ZERO - COMPUTE THE PERMUTATION VECTOR IP2
C	                             THAT IS EQUIVALENT TO THE TRANSPOSI-
C	                             TION VECTOR IP1
C	             IPAR POSITIVE - COMPUTE A TRANSPOSITION VECTOR IP2
C	                             THAT IS EQUIVALENT TO THE PERMUTATION
C	                             VECTOR IP1
C	      IER  - RESULTING ERROR PARAMETER
C	             IER=-1  -  N IS NOT POSITIVE
C	             IER= 0  -  NO ERROR
C	             IER= 1  -  IP1 IS EITHER NOT A PERMUTATION VECTOR OR
C	                        NOT A TRANSPOSITION VECTOR ON 1,...,N,
C	                        DEPENDING ON WHETHER IPAR IS NON-ZERO OR
C	                        ZERO, RESPECTIVELY
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)  IF IER=1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE TO
C	           ERROR AND THE PARTIAL RESULTS FOUND IN IP2 ARE USELESS.
C	      (3)  IP2 CANNOT HAVE THE SAME STORAGE ALLOCATION AS IP1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      (1)  IPAR NEGATIVE - FOR EACH I, I=1,...,N, IP2(IP1(I)) IS
C	                           SET TO I.
C	      (2)  IPAR  =  ZERO - INITIALLY IP2(I) IS SET TO I FOR
C	                           I=1,...,N.  THEN, FOR I=1,...,N IN THAT
C	                           ORDER, IP2(I) AND IP2(IP1(I)) ARE
C	                           INTERCHANGED.
C	      (3)  IPAR POSITIVE - INITIALLY IP1 IS MOVED TO IP2.  THEN
C	                           THE FOLLOWING TWO STEPS ARE REPEATED
C	                           FOR I SUCCESSIVELY EQUAL TO 1,...,N.
C	                           (A) FIND THE SMALLEST J GREATER THAN OR
C	                               EQUAL TO I SUCH THAT IP2(J)=I.
C	                           (B) SET IP2(J) TO IP2(I).
C
C	..................................................................
C
	SUBROUTINE PERM(IP1,IP2,N,IPAR,IER)
C
C
	DIMENSION IP1(1),IP2(1)
C
C	   TEST DIMENSION
	IF(N)19,19,1
C
C	   TEST IPAR TO DETERMINE WHETHER IP1 IS TO BE INTERPRETED AS
C	   A PERMUTATION VECTOR OR AS A TRANSPOSITION VECTOR
1	IF(IPAR)2,13,2
C
C	   CHECK THAT IP1 IS A PERMUTATION VECTOR AND COMPUTE IP1 INVERSE
2	DO 3 I=1,N
3	IP2(I)=0
	DO 6 I=1,N
	K=IP1(I)
	IF(K-N)4,5,20
4	IF(K)20,20,5
5	IF(IP2(K))20,6,20
6	IP2(K)=I
C
C	   TEST IPAR FOR THE DESIRED OPERATION
	IF(IPAR)12,7,7
C
C	   COMPUTE TRANSPOSITION VECTOR IP2 FOR PERMUTATION VECTOR IP1
7	DO 8 I=1,N
8	IP2(I)=IP1(I)
	NN=N-1
	IF(NN)12,12,9
9	DO 11 I=1,NN
	DO 10 J=1,NN
	IF(IP2(J)-I)10,11,10
10	CONTINUE
	J=N
11	IP2(J)=IP2(I)
C
C	   NORMAL RETURN - NO ERROR
12	IER=0
	RETURN
C
C	   COMPUTE PERMUTATION VECTOR IP2 FOR TRANSPOSITION VECTOR IP1
13	DO 14 I=1,N
14	IP2(I)=I
	DO 18 I=1,N
	K=IP1(I)
	IF(K-I)15,18,16
15	IF(K)20,20,17
16	IF(N-K)20,17,17
17	J=IP2(I)
	IP2(I)=IP2(K)
	IP2(K)=J
18	CONTINUE
	GO TO 12
C
C	   ERROR RETURN - N IS NOT POSITIVE
19	IER=-1
	RETURN
C
C	   ERROR RETURN - IP1 IS EITHER NOT A PERMUTATION VECTOR
C	                  OR NOT A TRANSPOSITION VECTOR
20	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PGCD
C
C	   PURPOSE
C	      DETERMINE GREATEST COMMON DIVISOR OF TWO POLYNOMIALS
C
C	   USAGE
C	      CALL PGCD(X,IDIMX,Y,IDIMY,WORK,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -  VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL,
C	               ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMX -  DIMENSION OF X
C	      Y     -  VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL,
C	               ORDERED FROM SMALLEST TO LARGEST POWER.
C	               THIS IS REPLACED BY GREATEST COMMON DIVISOR
C	      IDIMY -  DIMENSION OF Y
C	      WORK  -  WORKING STORAGE ARRAY
C	      EPS   -  TOLERANCE VALUE BELOW WHICH COEFFICIENT IS
C	               ELIMINATED DURING NORMALIZATION
C	      IER   -  RESULTANT ERROR CODE WHERE
C	               IER=0  NO ERROR
C	               IER=1  X OR Y IS ZERO POLYNOMIAL
C
C	   REMARKS
C	      IDIMX MUST BE GREATER THAN IDIMY
C	      IDIMY=1 ON RETURN MEANS X AND Y ARE PRIME, THE GCD IS A
C	      CONSTANT. IDIMX IS DESTROYED DURING COMPUTATION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      PDIV
C	      PNORM
C
C	   METHOD
C	      GREATEST COMMON DIVISOR OF TWO POLYNOMIALS X AND Y IS
C	      DETERMINED BY MEANS OF EUCLIDEAN ALGORITHM. COEFFICIENT
C	      VECTORS X AND Y ARE DESTROYED AND GREATEST COMMON
C	      DIVISOR IS GENERATED IN Y.
C
C	..................................................................
C
	SUBROUTINE PGCD(X,IDIMX,Y,IDIMY,WORK,EPS,IER)
	DIMENSION X(1),Y(1),WORK(1)
C
C	DIMENSION REQUIRED FOR VECTOR NAMED  WORK  IS   IDIMX-IDIMY+1
C
1	CALL PDIV(WORK,NDIM,X,IDIMX,Y,IDIMY,EPS,IER)
	IF(IER) 5,2,5
2	IF(IDIMX) 5,5,3
C
C	INTERCHANGE X AND Y
C
3	DO 4 J=1,IDIMY
	WORK(1)=X(J)
	X(J)=Y(J)
4	Y(J)=WORK(1)
	NDIM=IDIMX
	IDIMX=IDIMY
	IDIMY=NDIM
	GO TO 1
5	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PHI
C
C	   PURPOSE
C	      TO COMPUTE THE PHI COEFFICIENT BETWEEN TWO VARIABLES  WHICH
C	      ARE DICHOTOMOUS.
C
C	   USAGE
C	      CALL PHI (N,U,V,HU,HV,P,CH,XP,IE)
C
C	   DESCRIPTION OF PARAMETERS
C	      N  - NUMBER OF OBSERVATIONS
C	      U  - INPUT VECTOR OF LENGTH N CONTAINING THE FIRST DICHOTO-
C	           MOUS VARIABLE
C	      V  - INPUT VECTOR OF LENGTH N CONTAINING THE SECOND DICHOTO-
C	           MOUS VARIABLE
C	      HU - INPUT NUMERICAL CODE WHICH INDICATES THE HIGHER
C	           CATEGORY OF THE FIRST VARIABLE.  ANY OBSERVATION IN
C	           VECTOR U WHICH HAS A VALUE EQUAL TO OR GREATER THAN HU
C	           WILL BE CLASSIFIED IN THE HIGHER CATEGORY.
C	      HV - INPUT NUMERICAL CODE FOR VECTOR V, SIMILAR TO HU
C	      P  - PHI COEFFICIENT COMPUTED
C	      CH - CHI-SQUARE COMPUTED AS A FUNCTION OF PHI COEFFICIENT
C	           (DEGREES OF FREEDOM FOR CHI-SQUARE = 1)
C	      XP - COMPUTED VALUE OF THE MAXIMAL PHI COEFFICIENT THAT
C	           CAN BE ATTAINED IN THE PROBLEM
C	      IE - IF IE IS NON-ZERO, SOME CELL IN THE 2 BY 2 TABLE IS
C	           NULL.  IF SO, P, CH, AND XP ARE SET TO 10**75.
C
C	   REMARKS
C	      VARIABLES U AND V MUST BE SPECIFIED NUMERIC.
C	      THE PHI COEFFICIENT IS A SPECIAL CASE OF THE
C	      PEARSON PRODUCT-MOMENT CORRELATION WHEN BOTH VARIABLES ARE
C	      BINARY.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO P. HORST, 'PYSCHOLOGICAL MEASUREMENT AND
C	      PREDICTION', P. 94 (WADSWORTH, 1966).
C
C	..................................................................
C
	SUBROUTINE PHI (N,U,V,HU,HV,P,CH,XP,IE)
C
	DIMENSION U(1),V(1)
C
C	   CONSTRUCT A 2X2 CONTINGENCY TABLE
C
	IE=0
	A=0.0
	B=0.0
	C=0.0
	D=0.0
C
	DO 40 I=1,N
	IF(U(I)-HU) 10,25,25
10	IF(V(I)-HV) 15,20,20
15	D=D+1.0
	GO TO 40
20	B=B+1.0
	GO TO 40
25	IF(V(I)-HV) 30,35,35
30	C=C+1.0
	GO TO 40
35	A=A+1.0
40	CONTINUE
	IF(A) 100,100,41
41	IF(B) 100,100,42
42	IF(C) 100,100,43
43	IF(D) 100,100,44
C
C	   COMPUTE THE PHI COEFFICIENT
C
44	P=(A*D-B*C)/ SQRT((A+B)*(C+D)*(A+C)*(B+D))
C
C	   COMPUTE CHI-SQURE
C
	T=N
	CH=T*P*P
C
C	   COMPUTE THE MAXIMAL PHI COEFFICIENT
C
	P1=(A+C)/T
	P2=(B+D)/T
	P3=(A+B)/T
	P4=(C+D)/T
	IF(P1-P2) 75, 45, 45
45	IF(P3-P4) 65, 50, 50
50	IF(P1-P3) 60, 55, 55
55	XP=SQRT((P3/P4)*(P2/P1))
	GO TO 95
60	XP=SQRT((P1/P2)*(P4/P3))
	GO TO 95
65	IF(P1-P4) 70, 55, 55
70	XP=SQRT((P2/P1)*(P3/P4))
	GO TO 95
75	IF(P3-P4) 90, 80, 80
80	IF(P2-P3) 60, 85, 85
85	XP=SQRT((P4/P3)*(P1/P2))
	GO TO 95
90	IF(P2-P4) 70, 85, 85
C
95	RETURN
100	IE=1
	P=1.7E38                                                                  0
	CH=1.7E38                                                                 0
	XP=1.7E38                                                                 0
	GO TO 95
	END
C
C	..................................................................
C
C	   SUBROUTINE PILD
C
C	   PURPOSE
C	      EVALUATE POLYNOMIAL AND ITS FIRST DERIVATIVE FOR A GIVEN
C	      ARGUMENT
C
C	   USAGE
C	      CALL PILD(POLY,DVAL,ARGUM,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      POLY  - VALUE OF POLYNOMIAL
C	      DVAL  - DERIVATIVE
C	      ARGUM - ARGUMENT
C	      X     - VECTOR OF COEFFICIENTS FOR POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      PQSD
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF SUBROUTINE PQSD (QUADRATIC
C	      SYNTHETIC DIVISION)
C
C	..................................................................
C
	SUBROUTINE PILD (POLY,DVAL,ARGUM,X,IDIMX)
	DIMENSION X(1)
C
	P=ARGUM+ARGUM
	Q=-ARGUM*ARGUM
C
	CALL PQSD (DVAL,POLY,P,Q,X,IDIMX)
C
	POLY=ARGUM*DVAL+POLY
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PINT
C
C	   PURPOSE
C	      FIND INTEGRAL OF A POLYNOMIAL WITH CONSTANT OF INTEGRATION
C	      EQUAL TO ZERO
C
C	   USAGE
C	      CALL PINT(Y,IDIMY,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     - VECTOR OF COEFFICIENTS FOR INTEGRAL, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (EQUAL TO IDIMX+1)
C	      X     - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF Y IS SET AT DIMENSION OF X PLUS ONE, AND THE
C	      CONSTANT TERM IS SET TO ZERO. INTEGRAL IS THEN CALCULATED
C	      BY DIVIDING COEFFICIENTS BY THEIR RESPECTIVE EXPONENTS.
C
C	..................................................................
C
	SUBROUTINE PINT(Y,IDIMY,X,IDIMX)
	DIMENSION X(1),Y(1)
C
	IDIMY=IDIMX+1
	Y(1)=0.
	IF(IDIMX)1,1,2
1	RETURN
2	EXPT=1.
	DO 3 I=2,IDIMY
	Y(I)=X(I-1)/EXPT
3	EXPT=EXPT+1.
	GO TO 1
	END
C
C	..................................................................
C
C	   SUBROUTINE PLOT
C
C	   PURPOSE
C	      PLOT SEVERAL CROSS-VARIABLES VERSUS A BASE VARIABLE
C
C	   USAGE
C	      CALL PLOT (NO,A,N,M,NL,NS)
C
C	   DESCRIPTION OF PARAMETERS
C	      NO - CHART NUMBER (3 DIGITS MAXIMUM)
C	      A  - MATRIX OF DATA TO BE PLOTTED. FIRST COLUMN REPRESENTS
C	           BASE VARIABLE AND SUCCESSIVE COLUMNS ARE THE CROSS-
C	           VARIABLES (MAXIMUM IS 9).
C	      N  - NUMBER OF ROWS IN MATRIX A
C	      M  - NUMBER OF COLUMNS IN MATRIX A (EQUAL TO THE TOTAL
C	           NUMBER OF VARIABLES). MAXIMUM IS 10.
C	      NL - NUMBER OF LINES IN THE PLOT. IF 0 IS SPECIFIED, 50
C	           LINES ARE USED.
C	      NS - CODE FOR SORTING THE BASE VARIABLE DATA IN ASCENDING
C	           ORDER
C	             0  SORTING IS NOT NECESSARY (ALREADY IN ASCENDING
C	                ORDER).
C	             1  SORTING IS NECESSARY.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	..................................................................
C
	SUBROUTINE PLOT(NO,A,N,M,NL,NS)
	DIMENSION OUT(101),YPR(11),ANG(9),A(1)
C
1	FORMAT(1H1,60X,7H CHART ,I3,//)
2	FORMAT(1H ,F11.4,5X,101A1)
3	FORMAT(1H )
4	FORMAT(10H 123456789)
5	FORMAT(10A1)
7	FORMAT(1H ,16X,101H.         .         .         .         .      
     1   .         .         .         .         .         .)
8	FORMAT(1H0,9X,11F10.4)
C
C	..................................................................
C
	NLL=NL
C
	IF(NS) 16, 16, 10
C
C	   SORT BASE VARIABLE DATA IN ASCENDING ORDER
C
10	DO 15 I=1,N
	DO 14 J=I,N
	IF(A(I)-A(J)) 14, 14, 11
11	L=I-N
	LL=J-N
	DO 12 K=1,M
	L=L+N
	LL=LL+N
	F=A(L)
	A(L)=A(LL)
12	A(LL)=F
14	CONTINUE
15	CONTINUE
C
C	   TEST NLL
C
16	IF(NLL) 20, 18, 20
18	NLL=50
C
C	   PRINT TITLE
C
20	WRITE(6,1)NO
C
C	   DEVELOP BLANK AND DIGITS FOR PRINTING
C
	REWIND 13
	WRITE (13,4)
	REWIND 13
	READ (13,5) BLANK,(ANG(I),I=1,9)
	REWIND 13
C
C	   FIND SCALE FOR BASE VARIABLE
C
	XSCAL=(A(N)-A(1))/(FLOAT(NLL-1))
C
C	   FIND SCALE FOR CROSS-VARIABLES
C
	M1=N+1
	YMIN=A(M1)
	YMAX=YMIN
	M2=M*N
	DO 40 J=M1,M2
	IF(A(J)-YMIN) 28,26,26
26	IF(A(J)-YMAX) 40,40,30
28	YMIN=A(J)
	GO TO 40
30	YMAX=A(J)
40	CONTINUE
	YSCAL=(YMAX-YMIN)/100.0
C
C	   FIND BASE VARIABLE PRINT POSITION
C
	XB=A(1)
	L=1
	MY=M-1
	I=1
45	F=I-1
	XPR=XB+F*XSCAL
	IF(A(L)-XPR) 50,50,70
C
C	   FIND CROSS-VARIABLES
C
50	DO 55 IX=1,101
55	OUT(IX)=BLANK
	DO 60 J=1,MY
	LL=L+J*N
	JP=((A(LL)-YMIN)/YSCAL)+1.0
	OUT(JP)=ANG(J)
60	CONTINUE
C
C	   PRINT LINE AND CLEAR, OR SKIP
C
	WRITE(6,2)XPR,(OUT(IZ),IZ=1,101)
	L=L+1
	GO TO 80
70	WRITE(6,3)
80	I=I+1
	IF(I-NLL) 45, 84, 86
84	XPR=A(N)
	GO TO 50
C
C	   PRINT CROSS-VARIABLES NUMBERS
C
86	WRITE(6,7)
	YPR(1)=YMIN
	DO 90 KN=1,9
90	YPR(KN+1)=YPR(KN)+YSCAL*10.0
	YPR(11)=YMAX
	WRITE(6,8)(YPR(IP),IP=1,11)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PMPY
C
C	   PURPOSE
C	      MULTIPLY TWO POLYNOMIALS
C
C	   USAGE
C	      CALL PMPY(Z,IDIMZ,X,IDIMX,Y,IDIMY)
C
C	   DESCRIPTION OF PARAMETERS
C	      Z     - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMZ - DIMENSION OF Z (CALCULATED)
C	      X     - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1)
C	      Y     - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1)
C
C	   REMARKS
C	      Z CANNOT BE IN THE SAME LOCATION AS X
C	      Z CANNOT BE IN THE SAME LOCATION AS Y
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF Z IS CALCULATED AS IDIMX+IDIMY-1
C	      THE COEFFICIENTS OF Z ARE CALCULATED AS SUM OF PRODUCTS
C	      OF COEFFICIENTS OF X AND Y , WHOSE EXPONENTS ADD UP TO THE
C	      CORRESPONDING EXPONENT OF Z.
C
C	..................................................................
C
	SUBROUTINE PMPY(Z,IDIMZ,X,IDIMX,Y,IDIMY)
	DIMENSION Z(1),X(1),Y(1)
C
	IF(IDIMX*IDIMY)10,10,20
10	IDIMZ=0
	GO TO 50
20	IDIMZ=IDIMX+IDIMY-1
	DO 30 I=1,IDIMZ
30	Z(I)=0.
	DO 40 I=1,IDIMX
	DO 40 J=1,IDIMY
	K=I+J-1
40	Z(K)=X(I)*Y(J)+Z(K)
50	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PNORM
C
C	   PURPOSE
C	      NORMALIZE COEFFICIENT VECTOR OF A POLYNOMIAL
C
C	   USAGE
C	      CALL PNORM(X,IDIMX,EPS)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - VECTOR OF ORIGINAL COEFFICIENTS, ORDERED FROM
C	               SMALLEST TO LARGEST POWER. IT REMAINS UNCHANGED
C	      IDIMX  - DIMENSION OF X. IT IS REPLACED BY FINAL DIMENSION
C	      EPS    - TOLERANCE BELOW WHICH COEFFICIENT IS ELIMINATED
C
C	   REMARKS
C	      IF ALL COEFFICIENTS ARE LESS THAN EPS, RESULT IS A ZERO
C	      POLYNOMIAL WITH IDIMX=0 BUT VECTOR X REMAINS INTACT
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF VECTOR X IS REDUCED BY ONE FOR EACH TRAILING
C	      COEFFICIENT WITH AN ABSOLUTE VALUE LESS THAN OR EQUAL TO EPS
C
C	..................................................................
C
	SUBROUTINE PNORM(X,IDIMX,EPS)
	DIMENSION X(1)
C
1	IF(IDIMX) 4,4,2
2	IF(ABS(X(IDIMX))-EPS) 3,3,4
3	IDIMX=IDIMX-1
	GO TO 1
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE POINT
C
C	   PURPOSE
C	      TO COMPUTE THE POINT-BISERIAL CORRELATION COEFFICIENT
C	      BETWEEN TWO VARIABLES, WHEN ONE OF THE VARIABLES IS A BINARY
C	      VARIABLE AND ONE IS CONTINUOUS.  THIS IS A SPECIAL CASE OF
C	      THE PEARSON PRODUCT-MOMENT CORRELATION COEFFICIENT.
C
C	   USAGE
C	      CALL POINT (N,A,B,HI,ANS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      N   - NUMBER OF OBSERVATIONS
C	      A   - INPUT VECTOR OF LENGTH N CONTAINING THE CONTINUOUS
C	            VARIABLE
C	      B   - INPUT VECTOR OF LENGTH N CONTAINING THE DICHOTOMOUS
C	            (BINARY) VARIABLE
C	      HI  - INPUT NUMERICAL CODE TO INDICATE THE HIGHER CATEGORY.
C	            ANY VALUE OF THE BINARY VARIABLE NOT LESS THAN HI WILL
C	            BE CLASSIFIED IN THE HIGHER OF THE TWO CATEGORIES.
C	      ANS - OUTPUT VECTOR OF LENGTH 9 CONTAINING THE FOLLOWING
C	            RESULTS
C	               ANS(1)- MEAN OF VARIABLE A
C	               ANS(2)- STANDARD DEVIATION OF VARIABLE A
C	               ANS(3)- NUMBER OF OBSERVATIONS IN THE HIGHER
C	                       CATEGORY OF VARIABLE B
C	               ANS(4)- NUMBER OF OBSERVATIONS IN THE LOWER
C	                       CATEGORY OF VARIABLE B
C	               ANS(5)- MEAN OF VARIABLE A FOR ONLY THOSE
C	                       OBSERVATIONS IN THE HIGHER CATEGORY OF
C	                       VARIABLE B
C	               ANS(6)- MEAN OF VARIABLE A FOR ONLY THOSE
C	                       OBSERVATIONS IN THE LOWER CATEGORY OF
C	                       VARIABLE B
C	               ANS(7)- POINT-BISERIAL CORRELATION COEFFICIENT
C	               ANS(8)- T-TEST FOR THE SIGNIFICANCE OF THE
C	                       DIFFERENCE BETWEEN THE MEANS OF VARIABLE A
C	                       FOR THE HIGHER AND LOWER CATEGORIES
C	                       RESPECTIVELY.
C	               ANS(9)- DEGREES OF FREEDOM FOR THE T-TEST
C	      IER- 1, IF ALL ELEMENTS OF B ARE NOT LESS THAN HI.
C	           -1, IF ALL ELEMENTS OF B ARE LESS THAN HI.
C	           0, OTHERWISE.  IF IER IS NON-ZERO, ANS(I), I=5,...,9,
C	           IS SET TO 10**75.
C
C	   REMARKS
C	      THE SYMBOLS USED TO IDENTFY THE VALUES OF THE TWO CATEGORIES
C	      OF VARIABLE B MUST BE NUMERIC.  ALPHABETIC OR SPECIAL
C	      CHARACTERS CANNOT BE USED.
C	      THE T-TEST(ANS(8)) IS A TEST OF WHETHER THE POINT-BISERIAL
C	      COEFFICIENT DIFFERS SIGNIFICANTLY FROM ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO P. HORST, 'PSYCHOLOGICAL MEASUREMENT AND
C	      PREDICTION', P. 91 (WADSWORTH, 1966).
C
C	..................................................................
C
	SUBROUTINE POINT (N,A,B,HI,ANS,IER)
C
	DIMENSION A(1),B(1),ANS(1)
C
C	   COMPUTE MEAN AND STANDARD DEVIATION OF VARIABLE A
C
	IER=0
	SUM=0.0
	SUM2=0.0
	DO 10 I=1,N
	SUM=SUM+A(I)
10	SUM2=SUM2+A(I)*A(I)
	FN=N
	ANS(1)=SUM/FN
	ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0)
	ANS(2)= SQRT(ANS(2))
C
C	   FIND NUMBERS OF CASES IN THE HIGHER AND LOWER CATEGORIES
C
	P=0.0
	SUM=0.0
	SUM2=0.0
	DO 30 I=1,N
	IF(B(I)-HI) 20, 25, 25
20	SUM2=SUM2+A(I)
	GO TO 30
25	P=P+1.0
	SUM=SUM+A(I)
30	CONTINUE
C
	Q=FN-P
	ANS(3)=P
	ANS(4)=Q
	IF (P) 35,35,40
35	IER=-1
	GO TO 50
40	ANS(5)=SUM/P
	IF (Q) 45,45,60
45	IER=1
50	DO 55 I=5,9
55	ANS(I)=1.7E38                                                             0
	GO TO 65
60	ANS(6)=SUM2/Q
C
C	   COMPUTE THE POINT-BISERIAL CORRELATION
C
	R=((ANS(5)-ANS(1))/ANS(2))* SQRT(P/Q)
	ANS(7)=R
C
C	   COMPUTE T RATIO USED TO TEST THE HYPOTHESIS OF ZERO CORRELATION
C
	T=R* SQRT((FN-2.0)/(1.0-R*R))
	ANS(8)=T
C
C	   COMPUTE DEGREES OF FREEDOM
C
	ANS(9)=FN-2
C
65	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR POLYNOMIAL REGRESSION - POLRG
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD FOR A POLYNOMIAL REGRES-
C	      SION, (2) CALL SUBROUTINES TO PERFORM THE ANALYSIS, (3)
C	      PRINT THE REGRESSION COEFFICIENTS AND ANALYSIS OF VARIANCE
C	      TABLE FOR POLYNOMIALS OF SUCCESSIVELY INCREASING DEGREES,
C	      AND (4) OPTIONALLY PRINT THE TABLE OF RESIDUALS AND A PLOT
C	      OF Y VALUES AND Y ESTIMATES.
C
C	   REMARKS
C	      THE NUMBER OF OBSERVATIONS, N, MUST BE GREATER THAN M+1,
C	      WHERE M IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED.
C	      IF THERE IS NO REDUCTION IN THE RESIDUAL SUM OF SQUARES
C	      BETWEEN TWO SUCCESSIVE DEGREES OF THE POLYNOMIALS, THE
C	      PROGRAM TERMINATES THE PROBLEM BEFORE COMPLETING THE ANALY-
C	      SIS FOR THE HIGHEST DEGREE POLYNOMIAL SPECIFIED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      GDATA
C	      ORDER
C	      MINV
C	      MULTR
C	      PLOT  (A SPECIAL PLOT SUBROUTINE PROVIDED FOR THE SAMPLE
C	            PROGRAM.)
C
C	   METHOD
C	      REFER TO B. OSTLE, 'STATISTICS IN RESEARCH', THE IOWA STATE
C	      COLLEGE PRESS', 1954, CHAPTER 6.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C	PRODUCT OF N*(M+1), WHERE N IS THE NUMBER OF OBSERVATIONS AND M
C	IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED..
cC
c	   DIMENSION X(1100)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*M..
cC
c	   DIMENSION DI(100)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
cC	(M+2)*(M+1)/2..
cC
c	   DIMENSION D(66)
cC
cC	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO M..
cC
c	   DIMENSION B(10),E(10),SB(10),T(10)
cC
cC	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO (M+1)..
cC
c	   DIMENSION XBAR(11),STD(11),COE(11),SUMSQ(11),ISAVE(11)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 10..
cC
c	   DIMENSION ANS(10)
cC
cC	THE FOLLOWING DIMENSION WILL BE USED IF THE PLOT OF OBSERVED DATA
cC	AND ESTIMATES IS DESIRED.  THE SIZE OF THE DIMENSION, IN THIS
cC	CASE, MUST BE GREATER THAN OR EQUAL TO N*3.  OTHERWISE, THE SIZE
cC	OF DIMENSION MAY BE SET TO 1.
cC
c	   DIMENSION P(300)
cC
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION X,XBAR,STD,D,SUMSQ,DI,E,B,SB,T,ANS,DET,COE
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	   ...............................................................
cC
c1	FORMAT(A4,A2,I5,I2,I1)
c2	FORMAT(2F6.0)
c3	FORMAT(27H1POLYNOMIAL REGRESSION.....,A4,A2/)
c4	FORMAT(23H0NUMBER OF OBSERVATIONS,I6//)
c5	FORMAT(32H0POLYNOMIAL REGRESSION OF DEGREE,I3)
c6	FORMAT(12H0  INTERCEPT,E20.7)
c7	FORMAT(26H0  REGRESSION COEFFICIENTS/(6E20.7))
c8	FORMAT(1H0/24X,24HANALYSIS OF VARIANCE FOR,I4,19H  DEGREE POLYNOMI
c     1AL/)
c9	FORMAT(1H0,5X,19HSOURCE OF VARIATION,7X,9HDEGREE OF,7X,6HSUM OF,9X
c     1,4HMEAN,10X,1HF,9X,20HIMPROVEMENT IN TERMS/33X,7HFREEDOM,8X,7HSQUA
c     2RES,7X,6HSQUARE,7X,5HVALUE,8X,17HOF SUM OF SQUARES)
c10	FORMAT(20H0  DUE TO REGRESSION,12X,I6,F17.5,F14.5,F13.5,F20.5)
c11	FORMAT(32H   DEVIATION ABOUT REGRESSION   ,I6,F17.5,F14.5)
c12	FORMAT(8X,5HTOTAL,19X,I6,F17.5///)
c13	FORMAT(17H0  NO IMPROVEMENT)
c14	FORMAT(1H0//27X,18HTABLE OF RESIDUALS//16H OBSERVATION NO.,5X,7HX
c     1VALUE,7X,7HY VALUE,7X,10HY ESTIMATE,7X,8HRESIDUAL/)
c15	FORMAT(1H0,3X,I6,F18.5,F14.5,F17.5,F15.5)
cC	DOUBLE PRECISION TMPFIL,FILE
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC	FILE = TMPFIL('SSP')
cC	OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
cC	1	DISPOSE='DELETE')
cC
cC	..................................................................
cC
cC	READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR,PR1,N,M,NPLOT
c	IF (EOF) GOTO 999
cC
cC	   PR....PROBLEM NUMBER (MAY BE ALPHAMERIC)
cC	   PR1...PROBLEM NUMBER (CONTINUED)
cC	   N.....NUMBER OF OBSERVATIONS
cC	   M.....HIGHEST DEGREE POLYNOMIAL SPECIFIED
cC	   NPLOT.OPTION CODE FOR PLOTTING
cC	         0  IF PLOT IS NOT DESIRED.
cC	         1  IF PLOT IS DESIRED.
cC
cC	PRINT PROBLEM NUMBER AND N.
cC
c	WRITE (6,3) PR,PR1
c	WRITE (6,4) N
cC
cC	READ INPUT DATA
cC
c	L=N*M
c	DO 110 I=1,N
c	J=L+I
cC
cC	   X(I) IS THE INDEPENDENT VARIABLE, AND X(J) IS THE DEPENDENT
cC	   VARIABLE.
cC
c110	READ (5,2) X(I),X(J)
cC
c	CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ)
cC
c	MM=M+1
cc	SUM=0.0
c	NT=N-1
cC
c	DO 200 I=1,M
c	ISAVE(I)=I
cC
cC	FORM SUBSET OF CORRELATION COEFFICIENT MATRIX
cC
c	CALL ORDER (MM,D,MM,I,ISAVE,DI,E)
cC
cC	INVERT THE SUBMATRIX OF CORRELATION COEFFICIENTS
cC
c	CALL MINV (DI,I,DET,B,T)
cC
c	CALL MULTR (N,I,XBAR,STD,SUMSQ,DI,E,ISAVE,B,SB,T,ANS)
cC
cC	PRINT THE RESULT OF CALCULATION
cC
c	WRITE (6,5) I
c	IF(ANS(7)) 140,130,130
c130	SUMIP=ANS(4)-SUM
c	IF(SUMIP) 140, 140, 150
c140	WRITE (6,13)
c	GO TO 210
c150	WRITE (6,6) ANS(1)
c	WRITE (6,7) (B(J),J=1,I)
c	WRITE (6,8) I
c	WRITE (6,9)
c	SUM=ANS(4)
c	WRITE (6,10) I,ANS(4),ANS(6),ANS(10),SUMIP
c	NI=ANS(8)
c	WRITE (6,11) NI,ANS(7),ANS(9)
c	WRITE (6,12) NT,SUMSQ(MM)
cC
cC	SAVE COEFFICIENTS FOR CALCULATION OF Y ESTIMATES
cC
c	COE(1)=ANS(1)
c	DO 160 J=1,I
c160	COE(J+1)=B(J)
c	LA=I
c200	CONTINUE
cC
cC	TEST WHETHER PLOT IS DESIRED
cC
c210	IF(NPLOT) 100, 100, 220
cC
cC	   CALCULATE ESTIMATES
cC
c220	NP3=N+N
c	DO 230 I=1,N
c	NP3=NP3+1
c	P(NP3)=COE(1)
c	L=I
c	DO 230 J=1,LA
c	P(NP3)=P(NP3)+X(L)*COE(J+1)
c230	L=L+N
cC
cC	   COPY OBSERVED DATA
cC
c	N2=N
c	L=N*M
c	DO 240 I=1,N
c	P(I)=X(I)
c	N2=N2+1
c	L=L+1
c240	P(N2)=X(L)
cC
cC	PRINT TABLE OF RESIDUALS
cC
c	WRITE (6,3) PR,PR1
c	WRITE (6,5) LA
c	WRITE (6,14)
c	NP2=N
c	NP3=N+N
c	DO 250 I=1,N
c	NP2=NP2+1
c	NP3=NP3+1
c	RESID=P(NP2)-P(NP3)
c250	WRITE (6,15) I,P(I),P(NP2),P(NP3),RESID
cC
c	CALL PLOT (LA,P,N,3,0,1)
cC
c	GO TO 100
c999	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE POLRT
C
C	   PURPOSE
C	      COMPUTES THE REAL AND COMPLEX ROOTS OF A REAL POLYNOMIAL
C
C	   USAGE
C	      CALL POLRT(XCOF,COF,M,ROOTR,ROOTI,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      XCOF -VECTOR OF M+1 COEFFICIENTS OF THE POLYNOMIAL
C	            ORDERED FROM SMALLEST TO LARGEST POWER
C	      COF  -WORKING VECTOR OF LENGTH M+1
C	      M    -ORDER OF POLYNOMIAL
C	      ROOTR-RESULTANT VECTOR OF LENGTH M CONTAINING REAL ROOTS
C	            OF THE POLYNOMIAL
C	      ROOTI-RESULTANT VECTOR OF LENGTH M CONTAINING THE
C	            CORRESPONDING IMAGINARY ROOTS OF THE POLYNOMIAL
C	      IER  -ERROR CODE WHERE
C	            IER=0  NO ERROR
C	            IER=1  M LESS THAN ONE
C	            IER=2  M GREATER THAN 36
C	            IER=3  UNABLE TO DETERMINE ROOT WITH 500 INTERATIONS
C	                   ON 5 STARTING VALUES
C	            IER=4  HIGH ORDER COEFFICIENT IS ZERO
C
C	   REMARKS
C	      LIMITED TO 36TH ORDER POLYNOMIAL OR LESS.
C	      FLOATING POINT OVERFLOW MAY OCCUR FOR HIGH ORDER
C	      POLYNOMIALS BUT WILL NOT AFFECT THE ACCURACY OF THE RESULTS.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      NEWTON-RAPHSON ITERATIVE TECHNIQUE.  THE FINAL ITERATIONS
C	      ON EACH ROOT ARE PERFORMED USING THE ORIGINAL POLYNOMIAL
C	      RATHER THAN THE REDUCED POLYNOMIAL TO AVOID ACCUMULATED
C	      ERRORS IN THE REDUCED POLYNOMIAL.
C
C	..................................................................
C
	SUBROUTINE POLRT(XCOF,COF,M,ROOTR,ROOTI,IER)
	DIMENSION XCOF(1),COF(1),ROOTR(1),ROOTI(1)
	DOUBLE PRECISION XO,YO,X,Y,XPR,YPR,UX,UY,V,YT,XT,U,XT2,YT2,SUMSQ,
     1 DX,DY,TEMP,ALPHA
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION XCOF,COF,ROOTR,ROOTI
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C	   THE DOUBLE PRECISION VERSION MAY BE MODIFIED BY CHANGING THE
C	   CONSTANT IN STATEMENT 78 TO 1.0D-12 AND IN STATEMENT 122 TO
C	   1.0D-10.  THIS WILL PROVIDE HIGHER PRECISION RESULTS AT THE
C	   COST OF EXECUTION TIME
C
C	   ...............................................................
C
	IFIT=0
	N=M
	IER=0
	IF(XCOF(N+1))10,25,10
10	IF(N) 15,15,32
C
C	   SET ERROR CODE TO 1
C
15	IER=1
20	RETURN
C
C	   SET ERROR CODE TO 4
C
25	IER=4
	GO TO 20
C
C	   SET ERROR CODE TO 2
C
30	IER=2
	GO TO 20
32	IF(N-36) 35,35,30
35	NX=N
	NXX=N+1
	N2=1
	KJ1 = N+1
	DO 40 L=1,KJ1
	MT=KJ1-L+1
40	COF(MT)=XCOF(L)
C
C	   SET INITIAL VALUES
C
45	XO=.00500101
	YO=0.01000101
C
C	   ZERO INITIAL VALUE COUNTER
C
	IN=0
50	X=XO
C
C	   INCREMENT INITIAL VALUES AND COUNTER
C
	XO=-10.0*YO
	YO=-10.0*X
C
C	   SET X AND Y TO CURRENT VALUE
C
	X=XO
	Y=YO
	IN=IN+1
	GO TO 59
55	IFIT=1
	XPR=X
	YPR=Y
C
C	   EVALUATE POLYNOMIAL AND DERIVATIVES
C
59	ICT=0
60	UX=0.0
	UY=0.0
	V =0.0
	YT=0.0
	XT=1.0
	U=COF(N+1)
	IF(U) 65,130,65
65	DO 70 I=1,N
	L =N-I+1
	TEMP=COF(L)
	XT2=X*XT-Y*YT
	YT2=X*YT+Y*XT
	U=U+TEMP*XT2
	V=V+TEMP*YT2
	FI=I
	UX=UX+FI*XT*TEMP
	UY=UY-FI*YT*TEMP
	XT=XT2
70	YT=YT2
	SUMSQ=UX*UX+UY*UY
	IF(SUMSQ) 75,110,75
75	DX=(V*UY-U*UX)/SUMSQ
	X=X+DX
	DY=-(U*UY+V*UX)/SUMSQ
	Y=Y+DY
78	IF(DABS(DY)+DABS(DX)-1.0D-05) 100,80,80
C
C	   STEP ITERATION COUNTER
C
80	ICT=ICT+1
	IF(ICT-500) 60,85,85
85	IF(IFIT)100,90,100
90	IF(IN-5) 50,95,95
C
C	   SET ERROR CODE TO 3
C
95	IER=3
	GO TO 20
100	DO 105 L=1,NXX
	MT=KJ1-L+1
	TEMP=XCOF(MT)
	XCOF(MT)=COF(L)
105	COF(L)=TEMP
	ITEMP=N
	N=NX
	NX=ITEMP
	IF(IFIT) 120,55,120
110	IF(IFIT) 115,50,115
115	X=XPR
	Y=YPR
120	IFIT=0
122	IF(DABS(Y)-1.0D-4*DABS(X)) 135,125,125
125	ALPHA=X+X
	SUMSQ=X*X+Y*Y
	N=N-2
	GO TO 140
130	X=0.0
	NX=NX-1
	NXX=NXX-1
135	Y=0.0
	SUMSQ=0.0
	ALPHA=X
	N=N-1
140	COF(2)=COF(2)+ALPHA*COF(1)
145	DO 150 L=2,N
150	COF(L+1)=COF(L+1)+ALPHA*COF(L)-SUMSQ*COF(L-1)
155	ROOTI(N2)=Y
	ROOTR(N2)=X
	N2=N2+1
	IF(SUMSQ) 160,165,160
160	Y=-Y
	SUMSQ=0.0
	GO TO 155
165	IF(N) 20,20,45
	END
C
C	..................................................................
C
C	   SUBROUTINE PPRCN
C
C	   PURPOSE
C	      TO COMPUTE, GIVEN TWO PERMUTATION VECTORS IP1 AND IP2, THE
C	      COMPOSITION IP2(IP1) AND THE CONJUGATE IP1(IP2(IP1 INVERSE))
C	      OF IP2 BY IP1.  (SEE THE GENERAL DISCUSSION FOR DEFINITIONS
C	      AND NOTATION.)
C
C	   USAGE
C	      CALL PPRCN(IP1,IP2,IP3,N,IPAR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      IP1  - GIVEN PERMUTATION VECTOR (DIMENSION N)
C	      IP2  - GIVEN PERMUTATION VECTOR (DIMENSION N)
C	      IP3  - RESULTING PERMUTATION VECTOR (DIMENSION N)
C	      N    - DIMENSION OF VECTORS IP1, IP2 AND IP3
C	      IPAR - INPUT PARAMETER
C	             IPAR NON-NEGATIVE - COMPUTE IP2(IP1)
C	             IPAR NEGATIVE     - COMPUTE IP1(IP2(IP1 INVERSE))
C	      IER  - RESULTING ERROR PARAMETER
C	             IER=-1  -  N IS NOT POSITIVE
C	             IER= 0  -  NO ERROR
C	             IER= 1  -  IP1 AND IP2 ARE NOT BOTH PERMUTATION
C	                        VECTORS ON 1,...,N
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)  IF IER=1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE TO
C	           ERROR AND THE PARTIAL RESULTS FOUND IN IP2 ARE USELESS.
C	      (3)  IP3 CANNOT HAVE THE SAME STORAGE ALLOCATION AS IP1 OR
C	           IP2.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      PERM
C
C	   METHOD
C	      SUBROUTINE PERM IS USED TO CHECK THAT IP1 AND IP2 ARE PERMU-
C	      TATION VECTORS.  IF IP2(IP1) IS COMPUTED, IP3(I) IS SET TO
C	      IP2(IP1(I)) FOR I=1,...,N.  IF IP1(IP2(IP1 INVERSE)) IS
C	      COMPUTED, FIRST IP3 IS SET TO IP1 INVERSE BY SUBROUTINE PERM
C	      AND THEN IP3(I) IS SET TO IP1(IP2(IP3(I))) FOR I=1,...,N.
C
C	..................................................................
C
	SUBROUTINE PPRCN(IP1,IP2,IP3,N,IPAR,IER)
C
C
	DIMENSION IP1(1),IP2(1),IP3(1)
C
C	   CHECK THAT N IS POSITIVE AND THAT IP2 IS A PERMUTATION VECTOR
	CALL PERM(IP2,IP3,N,-1,IER)
C
C	   TEST IER TO SEE IF THERE IS AN ERROR
	IF(IER)7,1,7
C
C	   CHECK THAT IP1 IS A PERMUTATION VECTOR AND COMPUTE IP1 INVERSE
1	CALL PERM(IP1,IP3,N,-1,IER)
C
C	   TEST IER TO SEE IF THERE IS AN ERROR
	IF(IER)7,2,7
C
C	   TEST IPAR FOR THE DESIRED OPERATION
2	IF(IPAR)3,5,5
C
C	   COMPUTE IP1(IP2(IP1 INVERSE))
3	DO 4 I=1,N
	K=IP3(I)
	J=IP2(K)
4	IP3(I)=IP1(J)
	RETURN
C
C	   COMPUTE IP2(IP1)
5	DO 6 I=1,N
	K=IP1(I)
6	IP3(I)=IP2(K)
7	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PQFB
C
C	   PURPOSE
C	      TO FIND AN APPROXIMATION Q(X)=Q1+Q2*X+X*X TO A QUADRATIC
C	      FACTOR OF A GIVEN POLYNOMIAL P(X) WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL PQFB(C,IC,Q,LIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C   - INPUT VECTOR CONTAINING THE COEFFICIENTS OF P(X) -
C	            C(1) IS THE CONSTANT TERM (DIMENSION IC)
C	      IC  - DIMENSION OF C
C	      Q   - VECTOR OF DIMENSION 4 - ON INPUT Q(1) AND Q(2) MUST
C	            CONTAIN INITIAL GUESSES FOR Q1 AND Q2 - ON RETURN Q(1)
C	            AND Q(2) CONTAIN THE REFINED COEFFICIENTS Q1 AND Q2 OF
C	            Q(X), WHILE Q(3) AND Q(4) CONTAIN THE COEFFICIENTS A
C	            AND B OF A+B*X, WHICH IS THE REMAINDER OF THE QUOTIENT
C	            OF P(X) BY Q(X)
C	      LIM - INPUT VALUE SPECIFYING THE MAXIMUM NUMBER OF
C	            ITERATIONS TO BE PERFORMED
C	      IER - RESULTING ERROR PARAMETER (SEE REMARKS)
C	            IER= 0 - NO ERROR
C	            IER= 1 - NO CONVERGENCE WITHIN LIM ITERATIONS
C	            IER=-1 - THE POLYNOMIAL P(X) IS CONSTANT OR UNDEFINED
C	                     - OR OVERFLOW OCCURRED IN NORMALIZING P(X)
C	            IER=-2 - THE POLYNOMIAL P(X) IS OF DEGREE 1
C	            IER=-3 - NO FURTHER REFINEMENT OF THE APPROXIMATION TO
C	                     A QUADRATIC FACTOR IS FEASIBLE, DUE TO EITHER
C	                     DIVISION BY 0, OVERFLOW OR AN INITIAL GUESS
C	                     THAT IS NOT SUFFICIENTLY CLOSE TO A FACTOR OF
C	                     P(X)
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE IS NO COMPUTATION OTHER THAN THE
C	           POSSIBLE NORMALIZATION OF C.
C	      (2)  IF IER=-2 THERE IS NO COMPUTATION OTHER THAN THE
C	           NORMALIZATION OF C.
C	      (3)  IF IER =-3  IT IS SUGGESTED THAT A NEW INITIAL GUESS BE
C	           MADE FOR A QUADRATIC FACTOR.  Q, HOWEVER, WILL CONTAIN
C	           THE VALUES ASSOCIATED WITH THE ITERATION THAT YIELDED
C	           THE SMALLEST NORM OF THE MODIFIED LINEAR REMAINDER.
C	      (4)  IF IER=1, THEN, ALTHOUGH THE NUMBER OF ITERATIONS LIM
C	           WAS TOO SMALL TO INDICATE CONVERGENCE, NO OTHER PROB-
C	           LEMS HAVE BEEN DETECTED, AND Q WILL CONTAIN THE VALUES
C	           ASSOCIATED WITH THE ITERATION THAT YIELDED THE SMALLEST
C	           NORM OF THE MODIFIED LINEAR REMAINDER.
C	      (5)  FOR COMPLETE DETAIL SEE THE DOCUMENTATION FOR
C	           SUBROUTINES PQFB AND DPQFB.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      COMPUTATION IS BASED ON BAIRSTOW'S ITERATIVE METHOD.  (SEE
C	      WILKINSON, J.H., THE EVALUATION OF THE ZEROS OF ILL-CON-
C	      DITIONED POLYNOMIALS (PART ONE AND TWO), NUMERISCHE MATHE-
C	      MATIK, VOL.1 (1959), PP. 150-180, OR HILDEBRAND, F.B.,
C	      INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP. 472-476.)
C
C	..................................................................
C
	SUBROUTINE PQFB(C,IC,Q,LIM,IER)
C
C
	DIMENSION C(1),Q(1)
C
C	   TEST ON LEADING ZERO COEFFICIENTS
	IER=0
	J=IC+1
1	J=J-1
	IF(J-1)40,40,2
2	IF(C(J))3,1,3
C
C	   NORMALIZATION OF REMAINING COEFFICIENTS
3	A=C(J)
	IF(A-1.)4,6,4
4	DO 5 I=1,J
	C(I)=C(I)/A
	CALL OVERFL(N)
	IF(N-2)40,5,5
5	CONTINUE
C
C	   TEST ON NECESSITY OF BAIRSTOW ITERATION
6	IF(J-3)41,38,7
C
C	   PREPARE BAIRSTOW ITERATION
7	EPS=1.E-6
	EPS1=1.E-3
	L=0
	LL=0
	Q1=Q(1)
	Q2=Q(2)
	QQ1=0.
	QQ2=0.
	AA=C(1)
	BB=C(2)
	CB=ABS(AA)
	CA=ABS(BB)
	IF(CB-CA)8,9,10
8	CC=CB+CB
	CB=CB/CA
	CA=1.
	GO TO 11
9	CC=CA+CA
	CA=1.
	CB=1.
	GO TO 11
10	CC=CA+CA
	CA=CA/CB
	CB=1.
11	CD=CC*.1
C
C	   START BAIRSTOW ITERATION
C	   PREPARE NESTED MULTIPLICATION
12	A=0.
	B=A
	A1=A
	B1=A
	I=J
	QQQ1=Q1
	QQQ2=Q2
	DQ1=HH
	DQ2=H
C
C	   START NESTED MULTIPLICATION
13	H=-Q1*B-Q2*A+C(I)
	CALL OVERFL(N)
	IF(N-2)42,14,14
14	B=A
	A=H
	I=I-1
	IF(I-1)18,15,16
15	H=0.
16	H=-Q1*B1-Q2*A1+H
	CALL OVERFL(N)
	IF(N-2)42,17,17
17	C1=B1
	B1=A1
	A1=H
	GO TO 13
C	   END OF NESTED MULTIPLICATION
C
C	   TEST ON SATISFACTORY ACCURACY
18	H=CA*ABS(A)+CB*ABS(B)
	IF(LL)19,19,39
19	L=L+1
	IF(ABS(A)-EPS*ABS(C(1)))20,20,21
20	IF(ABS(B)-EPS*ABS(C(2)))39,39,21
C
C	   TEST ON LINEAR REMAINDER OF MINIMUM NORM
21	IF(H-CC)22,22,23
22	AA=A
	BB=B
	CC=H
	QQ1=Q1
	QQ2=Q2
C
C	   TEST ON LAST ITERATION STEP
23	IF(L-LIM)28,28,24
C
C	   TEST ON RESTART OF BAIRSTOW ITERATION WITH ZERO INITIAL GUESS
24	IF(H-CD)43,43,25
25	IF(Q(1))27,26,27
26	IF(Q(2))27,42,27
27	Q(1)=0.
	Q(2)=0.
	GO TO 7
C
C	   PERFORM ITERATION STEP
28	HH=AMAX1(ABS(A1),ABS(B1),ABS(C1))
	IF(HH)42,42,29
29	A1=A1/HH
	B1=B1/HH
	C1=C1/HH
	H=A1*C1-B1*B1
	IF(H)30,42,30
30	A=A/HH
	B=B/HH
	HH=(B*A1-A*B1)/H
	H=(A*C1-B*B1)/H
	Q1=Q1+HH
	Q2=Q2+H
C	   END OF ITERATION STEP
C
C	   TEST ON SATISFACTORY RELATIVE ERROR OF ITERATED VALUES
	IF(ABS(HH)-EPS*ABS(Q1))31,31,33
31	IF(ABS(H)-EPS*ABS(Q2))32,32,33
32	LL=1
	GO TO 12
C
C	   TEST ON DECREASING RELATIVE ERRORS
33	IF(L-1)12,12,34
34	IF(ABS(HH)-EPS1*ABS(Q1))35,35,12
35	IF(ABS(H)-EPS1*ABS(Q2))36,36,12
36	IF(ABS(QQQ1*HH)-ABS(Q1*DQ1))37,44,44
37	IF(ABS(QQQ2*H)-ABS(Q2*DQ2))12,44,44
C	   END OF BAIRSTOW ITERATION
C
C	   EXIT IN CASE OF QUADRATIC POLYNOMIAL
38	Q(1)=C(1)
	Q(2)=C(2)
	Q(3)=0.
	Q(4)=0.
	RETURN
C
C	   EXIT IN CASE OF SUFFICIENT ACCURACY
39	Q(1)=Q1
	Q(2)=Q2
	Q(3)=A
	Q(4)=B
	RETURN
C
C	   ERROR EXIT IN CASE OF ZERO OR CONSTANT POLYNOMIAL
40	IER=-1
	RETURN
C
C	   ERROR EXIT IN CASE OF LINEAR POLYNOMIAL
41	IER=-2
	RETURN
C
C	   ERROR EXIT IN CASE OF NONREFINED QUADRATIC FACTOR
42	IER=-3
	GO TO 44
C
C	   ERROR EXIT IN CASE OF UNSATISFACTORY ACCURACY
43	IER=1
44	Q(1)=QQ1
	Q(2)=QQ2
	Q(3)=AA
	Q(4)=BB
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PQSD
C
C	   PURPOSE
C	      PERFORM QUADRATIC SYNTHETIC DIVISION
C
C	   USAGE
C	      CALL PQSD(A,B,P,Q,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - COEFFICIENT OF Z IN REMAINDER (CALCULATED)
C	      B     - CONSTANT TERM IN REMAINDER (CALCULATED)
C	      P     - COEFFICIENT OF Z IN QUADRATIC POLYNOMIAL
C	      Q     - CONSTANT TERM IN QUADRATIC POLYNOMIAL
C	      X     - COEFFICIENT VECTOR FOR GIVEN POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      POLYNOMIAL IS DIVIDED BY THE QUADRATIC Z**2-P*Z-Q GIVING
C	      THE LINEAR REMAINDER A*Z+B
C
C	..................................................................
C
	SUBROUTINE PQSD(A,B,P,Q,X,IDIMX)
	DIMENSION X(1)
C
	A=0.
	B=0.
	J=IDIMX
1	IF(J)3,3,2
2	Z=P*A+B
	B=Q*A+X(J)
	A=Z
	J=J-1
	GO TO 1
3	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PRBM
C
C	   PURPOSE
C	      TO CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN
C	      POLYNOMIAL WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL PRBM (C,IC,RR,RC,POL,IR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C      - INPUT VECTOR CONTAINING THE COEFFICIENTS OF THE
C	               GIVEN POLYNOMIAL. COEFFICIENTS ARE ORDERED FROM
C	               LOW TO HIGH. ON RETURN COEFFICIENTS ARE DIVIDED
C	               BY THE LAST NONZERO TERM.
C	      IC     - DIMENSION OF VECTORS C, RR, RC, AND POL.
C	      RR     - RESULTANT VECTOR OF REAL PARTS OF THE ROOTS.
C	      RC     - RESULTANT VECTOR OF COMPLEX PARTS OF THE ROOTS.
C	      POL    - RESULTANT VECTOR OF COEFFICIENTS OF THE POLYNOMIAL
C	               WITH CALCULATED ROOTS. COEFFICIENTS ARE ORDERED
C	               FROM LOW TO HIGH (SEE REMARK 4).
C	      IR     - OUTPUT VALUE SPECIFYING THE NUMBER OF CALCULATED
C	               ROOTS. NORMALLY IR IS EQUAL TO IC-1.
C	      IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C	                IER=0  - NO ERROR,
C	                IER=1  - SUBROUTINE PQFB RECORDS POOR CONVERGENCE
C	                         AT SOME QUADRATIC FACTORIZATION WITHIN
C	                         50 ITERATION STEPS,
C	                IER=2  - POLYNOMIAL IS DEGENERATE, I.E. ZERO OR
C	                         CONSTANT,
C	                         OR OVERFLOW IN NORMALIZATION OF GIVEN
C	                         POLYNOMIAL,
C	                IER=3  - THE SUBROUTINE IS BYPASSED DUE TO
C	                         SUCCESSIVE ZERO DIVISORS OR OVERFLOWS
C	                         IN QUADRATIC FACTORIZATION OR DUE TO
C	                         COMPLETELY UNSATISFACTORY ACCURACY,
C	                IER=-1 - CALCULATED COEFFICIENT VECTOR HAS LESS
C	                         THAN THREE CORRECT SIGNIFICANT DIGITS.
C	                         THIS REVEALS POOR ACCURACY OF CALCULATED
C	                         ROOTS.
C
C	   REMARKS
C	      (1) REAL PARTS OF THE ROOTS ARE STORED IN RR(1) UP TO RR(IR)
C	          AND CORRESPONDING COMPLEX PARTS IN RC(1) UP TO RC(IR).
C	      (2) ERROR MESSAGE IER=1 INDICATES POOR CONVERGENCE WITHIN
C	          50 ITERATION STEPS AT SOME QUADRQTIC FACTORIZATION
C	          PERFORMED BY SUBROUTINE PQFB.
C	      (3) NO ACTION BESIDES ERROR MESSAGE IER=2 IN CASE OF A ZERO
C	          OR CONSTANT POLYNOMIAL. THE SAME ERROR MESSAGE IS GIVEN
C	          IN CASE OF AN OVERFLOW IN NORMALIZATION OF GIVEN
C	          POLYNOMIAL.
C	      (4) ERROR MESSAGE IER=3 INDICATES SUCCESSIVE ZERO DIVISORS
C	          OR OVERFLOWS OR COMPLETELY UNSATISFACTORY ACCURACY AT
C	          ANY QUADRATIC FACTORIZATION PERFORMED BY
C	          SUBROUTINE PQFB. IN THIS CASE CALCULATION IS BYPASSED.
C	          IR RECORDS THE NUMBER OF CALCULATED ROOTS.
C	          POL(1),...,POL(J-IR) ARE THE COEFFICIENTS OF THE
C	          REMAINING POLYNOMIAL, WHERE J IS THE ACTUAL NUMBER OF
C	          COEFFICIENTS IN VECTOR C (NORMALLY J=IC).
C	      (5) IF CALCULATED COEFFICIENT VECTOR HAS LESS THAN THREE
C	          CORRECT SIGNIFICANT DIGITS THOUGH ALL QUADRATIC
C	          FACTORIZATIONS SHOWED SATISFACTORY ACCURACY, THE ERROR
C	          MESSAGE IER=-1 IS GIVEN.
C	      (6) THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
C	          COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE
C	          BEEN CALCULATED. IN THIS CASE THE NUMBER OF ROOTS IR IS
C	          EQUAL TO THE ACTUAL DEGREE OF THE POLYNOMIAL (NORMALLY
C	          IR=IC-1). THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT
C	          VECTOR IS RECORDED IN RR(IR+1).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SUBROUTINE PQFB     QUADRATIC FACTORIZATION OF A POLYNOMIAL
C	                          BY BAIRSTOW ITERATION.
C
C	   METHOD
C	      THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
C	      SUCCESSIVE QUADRATIC FACTORIZATION PERFORMED BY BAIRSTOW
C	      ITERATION. X**2 IS USED AS INITIAL GUESS FOR THE FIRST
C	      QUADRATIC FACTOR, AND FURTHER EACH CALCULATED QUADRATIC
C	      FACTOR IS USED AS INITIAL GUESS FOR THE NEXT ONE. AFTER
C	      COMPUTATION OF ALL ROOTS THE COEFFICIENT VECTOR IS
C	      CALCULATED AND COMPARED WITH THE GIVEN ONE.
C	      FOR REFERENCE, SEE J. H. WILKINSON, THE EVALUATION OF THE
C	      ZEROS OF ILL-CONDITIONED POLYNOMIALS (PART ONE AND TWO),
C	      NUMERISCHE MATHEMATIK, VOL.1 (1959), PP.150-180.
C
C	..................................................................
C
	SUBROUTINE PRBM(C,IC,RR,RC,POL,IR,IER)
C
C
	DIMENSION C(1),RR(1),RC(1),POL(1),Q(4)
C
C	   TEST ON LEADING ZERO COEFFICIENTS
	EPS=1.E-3
	LIM=50
	IR=IC+1
1	IR=IR-1
	IF(IR-1)42,42,2
2	IF(C(IR))3,1,3
C
C	   WORK UP ZERO ROOTS AND NORMALIZE REMAINING POLYNOMIAL
3	IER=0
	J=IR
	L=0
	A=C(IR)
	DO 8 I=1,IR
	IF(L)4,4,7
4	IF(C(I))6,5,6
5	RR(I)=0.
	RC(I)=0.
	POL(J)=0.
	J=J-1
	GO TO 8
6	L=1
	IST=I
	J=0
7	J=J+1
	C(I)=C(I)/A
	POL(J)=C(I)
	CALL OVERFL(N)
	IF(N-2)42,8,8
8	CONTINUE
C
C	   START BAIRSTOW ITERATION
	Q1=0.
	Q2=0.
9	IF(J-2)33,10,14
C
C	   DEGREE OF RESTPOLYNOMIAL IS EQUAL TO ONE
10	A=POL(1)
	RR(IST)=-A
	RC(IST)=0.
	IR=IR-1
	Q2=0.
	IF(IR-1)13,13,11
11	DO 12 I=2,IR
	Q1=Q2
	Q2=POL(I+1)
12	POL(I)=A*Q2+Q1
13	POL(IR+1)=A+Q2
	GO TO 34
C	   THIS IS BRANCH TO COMPARISON OF COEFFICIENT VECTORS C AND POL
C
C	   DEGREE OF RESTPOLYNOMIAL IS GREATER THAN ONE
14	DO 22 L=1,10
	N=1
15	Q(1)=Q1
	Q(2)=Q2
	CALL PQFB(POL,J,Q,LIM,I)
	IF(I)16,24,23
16	IF(Q1)18,17,18
17	IF(Q2)18,21,18
18	GO TO (19,20,19,21),N
19	Q1=-Q1
	N=N+1
	GO TO 15
20	Q2=-Q2
	N=N+1
	GO TO 15
21	Q1=1.+Q1
22	Q2=1.-Q2
C
C	   ERROR EXIT DUE TO UNSATISFACTORY RESULTS OF FACTORIZATION
	IER=3
	IR=IR-J
	RETURN
C
C	   WORK UP RESULTS OF QUADRATIC FACTORIZATION
23	IER=1
24	Q1=Q(1)
	Q2=Q(2)
C
C	   PERFORM DIVISION OF FACTORIZED POLYNOMIAL BY QUADRATIC FACTOR
	B=0.
	A=0.
	I=J
25	H=-Q1*B-Q2*A+POL(I)
	POL(I)=B
	B=A
	A=H
	I=I-1
	IF(I-2)26,26,25
26	POL(2)=B
	POL(1)=A
C
C	   MULTIPLY POLYNOMIAL WITH CALCULATED ROOTS BY QUADRATIC FACTOR
	L=IR-1
	IF(J-L)27,27,29
27	DO 28 I=J,L
28	POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1
29	POL(L)=POL(L)+POL(L+1)*Q2+Q1
	POL(IR)=POL(IR)+Q2
C
C	   CALCULATE ROOT-PAIR FROM QUADRATIC FACTOR X*X+Q2*X+Q1
	H=-.5*Q2
	A=H*H-Q1
	B=SQRT(ABS(A))
	IF(A)30,30,31
30	RR(IST)=H
	RC(IST)=B
	IST=IST+1
	RR(IST)=H
	RC(IST)=-B
	GO TO 32
31	B=H+SIGN(B,H)
	RR(IST)=Q1/B
	RC(IST)=0.
	IST=IST+1
	RR(IST)=B
	RC(IST)=0.
32	IST=IST+1
	J=J-2
	GO TO 9
C
C	   SHIFT BACK ELEMENTS OF POL BY 1 AND COMPARE VECTORS POL AND C
33	IR=IR-1
34	A=0.
	DO 38 I=1,IR
	Q1=C(I)
	Q2=POL(I+1)
	POL(I)=Q2
	IF(Q1)35,36,35
35	Q2=(Q1-Q2)/Q1
36	Q2=ABS(Q2)
	IF(Q2-A)38,38,37
37	A=Q2
38	CONTINUE
	I=IR+1
	POL(I)=1.
	RR(I)=A
	RC(I)=0.
	IF(IER)39,39,41
39	IF(A-EPS)41,41,40
C
C	   WARNING DUE TO POOR ACCURACY OF CALCULATED COEFFICIENT VECTOR
40	IER=-1
41	RETURN
C
C	   ERROR EXIT DUE TO DEGENERATE POLYNOMIAL OR OVERFLOW IN
C	   NORMALIZATION
42	IER=2
	IR=0
	RETURN
	END
C
	FUNCTION PROB(NOPT,X,N1,N2)
C
C	THIS FUNCTION SUBPROGRAM COMPUTES THE PROBALITY CORRESPONDING
C	TO GIVEN VALUE OF A VARIANCE-RATIO, CHI-SQUARED, STUDENT'S,
C	OR STANDARDISED NORMAL DEVIATE, PARAMETERS ARE AS FOLLOWS:
C	NOPT= 1 FOR CHI-SQUARED (ONE-TAILED TEST)
C	      2 FOR STUDENT'S T(TWO-TAILED TEST)
C	      3	FOR STANDARDISED NORMAL DEVIATE (TWO-TAILED TEST)
C	      4 FOR VARIANCE RATIO (ONE-TAILED)
C	X=      NUMERICAL VALUE OF TEST-STATISTIC
C		SPECIFIED BY NOPT
C	N1=	DEGEES OF FREEDOM (FOR NUMERATOR IF NOPT=4
C		SPECIFY ZERO IF NOPT=3)
C	N2=	DEGREES OF FREEDOM FOR DENOMINATOR IF NOPT=4
C		OTHERWISE SPECIFY ZERO)
C	NOTE-FOR ACCURACY SEE GOLDEN, WEISS AND DAWIS (1968)
C	EDUC. PHYSIOL. MEASUREMENT, VOL. 28, PP. 163-165
C
C
	AN1=N1
	AN2=N2
C
C	CONVERT TEST STATISTIC TO VARIANCE RATIO IF NECESSARY.
C
	GO TO (1,2,3,4), NOPT
    1	F=X/AN1
	AN2=1.0E+10
	GO TO 5
    2	F=X*X
	AN1=1.0
	AN2=N1
	GO TO 5
    3	Z=ABS(X)
	F=10.0
	GO TO 7
    4	F=X
    5	FF=F
	PROB=1.0
	IF(AN1*AN2*F.EQ.0.0) RETURN
C
C	TAKE RECIPROCAL IF F LESS THEN 1.
C
	IF(F.GE.1.0) GO TO 6
	FF=1.0/F
	TEMP=AN1
	AN1=AN2
	AN2=TEMP
C
C	NORMALISE VARIANCE RATIO
C
    6	A1=2.0/AN1/9.0
	A2=2.0/AN2/9.0
	Z=ABS(((1.0-A2)*FF**0.333333-1.0+A1)/SQRT(A2*FF**
     1	0.666666+A1))
	IF(AN2.LE.3.0) Z=Z*(1.0+0.08*Z**4/AN2**3)
C
C	COMPUTE PROBABILITY
C
    7	FZ=EXP(-Z*Z/2.0)*0.3989423
	W=1.0/(1.0+Z*0.2316419)
	PROB=FZ*W*((((1.330274*W-1.821256)*W+
     1	1.781478)*W-0.3565638)*W+0.3193815)
	IF(NOPT.EQ.3) PROB=2.0*PROB
	IF(F.LT.1.0) PROB=1.0-PROB
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PROBT
C
C	   PURPOSE
C	      TO OBTAIN MAXIMUM LIKELIHOOD ESTIMATES FOR THE PARAMETERS A
C	      AND B IN THE PROBIT EQUATION  Y = A + BX.  AN ITERATIVE
C	      SCHEME IS USED.  THE INPUT TO THE SUBROUTINE CONSISTS OF K
C	      DIFFERENT DOSAGE LEVELS APPLIED TO K GROUPS OF SUBJECTS, AND
C	      THE NUMBER OF SUBJECTS IN EACH GROUP RESPONDING TO THE
C	      RESPECTIVE DOSAGE OF THE DRUG.
C
C	   USAGE
C	      CALL PROBT (K,X,S,R,LOG,ANS,W1,W2,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      K   - NUMBER OF DIFFERENT DOSE LEVELS OF THE DRUG.  K SHOULD
C	            BE GREATER THAN 2.
C	      X   - INPUT VECTOR OF LENGTH K CONTAINING THE DOSE LEVEL OF
C	            THE DRUG TESTED.  X MUST BE NON-NEGATIVE.
C	      S   - INPUT VECTOR OF LENGTH K CONTAINING THE NUMBER OF
C	            SUBJECTS TESTED AT EACH DOSE LEVEL
C	      R   - INPUT VECTOR OF LENGTH K CONTAINING THE NUMBER OF
C	            SUBJECTS AT EACH LEVEL RESPONDING TO THE DRUG
C	      LOG - INPUT OPTION CODE
C	            1- IF IT IS DESIRED TO CONVERT THE DOSE LEVELS TO
C	               COMMON LOGARITHMS.  THE DOSAGE LEVELS SHOULD BE
C	               NON-NULL IN THIS CASE.
C	            0- IF NO CONVERSION IS DESIRED
C	      ANS - OUTPUT VECTOR OF LENGTH 4 CONTAINING THE FOLLOWING
C	            RESULTS
C	            ANS(1)- ESTIMATE OF THE INTERCEPT CONSTANT A
C	            ANS(2)- ESTIMATE OF THE PROBIT REGRESSION COEFFICIENT
C	                    B
C	            ANS(3)- CHI-SQUARED VALUE FOR A TEST OF SIGNIFICANCE
C	                    OF THE FINAL PROBIT EQUATION
C	            ANS(4)- DEGREES OF FREEDOM FOR THE CHI-SQUARE
C	                    STATISTIC
C	      W1  - OUTPUT VECTOR OF LENGTH K CONTAINING THE PROPORTIONS
C	            OF SUBJECTS RESPONDING TO THE VARIOUS DOSE LEVELS OF
C	            THE DRUG
C	      W2  - OUTPUT VECTOR OF LENGTH K CONTAINING THE VALUES OF THE
C	            EXPECTED PROBIT FOR THE VARIOUS LEVELS OF A DRUG
C	      IER - 1 IF K IS NOT GREATER THAN 2.
C	            2 IF SOME DOSAGE LEVEL IS NEGATIVE, OR IF THE INPUT
C	              OPTION CODE LOG IS 1 AND SOME DOSAGE LEVEL IS ZERO.
C	            3 IF SOME ELEMENT OF S IS NOT POSITIVE.
C	            4 IF NUMBER OF SUBJECTS RESPONDING IS GREATER THAN
C	            NUMBER OF SUBJECTS TESTED.
C	            ONLY IF IER IS ZERO IS A PROBIT ANALYSIS PERFORMED.
C	            OTHERWISE, ANS, W1, AND W2 ARE SET TO ZERO.
C
C	   REMARKS
C	      THE PROGRAM WILL ITERATE ON THE PROBIT EQUATION UNTIL TWO
C	      SUCCESSIVE SOLUTIONS PRODUCE CHANGES OF LESS THAN 10**(-7).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NDTR
C	      NDTRI
C
C	   METHOD
C	      REFER TO D. J. FINNEY, PROBIT ANALYSIS. 2ND ED. (CAMBRIDGE,
C	      1952)
C
C	..................................................................
C
	SUBROUTINE PROBT (K,X,S,R,LOG,ANS,W1,W2,IER)
C
	DIMENSION X(1),S(1),R(1),ANS(1),W1(1),W2(1)
C
C	   TEST WHETHER LOG CONVERSION IS NEEDED
C
	IER=0
	IF(K-2)5,5,7
5	IER = 1
	GO TO 90
7	DO 8 I=1,K
	IF(X(I))12,8,8
8	CONTINUE
	IF(LOG-1) 16,10,16
10	DO 15 I=1,K
	IF(X(I))12,12,14
12	IER=2
	GO TO 90
14	X(I)= ALOG10(X(I))
15	CONTINUE
C
C	   COMPUTE PROPORTIONS OF OBJECTS RESPONDING
C
16	DO 18 I=1,K
	IF(S(I)-R(I)) 17,18,18
17	IER=4
	GO TO 90
18	CONTINUE
20	DO 23 I=1,K
	IF(S(I))21,21,22
21	IER=3
	GO TO 90
22	W1(I)=R(I)/S(I)
23	CONTINUE
C
C	   COMPUTE INITIAL ESTIMATES OF INTERCEPT AND PROBIT REGRESSION
C	   COEFFICIENT
C
	WN=0.0
	XBAR=0.0
	SNWY=0.0
	SXX=0.0
	SXY=0.0
C
	DO 30 I=1,K
	P=W1(I)
	IF(P) 30, 30, 24
24	IF(P-1.0) 25, 30, 30
25	WN=WN+1.0
C
	CALL NDTRI (P,Z,D,IER)
C
	Z=Z+5.0
	XBAR=XBAR+X(I)
	SNWY=SNWY+Z
	SXX=SXX+X(I)**2
	SXY=SXY+X(I)*Z
30	CONTINUE
C
	B=(SXY-(XBAR*SNWY)/WN)/(SXX-(XBAR*XBAR)/WN)
	XBAR=XBAR/WN
	SNWY=SNWY/WN
	A=SNWY-B*XBAR
	DD=0.0
C
C	   COMPUTE EXPECTED PROBIT
C
	DO 31 I=1,K
31	W2(I)=A+B*X(I)
C
33	SNW=0.0
	SNWX=0.0
	SNWY=0.0
	SNWXX=0.0
	SNWXY=0.0
	DO 50 I=1,K
	Y=W2(I)
C
C	   FIND A WEIGHTING COEFFICIENT FOR PROBIT ANALYSIS
C
	D=Y-5.0
C
	CALL NDTR (D,P,Z)
C
	Q=1.0-P
	W=(Z*Z)/(P*Q)
C
C	   COMPUTE WORKING PROBIT
C
	IF(Y-5.0) 35, 35, 40
35	WP=(Y-P/Z)+W1(I)/Z
	GO TO 45
40	WP=(Y+Q/Z)-(1.0-W1(I))/Z
C
C	   SUM INTERMEDIATE RESULTS
C
45	WN=W*S(I)
	SNW=SNW+WN
	SNWX=SNWX+WN*X(I)
	SNWY=SNWY+WN*WP
	SNWXX=SNWXX+WN*X(I)**2
50	SNWXY=SNWXY+WN*X(I)*WP
C
C	   COMPUTE NEW ESTIMATES OF INTERCEPT AND COEFFICIENT
C
	XBAR=SNWX/SNW
C
	SXX=SNWXX-(SNWX)*(SNWX)/SNW
	SXY=SNWXY-(SNWX)*(SNWY)/SNW
	B=SXY/SXX
C
	A=SNWY/SNW-B*XBAR
C
C	   EXAMINE THE CHANGES IN Y
C
	SXX=0.0
	DO 60 I=1,K
	Y=A+B*X(I)
	D=W2(I)-Y
	SXX=SXX+D*D
60	W2(I)=Y
	IF(( ABS(DD-SXX))-(1.0E-7)) 65, 65, 63
63	DD=SXX
	GO TO 33
C
C	   STORE INTERCEPT AND COEFFICIENT
C
65	ANS(1)=A
	ANS(2)=B
C
C	   COMPUTE CHI-SQUARE
C
	ANS(3)=0.0
	DO 70 I=1,K
	Y=W2(I)-5.0
C
	CALL NDTR (Y,P,D)
C
	AA=R(I)-S(I)*P
	DD=S(I)*P*(1.0-P)
70	ANS(3)=ANS(3)+AA*AA/DD
C
C	   DEGREES OF FREEDOM FOR CHI-SQUARE
C
	ANS(4)=K-2
C
80	RETURN
90	DO 100 I=1,K
	W1(I)=0.0
100	W2(I)=0.0
	DO 110 I=1,4
110	ANS(I)=0.0
	GO TO 80
	END
C
C	..................................................................
C
C	   SUBROUTINE PRQD
C
C	   PURPOSE
C	      CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN POLYNOMIAL
C	      WITH REAL COEFFICIENTS.
C
C	   USAGE
C	      CALL PRQD(C,IC,Q,E,POL,IR,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      C     - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              THE GIVEN COEFFICIENT VECTOR GETS DIVIDED BY THE
C	              LAST NONZERO TERM
C	      IC    - DIMENSION OF VECTOR C
C	      Q     - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN Q CONTAINS REAL PARTS OF ROOTS
C	      E     - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN E CONTAINS COMPLEX PARTS OF ROOTS
C	      POL   - WORKING STORAGE OF DIMENSION IC
C	              ON RETURN POL CONTAINS THE COEFFICIENTS OF THE
C	              POLYNOMIAL WITH CALCULATED ROOTS
C	              THIS RESULTING COEFFICIENT VECTOR HAS DIMENSION IR+1
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      IR    - NUMBER OF CALCULATED ROOTS
C	              NORMALLY IR IS EQUAL TO DIMENSION IC MINUS ONE
C	      IER   - RESULTING ERROR PARAMETER. SEE REMARKS
C
C	   REMARKS
C	      THE REAL PART OF THE ROOTS IS STORED IN Q(1) UP TO Q(IR)
C	      CORRESPONDING COMPLEX PARTS ARE STORED IN E(1) UP TO E(IR).
C	      IER = 0 MEANS NO ERRORS
C	      IER = 1 MEANS NO CONVERGENCE WITH FEASIBLE TOLERANCE
C	      IER = 2 MEANS POLYNOMIAL IS DEGENERATE (CONSTANT OR ZERO)
C	      IER = 3 MEANS SUBROUTINE WAS ABANDONED DUE TO ZERO DIVISOR
C	      IER = 4 MEANS THERE EXISTS NO S-FRACTION
C	      IER =-1 MEANS CALCULATED COEFFICIENT VECTOR REVEALS POOR
C	              ACCURACY OF THE CALCULATED ROOTS.
C	              THE CALCULATED COEFFICIENT VECTOR HAS LESS THAN
C	              3 CORRECT DIGITS.
C	      THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED
C	      COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE BEEN
C	      CALCULATED.
C	      THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT VECTOR IS
C	      RECORDED IN Q(IR+1).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF
C	      THE QUOTIENT-DIFFERENCE ALGORITHM WITH DISPLACEMENT.
C	      REFERENCE
C	      H.RUTISHAUSER, DER QUOTIENTEN-DIFFERENZEN-ALGORITHMUS,
C	      BIRKHAEUSER, BASEL/STUTTGART, 1957.
C
C	..................................................................
C
c	SUBROUTINE PRQD(C,IC,Q,E,POL,IR,IER)
cC
cC	 DIMENSIONED DUMMY VARIABLES
c	DIMENSION E(1),Q(1),C(1),POL(1)
cC
C	   NORMALIZATION OF GIVEN POLYNOM
      SUBROUTINE PRQD(C,IC,Q,E,POL,IR,IER)
      DIMENSION E(1),Q(1),C(1),POL(1)
      IER=0
      IR=IC
      EPS=1.E-6
      TOL=1.E-3
      LIMIT=10*IC
      KOUNT=0
    1 IF(IR-1)79,79,2
    2 IF(C(IR))4,3,4
    3 IR=IR-1
      GOTO 1
    4 O=1./C(IR)
      IEND=IR-1
      ISTA=1
      NSAV=IR+1
      JBEG=1
      DO 9 I=1,IR
      J=NSAV-I
      IF(C(I))7,5,7
    5 GOTO(6,8),JBEG
    6 NSAV=NSAV+1
      Q(ISTA)=0.
      E(ISTA)=0.
      ISTA=ISTA+1
      GOTO 9
    7 JBEG=2
    8 Q(J)=C(I)*O
      C(I)=Q(J)
    9 CONTINUE
      ESAV=0.
      Q(ISTA)=0.
   10 NSAV=IR
      EXPT=IR-ISTA
      E(ISTA)=EXPT
      DO 11 I=ISTA,IEND
      EXPT=EXPT-1.0
      POL(I+1)=EPS*ABS(Q(I+1))+EPS
   11 E(I+1)=Q(I+1)*EXPT
      IF(ISTA-IEND)12,20,60
   12 JEND=IEND-1
      DO 19 I=ISTA,JEND
      IF(I-ISTA)13,16,13
   13 IF(ABS(E(I))-POL(I+1))14,14,16
   14 NSAV=I
      DO 15 K=I,JEND
      IF(ABS(E(K))-POL(K+1))15,15,80
   15 CONTINUE
      GOTO 21
   16 DO 19 K=I,IEND
      E(K+1)=E(K+1)/E(I)
      Q(K+1)=E(K+1)-Q(K+1)
      IF(K-I)18,17,18
   17 IF(ABS(Q(I+1))-POL(I+1))80,80,19
   18 Q(K+1)=Q(K+1)/Q(I+1)
      POL(K+1)=POL(K+1)/ABS(Q(I+1))
      E(K)=Q(K+1)-E(K)
   19 CONTINUE
   20 Q(IR)=-Q(IR)
   21 E(ISTA)=0.
      NRAN=NSAV-1
   22 E(NRAN+1)=0.
      IF(NRAN-ISTA)24,23,31
   23 Q(ISTA+1)=Q(ISTA+1)+EXPT
      E(ISTA+1)=0.
   24 E(ISTA)=ESAV
      IF(IR-NSAV)60,60,25
   25 ISTA=NSAV
      ESAV=E(ISTA)
      GOTO 10
   26 P=P+EXPT
      IF(O)27,28,28
   27 Q(NRAN)=P
      Q(NRAN+1)=P
      E(NRAN)=T
      E(NRAN+1)=-T
      GOTO 29
   28 Q(NRAN)=P-T
      Q(NRAN+1)=P+T
      E(NRAN)=0.
   29 NRAN=NRAN-2
      GOTO 22
   30 Q(NRAN+1)=EXPT+P
      NRAN=NRAN-1
      GOTO 22
   31 JBEG=ISTA+1
      JEND=NRAN-1
      TEPS=EPS
      TDELT=1.E-2
   32 KOUNT=KOUNT+1
      P=Q(NRAN+1)
      R=ABS(E(NRAN))
      IF(R-TEPS)30,30,33
   33 S=ABS(E(JEND))
      IF(S-R)38,38,34
   34 IF(R-TDELT)36,35,35
   35 P=0.
   36 O=P
      DO 37 J=JBEG,NRAN
      Q(J)=Q(J)+E(J)-E(J-1)-O
      IF(ABS(Q(J))-POL(J))81,81,37
   37 E(J)=Q(J+1)*E(J)/Q(J)
      Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O
      GOTO 54
   38 P=0.5*(Q(NRAN)+E(NRAN)+Q(NRAN+1))
      O=P*P-Q(NRAN)*Q(NRAN+1)
      T=SQRT(ABS(O))
      IF(S-TEPS)26,26,39
   39 IF(O)43,40,40
   40 IF(P)42,41,41
   41 T=-T
   42 P=P+T
      R=S
      GOTO 34
   43 IF(S-TDELT)44,35,35
   44 O=Q(JBEG)+E(JBEG)-P
      IF(ABS(O)-POL(JBEG))81,81,45
   45 T=(T/O)**2
      U=E(JBEG)*Q(JBEG+1)/(O*(1.+T))
      V=O+U
      KOUNT=KOUNT+2
      DO 53 J=JBEG,NRAN
      O=Q(J+1)+E(J+1)-U-P
      IF(ABS(V)-POL(J))46,46,49
   46 IF(J-NRAN)81,47,81
   47 EXPT=EXPT+P
      IF(ABS(E(JEND))-TOL)48,48,81
   48 P=0.5*(V+O-E(JEND))
      O=P*P-(V-U)*(O-U*T-O*W*(1.+T)/Q(JEND))
      T=SQRT(ABS(O))
      GOTO 26
   49 IF(ABS(O)-POL(J+1))46,46,50
   50 W=U*O/V
      T=T*(V/O)**2
      Q(J)=V+W-E(J-1)
      U=0.
      IF(J-NRAN)51,52,52
   51 U=Q(J+2)*E(J+1)/(O*(1.+T))
   52 V=O+U-W
      IF(ABS(Q(J))-POL(J))81,81,53
   53 E(J)=W*V*(1.+T)/Q(J)
      Q(NRAN+1)=V-E(NRAN)
   54 EXPT=EXPT+P
      TEPS=TEPS*1.1
      TDELT=TDELT*1.1
      IF(KOUNT-LIMIT)32,55,55
   55 IER=1
   56 IEND=NSAV-NRAN-1
      E(ISTA)=ESAV
      IF(IEND)59,59,57
   57 DO 58 I=1,IEND
      J=ISTA+I
      K=NRAN+1+I
      E(J)=E(K)
   58 Q(J)=Q(K)
   59 IR=ISTA+IEND
   60 IR=IR-1
      IF(IR)78,78,61
   61 DO 62 I=1,IR
      Q(I)=Q(I+1)
   62 E(I)=E(I+1)
      POL(IR+1)=1.
      IEND=IR-1
      JBEG=1
      DO 69 J=1,IR
      ISTA=IR+1-J
      O=0.
      P=Q(ISTA)
      T=E(ISTA)
      IF(T)65,63,65
   63 DO 64 I=ISTA,IR
      POL(I)=O-P*POL(I+1)
   64 O=POL(I+1)
      GOTO 69
   65 GOTO(66,67),JBEG
   66 JBEG=2
      POL(ISTA)=0.
      GOTO 69
   67 JBEG=1
      U=P*P+T*T
      P=P+P
      DO 68 I=ISTA,IEND
      POL(I)=O-P*POL(I+1)+U*POL(I+2)
   68 O=POL(I+1)
      POL(IR)=O-P
   69 CONTINUE
      IF(IER)78,70,78
   70 P=0.
      DO 75 I=1,IR
      IF(C(I))72,71,72
   71 O=ABS(POL(I))
      GOTO 73
   72 O=ABS((POL(I)-C(I))/C(I))
   73 IF(P-O)74,75,75
   74 P=O
   75 CONTINUE
      IF(P-TOL)77,76,76
   76 IER=-1
   77 Q(IR+1)=P
      E(IR+1)=0.
   78 RETURN
   79 IER=2
      IR=0
      RETURN
   80 IER=4
      IR=ISTA
      GOTO 60
   81 IER=3
      GOTO 56
      END
C
C	..................................................................
C
C	   SUBROUTINE PSUB
C
C	   PURPOSE
C	      SUBTRACT ONE POLYNOMIAL FROM ANOTHER
C
C	   USAGE
C	      CALL PSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY)
C
C	   DESCRIPTION OF PARAMETERS
C	      Z     - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM
C	              SMALLEST TO LARGEST POWER
C	      IDIMZ - DIMENSION OF Z (CALCULATED)
C	      X     - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED
C	              FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1)
C	      Y     - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1)
C
C	   REMARKS
C	      VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR
C	      VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS
C	      THAN THE OTHER INPUT VECTOR
C	      THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE
C	      LARGER OF THE TWO INPUT VECTOR DIMENSIONS. COEFFICIENTS IN
C	      VECTOR Y ARE THEN SUBTRACTED FROM CORRESPONDING COEFFICIENTS
C	      IN VECTOR X.
C
C	..................................................................
C
	SUBROUTINE PSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY)
	DIMENSION Z(1),X(1),Y(1)
C
C	TEST DIMENSIONS OF SUMMANDS
C
	NDIM=IDIMX
	IF (IDIMX-IDIMY) 10,20,20
10	NDIM=IDIMY
20	IF (NDIM) 90,90,30
30	DO 80 I=1,NDIM
	IF (I-IDIMX) 40,40,60
40	IF (I-IDIMY) 50,50,70
50	Z(I)=X(I)-Y(I)
	GO TO 80
60	Z(I)=-Y(I)
	GO TO 80
70	Z(I)=X(I)
80	CONTINUE
90	IDIMZ=NDIM
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE PVAL
C
C	   PURPOSE
C	      EVALUATE A POLYNOMIAL FOR A GIVEN VALUE OF THE VARIABLE
C
C	   USAGE
C	      CALL PVAL(RES,ARG,X,IDIMX)
C
C	   DESCRIPTION OF PARAMETERS
C	      RES    - RESULTANT VALUE OF POLYNOMIAL
C	      ARG    - GIVEN VALUE OF THE VARIABLE
C	      X      - VECTOR OF COEFFICIENTS, ORDERED FROM SMALLEST TO
C	               LARGEST POWER
C	      IDIMX  - DIMENSION OF X
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF NESTED MULTIPLICATION
C
C	..................................................................
C
	SUBROUTINE PVAL(RES,ARG,X,IDIMX)
	DIMENSION X(1)
C
	RES=0.
	J=IDIMX
1	IF(J)3,3,2
2	RES=RES*ARG+X(J)
	J=J-1
	GO TO 1
3	RETURN
	END
	FUNCTION PVALUE(GIJ,M,N)
	PVALUE=1
	G=ABS(GIJ)
	IF(G.LE.0)GOTO 999
	IF(M.GT.0)GOTO 10
	G=G*G
	M=1
10	P=1.
	IF(G.LT.1.)GOTO 20
	IA=M
	IB=N
	F=G
	GOTO 30
20	IA=N
	IB=M
	F=1./G
30	B=IB
	A1=2./(9.*IA)
	B1=2./(9.*IB)
	Z=ABS((1.-B1)*F**0.333333-1.+A1)
	Z=Z/SQRT(B1*F**0.666667+A1)
	IF(IB.LT.4.) Z=Z*(1.+0.08*Z**4/B**3)
	P=(1.+Z*(0.196854+Z*(0.115194+Z*(0.000344+Z*0.019527))))**4
	P=0.5/P
	IF(G.LT.1.)P=1.-P
	PVALUE=AINT(100000.*P)/100000.
999	RETURN
	END
C
C
C	..................................................................
C
C	   SUBROUTINE PVSUB
C
C	   PURPOSE
C	      SUBSTITUTE VARIABLE OF A POLYNOMIAL BY ANOTHER POLYNOMIAL
C
C	   USAGE
C	      CALL PVSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY,WORK1,WORK2)
C
C	   DESCRIPTION OF PARAMETERS
C	      Z     - VECTOR OF COEFFICIENTS FOR RESULTANT POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMZ - DIMENSION OF Z
C	      X     - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL,
C	              ORDERED FROM SMALLEST TO LARGEST POWER
C	      IDIMX - DIMENSION OF X
C	      Y     - VECTOR OF COEFFICIENTS FOR POLYNOMIAL WHICH IS
C	              SUBSTITUTED FOR VARIABLE, ORDERED FROM SMALLEST TO
C	              LARGEST POWER
C	      IDIMY - DIMENSION OF Y
C	      WORK1 - WORKING STORAGE ARRAY (SAME DIMENSION AS Z)
C	      WORK2 - WORKING STORAGE ARRAY (SAME DIMENSION AS Z)
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      PMPY
C	      PADDM
C	      PCLA
C
C	   METHOD
C	      VARIABLE OF POLYNOMIAL X IS SUBSTITUTED BY POLYNOMIAL Y
C	      TO FORM POLYNOMIAL Z. DIMENSION OF NEW POLYNOMIAL IS
C	      (IDIMX-1)*(IDIMY-1)+1. SUBROUTINE REQUIRES TWO WORK AREAS
C
C	..................................................................
C
	SUBROUTINE PVSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY,WORK1,WORK2)
	DIMENSION Z(1),X(1),Y(1),WORK1(1),WORK2(1)
C
C	TEST OF DIMENSIONS
C
	IF (IDIMX-1) 1,3,3
1	IDIMZ=0
2	RETURN
C
3	IDIMZ=1
	Z(1)=X(1)
	IF (IDIMY*IDIMX-IDIMY) 2,2,4
4	IW1=1
	WORK1(1)=1.
C
	DO 5 I=2,IDIMX
	CALL PMPY(WORK2,IW2,Y,IDIMY,WORK1,IW1)
	CALL PCLA(WORK1,IW1,WORK2,IW2)
	FACT=X(I)
	CALL PADDM(Z,IDIMR,Z,IDIMZ,FACT,WORK1,IW1)
	IDIMZ=IDIMR
5	CONTINUE
	GO TO 2
	END
C
C	..................................................................
C
C	   SUBROUTINE QA10
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA10 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 10-POINT GENERALIZED GAUSS-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 19.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA10(FCT,Y)
C
C
	X=29.02495
	Y=.4458787E-12*FCT(X)
	X=21.19389
	Y=Y+.8798682E-9*FCT(X)
	X=15.56116
	Y=Y+.2172139E-6*FCT(X)
	X=11.20813
	Y=Y+.1560511E-4*FCT(X)
	X=7.777439
	Y=Y+.0004566773*FCT(X)
	X=5.084908
	Y=Y+.006487547*FCT(X)
	X=3.022513
	Y=Y+.04962104*FCT(X)
	X=1.522944
	Y=Y+.2180344*FCT(X)
	X=.5438675
	Y=Y+.5733510*FCT(X)
	X=.06019206
	Y=Y+.9244873*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA2
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA2 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 2-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 3.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA2(FCT,Y)
C
C
	X=2.724745
	Y=.1626257*FCT(X)
	X=.2752551
	Y=Y+1.609828*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA3
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA3 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 3-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 5.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA3(FCT,Y)
C
C
	X=5.525344
	Y=.009060020*FCT(X)
	X=1.784493
	Y=Y+.3141346*FCT(X)
	X=.1901635
	Y=Y+1.449259*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA4 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA4(FCT,Y)
C
C
	X=8.588636
	Y=.0003992081*FCT(X)
	X=3.926964
	Y=Y+.03415597*FCT(X)
	X=1.339097
	Y=Y+.4156047*FCT(X)
	X=.1453035
	Y=Y+1.322294*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA5
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA5 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 5-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 9.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA5(FCT,Y)
C
C
	X=11.80719
	Y=.1528087E-4*FCT(X)
	X=6.414730
	Y=Y+.002687291*FCT(X)
	X=3.085937
	Y=Y+.06774879*FCT(X)
	X=1.074562
	Y=Y+.4802772*FCT(X)
	X=.1175813
	Y=Y+1.221725*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA6
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA6 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 6-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 11.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA6(FCT,Y)
C
C
	X=15.12996
	Y=.5317103E-6*FCT(X)
	X=9.124248
	Y=Y+.0001714737*FCT(X)
	X=5.196153
	Y=Y+.007810781*FCT(X)
	X=2.552590
	Y=Y+.1032160*FCT(X)
	X=.8983028
	Y=Y+.5209846*FCT(X)
	X=.09874701
	Y=Y+1.140270*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA7
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA7 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 7-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 13.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA7(FCT,Y)
C
C
	X=18.52828
	Y=.1725718E-7*FCT(X)
	X=11.98999
	Y=Y+.9432969E-5*FCT(X)
	X=7.554091
	Y=Y+.0007101852*FCT(X)
	X=4.389793
	Y=Y+.01570011*FCT(X)
	X=2.180592
	Y=Y+.1370111*FCT(X)
	X=.7721379
	Y=Y+.5462112*FCT(X)
	X=.08511544
	Y=Y+1.072812*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA8 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA8(FCT,Y)
C
C
	X=21.98427
	Y=.5309615E-9*FCT(X)
	X=14.97262
	Y=Y+.4641962E-6*FCT(X)
	X=10.09332
	Y=Y+.5423720E-4*FCT(X)
	X=6.483145
	Y=Y+.001864568*FCT(X)
	X=3.809476
	Y=Y+.02576062*FCT(X)
	X=1.905114
	Y=Y+.1676201*FCT(X)
	X=.6772491
	Y=Y+.5612949*FCT(X)
	X=.07479188
	Y=Y+1.015859*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QA9
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X
C	                          FROM 0 TO INFINITY).
C
C	   USAGE
C	      CALL QA9 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 9-POINT GENERALIZED GAUSSIAN-
C	      LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY,
C	      WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 17.
C	      FOR REFERENCE, SEE
C	      CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF
C	      INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO
C	      INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17,
C	      ISS.83 (1963), PP.245-256.
C
C	..................................................................
C
	SUBROUTINE QA9(FCT,Y)
C
C
	X=25.48598
	Y=.1565640E-10*FCT(X)
	X=18.04651
	Y=Y+.2093441E-7*FCT(X)
	X=12.77183
	Y=Y+.3621309E-5*FCT(X)
	X=8.769757
	Y=Y+.0001836225*FCT(X)
	X=5.694423
	Y=Y+.003777045*FCT(X)
	X=3.369176
	Y=Y+.03728008*FCT(X)
	X=1.692395
	Y=Y+.1946035*FCT(X)
	X=.6032364
	Y=Y+.5696146*FCT(X)
	X=.06670223
	Y=Y+.9669914*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QATR
C
C	   PURPOSE
C	      TO COMPUTE AN APPROXIMATION FOR INTEGRAL(FCT(X), SUMMED
C	      OVER X FROM XL TO XU).
C
C	   USAGE
C	      CALL QATR (XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      EPS    - THE UPPER BOUND OF THE ABSOLUTE ERROR.
C	      NDIM   - THE DIMENSION OF THE AUXILIARY STORAGE ARRAY AUX.
C	               NDIM-1 IS THE MAXIMAL NUMBER OF BISECTIONS OF
C	               THE INTERVAL (XL,XU).
C	      FCT    - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING APPROXIMATION FOR THE INTEGRAL VALUE.
C	      IER    - A RESULTING ERROR PARAMETER.
C	      AUX    - AN AUXILIARY STORAGE ARRAY WITH DIMENSION NDIM.
C
C	   REMARKS
C	      ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM
C	      IER=0  - IT WAS POSSIBLE TO REACH THE REQUIRED ACCURACY.
C	               NO ERROR.
C	      IER=1  - IT IS IMPOSSIBLE TO REACH THE REQUIRED ACCURACY
C	               BECAUSE OF ROUNDING ERRORS.
C	      IER=2  - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE NDIM
C	               IS LESS THAN 5, OR THE REQUIRED ACCURACY COULD NOT
C	               BE REACHED WITHIN NDIM-1 STEPS. NDIM SHOULD BE
C	               INCREASED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE CODED BY
C	      THE USER. ITS ARGUMENT X SHOULD NOT BE DESTROYED.
C
C	   METHOD
C	      EVALUATION OF Y IS DONE BY MEANS OF TRAPEZOIDAL RULE IN
C	      CONNECTION WITH ROMBERGS PRINCIPLE. ON RETURN Y CONTAINS
C	      THE BEST POSSIBLE APPROXIMATION OF THE INTEGRAL VALUE AND
C	      VECTOR AUX THE UPWARD DIAGONAL OF ROMBERG SCHEME.
C	      COMPONENTS AUX(I) (I=1,2,...,IEND, WITH IEND LESS THAN OR
C	      EQUAL TO NDIM) BECOME APPROXIMATIONS TO INTEGRAL VALUE WITH
C	      DECREASING ACCURACY BY MULTIPLICATION WITH (XU-XL).
C	      FOR REFERENCE, SEE
C	      (1) FILIPPI, DAS VERFAHREN VON ROMBERG-STIEFEL-BAUER ALS
C	          SPEZIALFALL DES ALLGEMEINEN PRINZIPS VON RICHARDSON,
C	          MATHEMATIK-TECHNIK-WIRTSCHAFT, VOL.11, ISS.2 (1964),
C	          PP.49-54.
C	      (2) BAUER, ALGORITHM 60, CACM, VOL.4, ISS.6 (1961), PP.255.
C
C	..................................................................
C
	SUBROUTINE QATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX)
C
C
	DIMENSION AUX(1)
C
C	PREPARATIONS OF ROMBERG-LOOP
	AUX(1)=.5*(FCT(XL)+FCT(XU))
	H=XU-XL
	IF(NDIM-1)8,8,1
1	IF(H)2,10,2
C
C	NDIM IS GREATER THAN 1 AND H IS NOT EQUAL TO 0.
2	HH=H
	E=EPS/ABS(H)
	DELT2=0.
	P=1.
	JJ=1
	DO 7 I=2,NDIM
	Y=AUX(1)
	DELT1=DELT2
	HD=HH
	HH=.5*HH
	P=.5*P
	X=XL+HH
	SM=0.
	DO 3 J=1,JJ
	SM=SM+FCT(X)
3	X=X+HD
	AUX(I)=.5*AUX(I-1)+P*SM
C	A NEW APPROXIMATION OF INTEGRAL VALUE IS COMPUTED BY MEANS OF
C	TRAPEZOIDAL RULE.
C
C	START OF ROMBERGS EXTRAPOLATION METHOD.
	Q=1.
	JI=I-1
	DO 4 J=1,JI
	II=I-J
	Q=Q+Q
	Q=Q+Q
4	AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.)
C	END OF ROMBERG-STEP
C
	DELT2=ABS(Y-AUX(1))
	IF(I-5)7,5,5
5	IF(DELT2-E)10,10,6
6	IF(DELT2-DELT1)7,11,11
7	JJ=JJ+JJ
8	IER=2
9	Y=H*AUX(1)
	RETURN
10	IER=0
	GO TO 9
11	IER=1
	Y=H*Y
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE PROGRAM FOR INTEGRATION OF A TABULATED FUNCTION BY
C	   NUMERICAL QUADRATURE - QDINT
C
C	   PURPOSE
C	      INTEGRATES A SET OF TABULATED VALUES FOR F(X) GIVEN THE
C	      NUMBER OF VALUES AND THEIR SPACING
C
C	   REMARKS
C	      THE NUMBER OF VALUES MUST BE MORE THAN TWO AND THE SPACING
C	      GREATER THAN ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      QSF
C
C	   METHOD
C	      READS CONTROL CARD CONTAINING THE CODE NUMBER, NUMBER OF
C	      VALUES, AND THE SPACING OF THE FUNCTION VALUES CONTAINED
C	      ON THE FOLLOWING DATA CARDS. DATA CARDS ARE THEN READ AND
C	      INTEGRATION IS PERFORMED. MORE THAN ONE CONTROL CARD AND
C	      CORRESPONDING DATA CAN BE INTEGRATED IN ONE RUN. EXECUTION
C	      IS TERMINATED BY A BLANK CONTROL CARD.
C
C	..................................................................
C
C	   THE FOLLOWING DIMENSION MUST BE AS LARGE AS THE MAXIMUM NUMBER
C	   OF TABULATED VALUES TO BE INTEGRATED
C
	DIMENSION Z(500)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION Z,SPACE
C
C	   ...............................................................
C
10	FORMAT (2I5,F10.0)
20	FORMAT(1H1,62HINTEGRATION OF TABULATED VALUES FOR DY/DX USING SUBR
     1OUTINE QSF//1H ,10HFUNCTION  ,I5,3X,I5,17H TABULATED VALUES,
     25X,10HINTERVAL =,E15.8//)
22	FORMAT(1H ,17HILLEGAL CONDITION/)
23	FORMAT(1H ,45HNUMBER OF TABULATED VALUES IS LESS THAN THREE)
30	FORMAT(1H ,7X,'RESULTANT VALUE OF INTEGRAL AT EACH STEP IS ',/
     1(1H ,6E15.8))
32	FORMAT(7F10.0)
C	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
C	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
C
35	READ(5,10)ICOD,NUMBR,SPACE
	IF(ICOD+NUMBR)70,70,38
38	WRITE(6,20)ICOD,NUMBR,SPACE
50	READ(5,32)(Z(I),I=1,NUMBR)
	IF(NUMBR-3)100,55,55
55	CALL QSF(SPACE,Z,Z,NUMBR)
60	WRITE(6,30)(Z(I),I=1,NUMBR)
	GO TO 35
   70	STOP
100	WRITE(6,22)
	WRITE (6,23)
	GO TO 35
200	WRITE(6,22)
	GO TO 35
	END
C
C	..................................................................
C
C	   SUBROUTINE QG10
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG10(XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 10-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 19
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG10(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4869533*B
	Y=.03333567*(FCT(A+C)+FCT(A-C))
	C=.4325317*B
	Y=Y+.07472567*(FCT(A+C)+FCT(A-C))
	C=.3397048*B
	Y=Y+.1095432*(FCT(A+C)+FCT(A-C))
	C=.2166977*B
	Y=Y+.1346334*(FCT(A+C)+FCT(A-C))
	C=.07443717*B
	Y=B*(Y+.1477621*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG2
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG2 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 2-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 3
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG2(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	Y=.2886751*B
	Y=.5*B*(FCT(A+Y)+FCT(A-Y))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG3
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG3 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 3-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 5
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG3(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	Y=.3872983*B
	Y=.2777778*(FCT(A+Y)+FCT(A-Y))
	Y=B*(Y+.4444444*FCT(A))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG4 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 7
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG4(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4305682*B
	Y=.1739274*(FCT(A+C)+FCT(A-C))
	C=.1699905*B
	Y=B*(Y+.3260726*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG5
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG5 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 5-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 9
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG5(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4530899*B
	Y=.1184634*(FCT(A+C)+FCT(A-C))
	C=.2692347*B
	Y=Y+.2393143*(FCT(A+C)+FCT(A-C))
	Y=B*(Y+.2844444*FCT(A))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG6
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG6 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 6-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 11
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG6(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4662348*B
	Y=.08566225*(FCT(A+C)+FCT(A-C))
	C=.3306047*B
	Y=Y+.1803808*(FCT(A+C)+FCT(A-C))
	C=.1193096*B
	Y=B*(Y+.2339570*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG7
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG7 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 7-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 13
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG7(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4745540*B
	Y=.06474248*(FCT(A+C)+FCT(A-C))
	C=.3707656*B
	Y=Y+.1398527*(FCT(A+C)+FCT(A-C))
	C=.2029226*B
	Y=Y+.1909150*(FCT(A+C)+FCT(A-C))
	Y=B*(Y+.2089796*FCT(A))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG8 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 15
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG8(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4801449*B
	Y=.05061427*(FCT(A+C)+FCT(A-C))
	C=.3983332*B
	Y=Y+.1111905*(FCT(A+C)+FCT(A-C))
	C=.2627662*B
	Y=Y+.1568533*(FCT(A+C)+FCT(A-C))
	C=.09171732*B
	Y=B*(Y+.1813419*(FCT(A+C)+FCT(A-C)))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QG9
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU)
C
C	   USAGE
C	      CALL QG9 (XL,XU,FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      XL     - THE LOWER BOUND OF THE INTERVAL.
C	      XU     - THE UPPER BOUND OF THE INTERVAL.
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 9-POINT GAUSS QUADRATURE
C	      FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 17
C	      EXACTLY.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338.
C
C	..................................................................
C
	SUBROUTINE QG9(XL,XU,FCT,Y)
C
C
	A=.5*(XU+XL)
	B=XU-XL
	C=.4840801*B
	Y=.04063719*(FCT(A+C)+FCT(A-C))
	C=.4180156*B
	Y=Y+.09032408*(FCT(A+C)+FCT(A-C))
	C=.3066857*B
	Y=Y+.1303053*(FCT(A+C)+FCT(A-C))
	C=.1621267*B
	Y=Y+.1561735*(FCT(A+C)+FCT(A-C))
	Y=B*(Y+.1651197*FCT(A))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH10
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH10(FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 10-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 19.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH10(FCT,Y)
C
C
	X=3.436159
	Z=-X
	Y=.7640433E-5*(FCT(X)+FCT(Z))
	X=2.532732
	Z=-X
	Y=Y+.001343646*(FCT(X)+FCT(Z))
	X=1.756684
	Z=-X
	Y=Y+.03387439*(FCT(X)+FCT(Z))
	X=1.036611
	Z=-X
	Y=Y+.2401386*(FCT(X)+FCT(Z))
	X=.3429013
	Z=-X
	Y=Y+.6108626*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH2
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH2 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 2-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 3.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH2(FCT,Y)
C
C
	X=.7071068
	Z=-X
	Y=.8862269*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH3
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH3 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 3-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 5.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH3(FCT,Y)
C
C
	X=1.224745
	Z=-X
	Y=.2954090*(FCT(X)+FCT(Z))
	X=0.
	Y=Y+1.181636*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH4 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH4(FCT,Y)
C
C
	X=1.650680
	Z=-X
	Y=.08131284*(FCT(X)+FCT(Z))
	X=.5246476
	Z=-X
	Y=Y+.8049141*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH5
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH5 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 5-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 9.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH5(FCT,Y)
C
C
	X=2.020183
	Z=-X
	Y=.01995324*(FCT(X)+FCT(Z))
	X=.9585725
	Z=-X
	Y=Y+.3936193*(FCT(X)+FCT(Z))
	X=0.
	Y=Y+.9453087*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH6
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH6 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 6-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 11.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH6(FCT,Y)
C
C
	X=2.350605
	Z=-X
	Y=.004530010*(FCT(X)+FCT(Z))
	X=1.335849
	Z=-X
	Y=Y+.1570673*(FCT(X)+FCT(Z))
	X=.4360774
	Z=-X
	Y=Y+.7246296*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH7
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH7 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 7-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 13.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH7(FCT,Y)
C
C
	X=2.651961
	Z=-X
	Y=.0009717812*(FCT(X)+FCT(Z))
	X=1.673552
	Z=-X
	Y=Y+.05451558*(FCT(X)+FCT(Z))
	X=.8162879
	Z=-X
	Y=Y+.4256073*(FCT(X)+FCT(Z))
	X=0.
	Y=Y+.8102646*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH8
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH8 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 15.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH8(FCT,Y)
C
C
	X=2.930637
	Z=-X
	Y=.0001996041*(FCT(X)+FCT(Z))
	X=1.981657
	Z=-X
	Y=Y+.01707798*(FCT(X)+FCT(Z))
	X=1.157194
	Z=-X
	Y=Y+.2078023*(FCT(X)+FCT(Z))
	X=.3811870
	Z=-X
	Y=Y+.6611470*(FCT(X)+FCT(Z))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QH9
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM
C	                          -INFINITY TO +INFINITY).
C
C	   USAGE
C	      CALL QH9 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 9-POINT GAUSSIAN-HERMITE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 17.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346.
C
C	..................................................................
C
	SUBROUTINE QH9(FCT,Y)
C
C
	X=3.190993
	Z=-X
	Y=.3960698E-4*(FCT(X)+FCT(Z))
	X=2.266581
	Z=-X
	Y=Y+.004943624*(FCT(X)+FCT(Z))
	X=1.468553
	Z=-X
	Y=Y+.08847453*(FCT(X)+FCT(Z))
	X=.7235510
	Z=-X
	Y=Y+.4326516*(FCT(X)+FCT(Z))
	X=0.
	Y=Y+.7202352*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QHFE
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION AND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL QHFE (H,Y,DERY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - THE INCREMENT OF ARGUMENT VALUES.
C	      Y      - THE INPUT VECTOR OF FUNCTION VALUES.
C	      DERY   - THE INPUT VECTOR OF DERIVATIVE VALUES.
C	      Z      - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE
C	               IDENTICAL WITH Y OR DERY.
C	      NDIM   - THE DIMENSION OF VECTORS Y,DERY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
C	      (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-230.
C
C	..................................................................
C
	SUBROUTINE QHFE(H,Y,DERY,Z,NDIM)
C
C
	DIMENSION Y(1),DERY(1),Z(1)
C
	SUM2=0.
	IF(NDIM-1)4,3,1
1	HH=.5*H
	HS=.1666667*H
C
C	INTEGRATION LOOP
	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I)))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QHFG
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      GENERAL TABLE OF ARGUMENT, FUNCTION, AND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL QHFG (X,Y,DERY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE INPUT VECTOR OF ARGUMENT VALUES.
C	      Y      - THE INPUT VECTOR OF FUNCTION VALUES.
C	      DERY   - THE INPUT VECTOR OF DERIVATIVE VALUES.
C	      Z      - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE
C	               IDENTICAL WITH X,Y OR DERY.
C	      NDIM   - THE DIMENSION OF VECTORS X,Y,DERY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	          MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319.
C	      (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	          PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	          PP.227-230.
C
C	..................................................................
C
	SUBROUTINE QHFG(X,Y,DERY,Z,NDIM)
C
C
	DIMENSION X(1),Y(1),DERY(1),Z(1)
C
	SUM2=0.
	IF(NDIM-1)4,3,1
C
C	INTEGRATION LOOP
1	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=.5*(X(I)-X(I-1))
	SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.3333333*SUM2*(DERY(I-1)-DERY(I)))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QHSE
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      EQUIDISTANT TABLE OF FUNCTION, FIRST DERIVATIVE,
C	      AND SECOND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL QHSE (H,Y,FDY,SDY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      H      - THE INCREMENT OF ARGUMENT VALUES.
C	      Y      - THE INPUT VECTOR OF FUNCTION VALUES.
C	      FDY    - THE INPUT VECTOR OF FIRST DERIVATIVE.
C	      SDY    - THE INPUT VECTOR OF SECOND DERIVATIVE.
C	      Z      - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE
C	               IDENTICAL WITH Y,FDY OR SDY.
C	      NDIM   - THE DIMENSION OF VECTORS Y,FDY,SDY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	      PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	      PP.227-230.
C
C	..................................................................
C
	SUBROUTINE QHSE(H,Y,FDY,SDY,Z,NDIM)
C
C
	DIMENSION Y(1),FDY(1),SDY(1),Z(1)
C
	SUM2=0.
	IF(NDIM-1)4,3,1
1	HH=.5*H
	HF=.2*H
	HT=.08333333*H
C
C	INTEGRATION LOOP
	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+
     1              HT*(SDY(I-1)+SDY(I))))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QHSG
C
C	   PURPOSE
C	      TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C	      GENERAL TABLE OF ARGUMENT, FUNCTION, FIRST DERIVATIVE,
C	      AND SECOND DERIVATIVE VALUES.
C
C	   USAGE
C	      CALL QHSG (X,Y,FDY,SDY,Z,NDIM)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - THE INPUT VECTOR OF ARGUMENT VALUES.
C	      Y      - THE INPUT VECTOR OF FUNCTION VALUES.
C	      FDY    - THE INPUT VECTOR OF FIRST DERIVATIVE.
C	      SDY    - THE INPUT VECTOR OF SECOND DERIVATIVE.
C	      Z      - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE
C	               IDENTICAL WITH X,Y,FDY OR SDY.
C	      NDIM   - THE DIMENSION OF VECTORS X,Y,FDY,SDY,Z.
C
C	   REMARKS
C	      NO ACTION IN CASE NDIM LESS THAN 1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C	      MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA.
C	      FOR REFERENCE, SEE
C	      R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C	      PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C	      PP.227-230.
C
C	..................................................................
C
	SUBROUTINE QHSG(X,Y,FDY,SDY,Z,NDIM)
C
C
	DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1)
C
	SUM2=0.
	IF(NDIM-1)4,3,1
C
C	INTEGRATION LOOP
1	DO 2 I=2,NDIM
	SUM1=SUM2
	SUM2=.5*(X(I)-X(I-1))
	SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4*SUM2*((FDY(I-1)-FDY(I))+
     1     .1666667*SUM2*(SDY(I-1)+SDY(I))))
2	Z(I-1)=SUM1
3	Z(NDIM)=SUM2
4	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QL10
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0
C	                          TO INFINITY).
C
C	   USAGE
C	      CALL QL10(FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 10-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 19.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352.
C
C	..................................................................
C
	SUBROUTINE QL10(FCT,Y)
C
C
	X=29.92070
	Y=.9911827E-12*FCT(X)
	X=21.99659
	Y=Y+.1839565E-8*FCT(X)
	X=16.27926
	Y=Y+.4249314E-6*FCT(X)
	X=11.84379
	Y=Y+.2825923E-4*FCT(X)
	X=8.330153
	Y=Y+.7530084E-3*FCT(X)
	X=5.552496
	Y=Y+.009501517*FCT(X)
	X=3.401434
	Y=Y+.06208746*FCT(X)
	X=1.808343
	Y=Y+.2180683*FCT(X)
	X=.7294545
	Y=Y+.4011199*FCT(X)
	X=.1377935
	Y=Y+.3084411*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QL2
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0
C	                          TO INFINITY).
C
C	   USAGE
C	      CALL QL2 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 2-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 3.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352.
C
C	..................................................................
C
	SUBROUTINE QL2(FCT,Y)
C
C
	X=3.414214
	Y=.1464466*FCT(X)
	X=.5857864
	Y=Y+.8535534*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QL3
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0
C	                          TO INFINITY).
C
C	   USAGE
C	      CALL QL3 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 3-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 5.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352.
C
C	..................................................................
C
	SUBROUTINE QL3(FCT,Y)
C
C
	X=6.289945
	Y=.01038926*FCT(X)
	X=2.294280
	Y=Y+.2785177*FCT(X)
	X=.4157746
	Y=Y+.7110930*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QL4
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0
C	                          TO INFINITY).
C
C	   USAGE
C	      CALL QL4 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 7.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352.
C
C	..................................................................
C
	SUBROUTINE QL4(FCT,Y)
C
C
	X=9.395071
	Y=.5392947E-3*FCT(X)
	X=4.536620
	Y=Y+.03888791*FCT(X)
	X=1.745761
	Y=Y+.3574187*FCT(X)
	X=.3225477
	Y=Y+.6031541*FCT(X)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE QL5
C
C	   PURPOSE
C	      TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0
C	                          TO INFINITY).
C
C	   USAGE
C	      CALL QL5 (FCT,Y)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	      Y      - THE RESULTING INTEGRAL VALUE.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF 5-POINT GAUSSIAN-LAGUERRE
C	      QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER
C	      FCT(X) IS A POLYNOMIAL UP TO DEGREE 9.
C	      FOR REFERENCE, SEE
C	      V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS,
C	      MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352.
C
C	..................................................................
C
	SUBROUTINE QL5(FCT,Y)
C
C
	X=12.64080
	Y=.2336997E-4*FCT(X)
	X=7.085810
	Y=Y+.3611759E-2*FCT(X)
	X=3.596426
	Y=Y+.07594245*FCT(X)
	X=1.413403
	Y=Y+.3986668*FCT(X)
	X=.2635603
	Y=Y+.5217556*FCT(X)
	RETURN
	END
C
C     ..................................................................
C
C        SUBROUTINE QSF
C
C        PURPOSE
C           TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN
C           EQUIDISTANT TABLE OF FUNCTION VALUES.
C
C        USAGE
C           CALL QSF (H,Y,Z,NDIM)
C
C        DESCRIPTION OF PARAMETERS
C           H      - THE INCREMENT OF ARGUMENT VALUES.
C           Y      - THE INPUT VECTOR OF FUNCTION VALUES.
C           Z      - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE
C                    IDENTICAL WITH Y.
C           NDIM   - THE DIMENSION OF VECTORS Y AND Z.
C
C        REMARKS
C           NO ACTION IN CASE NDIM LESS THAN 3.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY
C           MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A
C           COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF
C           ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3
C           TRUNCATION ERROR OF Z(2) IS OF ORDER H**4.
C           FOR REFERENCE, SEE
C           (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C               MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76.
C           (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND
C               PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963,
C               PP.214-221.
C
C     ..................................................................
C
      SUBROUTINE QSF(H,Y,Z,NDIM)
C
C
      DIMENSION Y(1),Z(1)
C
      HT=.3333333*H
      IF(NDIM-5)7,8,1
C
C     NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP
    1 SUM1=Y(2)+Y(2)
      SUM1=SUM1+SUM1
      SUM1=HT*(Y(1)+SUM1+Y(3))
      AUX1=Y(4)+Y(4)
      AUX1=AUX1+AUX1
      AUX1=SUM1+HT*(Y(3)+AUX1+Y(5))
      AUX2=HT*(Y(1)+3.875*(Y(2)+Y(5))+2.625*(Y(3)+Y(4))+Y(6))
      SUM2=Y(5)+Y(5)
      SUM2=SUM2+SUM2
      SUM2=AUX2-HT*(Y(4)+SUM2+Y(6))
      Z(1)=0.
      AUX=Y(3)+Y(3)
      AUX=AUX+AUX
      Z(2)=SUM2-HT*(Y(2)+AUX+Y(4))
      Z(3)=SUM1
      Z(4)=SUM2
      IF(NDIM-6)5,5,2
C
C     INTEGRATION LOOP
    2 DO 4 I=7,NDIM,2
      SUM1=AUX1
      SUM2=AUX2
      AUX1=Y(I-1)+Y(I-1)
      AUX1=AUX1+AUX1
      AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I))
      Z(I-2)=SUM1
      IF(I-NDIM)3,6,6
    3 AUX2=Y(I)+Y(I)
      AUX2=AUX2+AUX2
      AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1))
    4 Z(I-1)=SUM2
    5 Z(NDIM-1)=AUX1
      Z(NDIM)=AUX2
      RETURN
    6 Z(NDIM-1)=SUM2
      Z(NDIM)=AUX1
      RETURN
C     END OF INTEGRATION LOOP
C
    7 IF(NDIM-3)12,11,8
C
C     NDIM IS EQUAL TO 4 OR 5
    8 SUM2=1.125*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4))
      SUM1=Y(2)+Y(2)
      SUM1=SUM1+SUM1
      SUM1=HT*(Y(1)+SUM1+Y(3))
      Z(1)=0.
      AUX1=Y(3)+Y(3)
      AUX1=AUX1+AUX1
      Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4))
      IF(NDIM-5)10,9,9
    9 AUX1=Y(4)+Y(4)
      AUX1=AUX1+AUX1
      Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5))
   10 Z(3)=SUM1
      Z(4)=SUM2
      RETURN
C
C     NDIM IS EQUAL TO 3
   11 SUM1=HT*(1.25*Y(1)+Y(2)+Y(2)-.25*Y(3))
      SUM2=Y(2)+Y(2)
      SUM2=SUM2+SUM2
      Z(3)=HT*(Y(1)+SUM2+Y(3))
      Z(1)=0.
      Z(2)=SUM1
   12 RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RADD
C
C        PURPOSE
C           ADD ROW OF ONE MATRIX TO ROW OF ANOTHER MATRIX
C
C        USAGE
C           CALL RADD(A,IRA,R,IRR,N,M,MS,L)
C
C        DESCRIPTION OF PARAMETERS
C           A   - NAME OF INPUT MATRIX
C           IRA - ROW IN MATRIX A TO BE ADDED TO ROW IRR OF MATRIX R
C           R   - NAME OF OUTPUT MATRIX
C           IRR - ROW IN MATRIX R WHERE SUMMATION IS DEVELOPED
C           N   - NUMBER OF ROWS IN A
C           M   - NUMBER OF COLUMNS IN A AND R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C           L   - NUMBER OF ROWS IN R
C
C        REMARKS
C           MATRIX R MUST BE A GENERAL MATRIX
C           MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A UNLESS
C           A IS GENERAL
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           EACH ELEMENT OF ROW IRA OF MATRIX A IS ADDED TO
C           CORRESPONDING ELEMENT OF ROW IRR OF MATRIX R
C
C     ..................................................................
C
      SUBROUTINE RADD(A,IRA,R,IRR,N,M,MS,L)
      DIMENSION A(1),R(1)
C
      IR=IRR-L
      DO 2 J=1,M
      IR=IR+L
C
C        LOCATE INPUT ELEMENT FOR ANY MATRIX STORAGE MODE
C
      CALL LOC(IRA,J,IA,N,M,MS)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(IA) 1,2,1
C
C        ADD ELEMENTS
C
    1 R(IR)=R(IR)+A(IA)
    2 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RANK
C
C        PURPOSE
C           RANK A VECTOR OF VALUES
C
C        USAGE
C           CALL RANK(A,R,N)
C
C        DESCRIPTION OF PARAMETERS
C           A - INPUT VECTOR OF N VALUES
C           R - OUTPUT VECTOR OF LENGTH N. SMALLEST VALUE IS RANKED 1,
C               LARGEST IS RANKED N. TIES ARE ASSIGNED AVERAGE OF TIED
C               RANKS
C           N - NUMBER OF VALUES
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           VECTOR IS SEARCHED FOR SUCCESSIVELY LARGER ELEMENTS. IF TIES
C           OCCUR, THEY ARE LOCATED AND THEIR RANK VALUE COMPUTED.
C           FOR EXAMPLE, IF 2 VALUES ARE TIED FOR SIXTH RANK, THEY ARE
C           ASSIGNED A RANK OF 6.5 (=(6+7)/2)
C
C     ..................................................................
C
      SUBROUTINE RANK(A,R,N)
      DIMENSION A(1),R(1)
C
C        INITIALIZATION
C
      DO 10 I=1,N
   10 R(I)=0.0
C
C        FIND RANK OF DATA
C
      DO 100 I=1,N
C
C        TEST WHETHER DATA POINT IS ALREADY RANKED
C
      IF(R(I)) 20, 20, 100
C
C        DATA POINT TO BE RANKED
C
   20 SMALL=0.0
      EQUAL=0.0
      X=A(I)
      DO 50 J=1,N
      IF(A(J)-X) 30, 40, 50
C        COUNT NUMBER OF DATA POINTS WHICH ARE SMALLER
C
C
   30 SMALL=SMALL+1.0
      GO TO 50
C
C        COUNT NUMBER OF DATA POINTS WHICH ARE EQUAL
C
   40 EQUAL=EQUAL+1.0
      R(J)=-1.0
   50 CONTINUE
C
C        TEST FOR TIE
C
      IF(EQUAL-1.0) 60, 60, 70
C
C        STORE RANK OF DATA POINT WHERE NO TIE
C
   60 R(I)=SMALL+1.0
      GO TO 100
C
C        CALCULATE RANK OF TIED DATA POINTS
C
   70 P=SMALL + (EQUAL + 1.0)*0.5
      DO 90 J=I,N
      IF(R(J)+1.0) 90, 80, 90
   80 R(J)=P
   90 CONTINUE
  100 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RCPY
C
C        PURPOSE
C           COPY SPECIFIED ROW OF A MATRIX INTO A VECTOR
C
C        USAGE
C           CALL RCPY (A,L,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           L - ROW OF A TO BE MOVED TO R
C           R - NAME OF OUTPUT VECTOR OF LENGTH M
C           N - NUMBER OR ROWS IN A
C           M - NUMBER OF COLUMNS IN A
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           ELEMENTS OF ROW L ARE MOVED TO CORRESPONDING POSITIONS
C           OF VECTOR R
C
C     ..................................................................
C
      SUBROUTINE RCPY(A,L,R,N,M,MS)
      DIMENSION A(1),R(1)
C
      DO 3 J=1,M
C
C        LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
      CALL LOC(L,J,LJ,N,M,MS)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(LJ) 1,2,1
C
C        MOVE ELEMENT TO R
C
    1 R(J)=A(LJ)
      GO TO 3
    2 R(J)=0.0
    3 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RCUT
C
C        PURPOSE
C           PARTITION A MATRIX BETWEEN SPECIFIED ROWS TO FORM TWO
C           RESULTANT MATRICES
C
C        USAGE
C           CALL RCUT (A,L,R,S,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           L - ROW OF A ABOVE WHICH PARTITIONING TAKES PLACE
C           R - NAME OF MATRIX TO BE FORMED FROM UPPER PORTION OF A
C           S - NAME OF MATRIX TO BE FORMED FROM LOWER PORTION OF A
C           N - NUMBER OF ROWS IN A
C           M - NUMBER OF COLUMNS IN A
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX A
C           MATRIX S CANNOT BE IN SAME LOCATION AS MATRIX A
C           MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX S
C           MATRIX R AND MATRIX S ARE ALWAYS GENERAL MATRICES
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           ELEMENTS OF MATRIX A ABOVE ROW L ARE MOVED TO FORM MATRIX R
C           OF L-1 ROWS AND M COLUMNS. ELEMENTS OF MATRIX A IN ROW L
C           AND BELOW ARE MOVED TO FORM MATRIX S OF N-L+1 ROWS AND M
C           COLUMNS
C
C     ..................................................................
C
      SUBROUTINE RCUT(A,L,R,S,N,M,MS)
      DIMENSION A(1),R(1),S(1)
C
      IR=0
      IS=0
      DO 70 J=1,M
      DO 70 I=1,N
C
C        FIND LOCATION IN OUTPUT MATRIX AND SET TO ZERO
C
      IF(I-L) 20,10,10
   10 IS=IS+1
      S(IS)=0.0
      GO TO 30
   20 IR=IR+1
      R(IR)=0.0
C
C        LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
   30 CALL LOC(I,J,IJ,N,M,MS)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(IJ) 40,70,40
C
C        DETERMINE WHETHER ABOVE OR BELOW L
C
   40 IF(I-L) 60,50,50
   50 S(IS)=A(IJ)
      GO TO 70
   60 R(IR)=A(IJ)
   70 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        FUNCTION RECP
C
C        PURPOSE
C           CALCULATE RECIPROCAL OF AN ELEMENT. THIS IS A FORTRAN
C           FUNCTION SUBPROGRAM WHICH MAY BE USED AS AN ARGUMENT BY
C           SUBROUTINE MFUN.
C
C        USAGE
C           RECP(E)
C
C        DESCRIPTION OF PARAMETERS
C           E - MATRIX ELEMENT
C
C        REMARKS
C           RECIPROCAL OF ZERO IS TAKEN TO BE 1.0E75
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           RECIPROCAL OF ELEMENT E IS PLACED IN RECP
C
C     ..................................................................
C
      FUNCTION RECP(E)
C
      BIG=1.0E37
C
C        TEST ELEMENT FOR ZERO
C
      IF(E) 1,2,1
C
C        IF NON-ZERO, CALCULATE RECIPROCAL
C
    1 RECP=1.0/E
      RETURN
C
C        IF ZERO, SET EQUAL TO INFINITY
C
    2 RECP=SIGN(BIG,E)
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RINT
C
C        PURPOSE
C           INTERCHANGE TWO ROWS OF A MATRIX
C
C        USAGE
C           CALL RINT(A,N,M,LA,LB)
C
C        DESCRIPTION OF PARAMETERS
C           A  - NAME OF MATRIX
C           N  - NUMBER OF ROWS IN A
C           M  - NUMBER OF COLUMNS IN A
C           LA - ROW TO BE INTERCHANGED WITH ROW LB
C           LB - ROW TO BE INTERCHANGED WITH ROW LA
C
C        REMARKS
C           MATRIX A MUST BE A GENERAL MATRIX
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           EACH ELEMENT OF ROW LA IS INTERCHANGED WITH CORRESPONDING
C           ELEMENT OF ROW LB
C
C     ..................................................................
C
      SUBROUTINE RINT(A,N,M,LA,LB)
      DIMENSION A(1)
C
      LAJ=LA-N
      LBJ=LB-N
      DO 3 J=1,M
C
C        LOCATE ELEMENTS IN BOTH ROWS
C
      LAJ=LAJ+N
      LBJ=LBJ+N
C
C        INTERCHANGE ELEMENTS
C
      SAVE=A(LAJ)
      A(LAJ)=A(LBJ)
    3 A(LBJ)=SAVE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RK1
C
C        PURPOSE
C           INTEGRATES A FIRST ORDER DIFFERENTIAL EQUATION
C           DY/DX=FUN(X,Y) UP TO A SPECIFIED FINAL VALUE
C
C        USAGE
C           CALL RK1(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER)
C
C        DESCRIPTION OF PARAMETERS
C           FUN -USER-SUPPLIED FUNCTION SUBPROGRAM WITH ARGUMENTS X,Y
C                WHICH GIVES DY/DX
C           HI  -THE STEP SIZE
C           XI  -INITIAL VALUE OF X
C           YI  -INITIAL VALUE OF Y WHERE YI=Y(XI)
C           XF  -FINAL VALUE OF X
C           YF  -FINAL VALUE OF Y
C           ANSX-RESULTANT FINAL VALUE OF X
C           ANSY-RESULTANT FINAL VALUE OF Y
C                EITHER ANSX WILL EQUAL XF OR ANSY WILL EQUAL YF
C                DEPENDING ON WHICH IS REACHED FIRST
C           IER -ERROR CODE
C                IER=0 NO ERROR
C                IER=1 STEP SIZE IS ZERO
C
C        REMARKS
C           IF XI IS GREATER THAN XF, ANSX=XI AND ANSY=YI
C           IF H IS ZERO, IER IS SET TO ONE, ANSX IS SET TO XI, AND
C           ANSY IS SET TO ZERO
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           FUN IS A TWO ARGUMENT FUNCTION SUBPROGRAM FURNISHED BY THE
C           USER.  DY/DX=FUN (X,Y)
C           CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT
C           CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO
C           RK1
C
C        METHOD
C           USES FOURTH ORDER RUNGE-KUTTA INTEGRATION PROCESS ON A
C           RECURSIVE BASIS AS SHOWN IN F.B. HILDEBRAND, 'INTRODUCTION
C           TO NUMERICAL ANALYSIS',MCGRAW-HILL,1956. PROCESS IS
C           TERMINATED AND FINAL VALUE ADJUSTED WHEN EITHER XF OR YF
C           IS REACHED.
C
C     ..................................................................
C
      SUBROUTINE RK1(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER)
C
C        ...............................................................
C
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C        STATEMENT WHICH FOLLOWS.
C
C     DOUBLE PRECISION HI,XI,YI,XF,YF,ANSX,ANSY,H,XN,YN,HNEW,XN1,YN1,
C    1                 XX,YY,XNEW,YNEW,H2,T1,T2,T3,T4,FUN
C
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C        ROUTINE.
C
C        USER FUNCTION SUBPROGRAM, FUN, MUST BE IN DOUBLE PRECISION.
C
C        ...............................................................
C
C     IF XF IS LESS THAN OR EQUAL TO XI, RETURN XI,YI AS ANSWER
C
      IER=0
      IF(XF-XI) 11,11,12
   11 ANSX=XI
      ANSY=YI
      RETURN
C
C     TEST INTERVAL VALUE
C
   12 H=HI
      IF(HI) 16,14,20
   14 IER=1
      ANSX=XI
      ANSY=0.0
      RETURN
   16 H=-HI
C
C     SET XN=INITIAL X,YN=INITIAL Y
C
   20 XN=XI
      YN=YI
C
C     INTEGRATE ONE TIME STEP
C
      HNEW=H
      JUMP=1
      GO TO 170
   25 XN1=XX
      YN1=YY
C
C     COMPARE XN1 (=X(N+1)) TO X FINAL AND BRANCH ACCORDINGLY
C
      IF(XN1-XF)50,30,40
C
C     XN1=XF, RETURN (XF,YN1) AS ANSWER
C
   30 ANSX=XF
      ANSY=YN1
      GO TO 160
C
C     XN1 GREATER THAN XF, SET NEW STEP SIZE AND INTEGRATE ONE STEP
C     RETURN RESULTS OF INTEGRATION AS ANSWER
C
   40 HNEW=XF-XN
      JUMP=2
      GO TO 170
   45 ANSX=XX
      ANSY=YY
      GO TO 160
C
C     XN1 LESS THAN X FINAL, CHECK IF (YN,YN1) SPAN Y FINAL
C
C
   50 IF((YN1-YF)*(YF-YN))60,70,110
C
C     YN1 AND YN DO NOT SPAN YF. SET (XN,YN) AS (XN1,YN1) AND REPEAT
C
   60 YN=YN1
      XN=XN1
      GO TO 170
C
C     EITHER YN OR YN1 =YF. CHECK WHICH AND SET PROPER (X,Y) AS ANSWER
C
   70 IF(YN1-YF)80,100,80
   80 ANSY=YN
      ANSX=XN
      GO TO 160
  100 ANSY=YN1
      ANSX=XN1
      GO TO 160
C
C     YN AND YN1 SPAN YF. TRY TO FIND X VALUE ASSOCIATED WITH YF
C
  110 DO 140 I=1,10
C
C     INTERPOLATE TO FIND NEW TIME STEP AND INTEGRATE ONE STEP
C     TRY TEN INTERPOLATIONS AT MOST
C
      HNEW=((YF-YN )/(YN1-YN))*(XN1-XN)
      JUMP=3
      GO TO 170
  115 XNEW=XX
      YNEW=YY
C
C     COMPARE COMPUTED Y VALUE WITH YF AND BRANCH
C
      IF(YNEW-YF)120,150,130
C
C     ADVANCE, YF IS BETWEEN YNEW AND YN1
C
  120 YN=YNEW
      XN=XNEW
      GO TO 140
C
C     ADVANCE, YF IS BETWEEN YN AND YNEW
C
  130 YN1=YNEW
      XN1=XNEW
  140 CONTINUE
C
C     RETURN (XNEW,YF) AS ANSWER
C
  150 ANSX=XNEW
      ANSY=YF
  160 RETURN
C
  170 H2=HNEW/2.0
      T1=HNEW*FUN(XN,YN)
      T2=HNEW*FUN(XN+H2,YN+T1/2.0)
      T3=HNEW*FUN(XN+H2,YN+T2/2.0)
      T4=HNEW*FUN(XN+HNEW,YN+T3)
      YY=YN+(T1+2.0*T2+2.0*T3+T4)/6.0
      XX=XN+HNEW
      GO TO (25,45,115), JUMP
C
      END
C
C     ..................................................................
C
C        SUBROUTINE RK2
C
C        PURPOSE
C           INTEGRATES A FIRST ORDER DIFFERENTIAL EQUATION
C           DY/DX=FUN(X,Y) AND PRODUCES A TABLE OF INTEGRATED VALUES
C
C        USAGE
C           CALL RK2(FUN,H,XI,YI,K,N,VEC)
C
C        DESCRIPTION OF PARAMETERS
C           FUN-USER-SUPPLIED FUNCTION SUBPROGRAM WITH ARGUMENTS X,Y
C               WHICH GIVES DY/DX
C           H  -STEP SIZE
C           XI -INITIAL VALUE OF X
C           YI -INITIAL VALUE OF Y WHERE YI=Y(XI)
C           K  -THE INTERVAL AT WHICH COMPUTED VALUES ARE TO BE STORED
C           N  -THE NUMBER OF VALUES TO BE STORED
C           VEC-THE RESULTANT VECTOR OF LENGTH N IN WHICH COMPUTED
C               VALUES OF Y ARE TO BE STORED
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           FUN - USER-SUPPLIED FUNCTION SUBPROGRAM FOR DY/DX
C           CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT
C           CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO
C           RK2
C
C        METHOD
C           FOURTH ORDER RUNGE-KUTTA INTEGRATION ON A RECURSIVE BASIS AS
C           SHOWN IN F.B. HILDEBRAND, 'INTRODUCTION TO NUMERICAL
C           ANALYSIS', MCGRAW-HILL, NEW YORK, 1956
C
C     ..................................................................
C
      SUBROUTINE RK2(FUN,H,XI,YI,K,N,VEC)
C
C        ...............................................................
C
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C        STATEMENT WHICH FOLLOWS.
C
C     DOUBLE PRECISION H,XI,YI,VEC,H2,Y,X,T1,T2,T3,T4,FUN
C
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C        ROUTINE.
C
C        USER FUNCTION SUBPROGRAM, FUN, MUST BE IN DOUBLE PRECISION.
C
C        ...............................................................
C
      DIMENSION VEC(1)
      H2=H/2.
      Y=YI
      X=XI
      DO 2 I=1,N
      DO 1 J=1,K
      T1=H*FUN(X,Y)
      T2=H*FUN(X+H2,Y+T1/2.)
      T3=H*FUN(X+H2,Y+T2/2.)
      T4=H*FUN(X+H,Y+T3)
      Y= Y+(T1+2.*T2+2.*T3+T4)/6.
    1 X=X+H
    2 VEC(I)=Y
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RSRT
C
C        PURPOSE
C           SORT ROWS OF A MATRIX
C
C        USAGE
C           CALL RSRT(A,B,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX TO BE SORTED
C           B - NAME OF INPUT VECTOR WHICH CONTAINS SORTING KEY
C           R - NAME OF SORTED OUTPUT MATRIX
C           N - NUMBER OF ROWS IN A AND R AND LENGTH OF B
C           M - NUMBER OF COLUMNS IN A AND R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C           MATRIX R IS ALWAYS A GENERAL MATRIX
C           N MUST BE GREATER THAN ONE.
C	    M ALSO MUST BE AT LEAST TWO
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           ROWS OF INPUT MATRIX A ARE SORTED TO FORM OUTPUT MATRIX R.
C           THE SORTED ROW SEQUENCE IS DETERMINED BY THE VALUES OF
C           ELEMENTS IN COLUMN VECTOR B. THE LOWEST VALUED ELEMENT IN
C           B WILL CAUSE THE CORRESPONDING ROW OF A TO BE PLACED IN THE
C           FIRST ROW OF R. THE HIGHEST VALUED ELEMENT OF B WILL CAUSE
C           THE CORRESPONDING ROW OF A TO BE PLACED IN THE LAST ROW OF
C           R. IF DUPLICATE VALUES EXIST IN B, THE CORRESPONDING ROWS
C           OF A ARE MOVED TO R IN THE SAME ORDER AS IN A.
C
C     ..................................................................
C
      SUBROUTINE RSRT(A,B,R,N,M,MS)
      DIMENSION A(1),B(1),R(1)
C
C        MOVE SORTING KEY VECTOR TO FIRST COLUMN OF OUTPUT MATRIX
C        AND BUILD ORIGINAL SEQUENCE LIST IN SECOND COLUMN
C
      DO 10 I=1,N
      R(I)=B(I)
      I2=I+N
   10 R(I2)=I
C
C        SORT ELEMENTS IN SORTING KEY VECTOR (ORIGINAL SEQUENCE LIST
C        IS RESEQUENCED ACCORDINGLY)
C
      L=N+1
   20 ISORT=0
      L=L-1
      DO 40 I=2,L
      IF(R(I)-R(I-1)) 30,40,40
   30 ISORT=1
      RSAVE=R(I)
      R(I)=R(I-1)
      R(I-1)=RSAVE
      I2=I+N
      SAVER=R(I2)
      R(I2)=R(I2-1)
      R(I2-1)=SAVER
   40 CONTINUE
      IF(ISORT) 20,50,20
C
C        MOVE ROWS FROM MATRIX A TO MATRIX R (NUMBER IN SECOND COLUMN
C        OF R REPRESENTS ROW NUMBER OF MATRIX A TO BE MOVED)
C
   50 DO 80 I=1,N
C
C        GET ROW NUMBER IN MATRIX A
C
      I2=I+N
      IN=R(I2)
C
      IR=I-N
      DO 80 J=1,M
C
C        LOCATE ELEMENT IN OUTPUT MATRIX
C
      IR=IR+N
C
C        LOCATE ELEMENT IN INPUT MATRIX
C
      CALL LOC(IN,J,IA,N,M,MS)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(IA) 60,70,60
C
C        MOVE ELEMENT TO OUTPUT MATRIX
C
   60 R(IR)=A(IA)
      GO TO 80
   70 R(IR)=0
   80 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RSUM
C
C        PURPOSE
C           SUM ELEMENTS OF EACH ROW TO FORM COLUMN VECTOR
C
C        USAGE
C           CALL RSUM (A,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           R - NAME OF VECTOR OF LENGTH N
C           N - NUMBER OF ROWS IN A
C           M - NUMBER OF COLUMNS IN A
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           VECTOR R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C           UNLESS A IS GENERAL
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           ELEMENTS ARE SUMMED ACROSS EACH ROW INTO A CORRESPONDING
C           ELEMENT OF OUTPUT COLUMN VECTOR R
C
C     ..................................................................
C
      SUBROUTINE RSUM(A,R,N,M,MS)
      DIMENSION A(1),R(1)
C
      DO 3 I=1,N
C
C        CLEAR OUTPUT LOCATION
C
      R(I)=0.0
C
      DO 3 J=1,M
C
C        LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
      CALL LOC(I,J,IJ,N,M,MS)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(IJ) 2,3,2
C
C        ACCUMULATE IN OUTPUT VECTOR
C
    2 R(I)=R(I)+A(IJ)
    3 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RTAB
C
C        PURPOSE
C           TABULATE ROWS OF A MATRIX TO FORM A SUMMARY MATRIX
C
C        USAGE
C           CALL RTAB(A,B,R,S,N,M,MS,L)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           B - NAME OF INPUT VECTOR OF LENGTH N CONTAINING KEY
C           R - NAME OF OUTPUT MATRIX CONTAINING SUMMARY OF ROW DATA.
C               IT IS INITIALLY SET TO ZERO BY THIS SUBROUTINE.
C           S - NAME OF OUTPUT VECTOR OF LENGTH L+1 CONTAINING COUNTS
C           N - NUMBER OF ROWS IN A
C           M - NUMBER OF COLUMNS IN A AND R
C           L - NUMBER OF ROWS IN R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           MATRIX R IS ALWAYS A GENERAL MATRIX
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C           RADD
C
C        METHOD
C           ROWS OF DATA IN MATRIX A ARE TABULATED BASED ON THE KEY
C           CONTAINED IN VECTOR B. THE FLOATING POINT NUMBER IN B(I) IS
C           TRUNCATED TO FORM J. THE ITH ROW OF A IS ADDED TO THE JTH
C           ROW OF R ELEMENT BY ELEMENT AND ONE IS ADDED TO S(J). IF J
C           IS NOT BETWEEN ONE AND L, ONE IS ADDED TO S(L+1). THIS
C           PROCEDURE IS REPEATED FOR EVERY ELEMENT IN VECTOR B.
C           UPON COMPLETION, THE OUTPUT MATRIX R CONTAINS A SUMMARY OF
C           ROW DATA AS SPECIFIED BY VECTOR B. EACH ELEMENT IN VECTOR S
C           CONTAINS A COUNT OF THE NUMBER OF ROWS OF A USED TO FORM THE
C           CORRESPONDING ROW OF R. ELEMENT S(L+1) CONTAINS A COUNT OF
C           THE NUMBER OF ROWS OF A NOT INCLUDED IN R AS A RESULT OF J
C           BEING LESS THAN ONE OR GREATER THAN L.
C
C     ..................................................................
C
      SUBROUTINE RTAB(A,B,R,S,N,M,MS,L)
      DIMENSION A(1),B(1),R(1),S(1)
C
C        CLEAR OUTPUT AREAS
C
      CALL LOC(M,L,IT,M,L,0)
      DO 10 IR=1,IT
   10 R(IR)=0.0
      DO 20 IS=1,L
   20 S(IS)=0.0
      S(L+1)=0.0
C
      DO 60 I=1,N
C
C        TEST FOR THE KEY OUTSIDE THE RANGE
C
      JR=B(I)
      IF (JR-1) 50,40,30
   30 IF (JR-L) 40,40,50
C
C
C        ADD ROW OF A TO ROW OF R AND 1 TO COUNT
C
   40 CALL RADD(A,I,R,JR,N,M,MS,L)
      S(JR)=S(JR)+1.0
      GO TO 60
C
   50 S(L+1)=S(L+1)+1.0
   60 CONTINUE
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RTIE
C
C        PURPOSE
C           ADJOIN TWO MATRICES WITH SAME COLUMN DIMENSION TO FORM ONE
C           RESULTANT MATRIX (SEE METHOD)
C
C        USAGE
C           CALL RTIE(A,B,R,N,M,MSA,MSB,L)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF FIRST INPUT MATRIX
C           B - NAME OF SECOND INPUT MATRIX
C           R - NAME OF OUTPUT MATRIX
C           N - NUMBER OF ROWS IN A
C           M - NUMBER OF COLUMNS IN A,B,R
C           MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C           MSB - SAME AS MSA EXCEPT FOR MATRIX B
C           L - NUMBER OF ROWS IN B
C
C        REMARKS
C           MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B
C           MATRIX R IS ALWAYS A GENERAL MATRIX
C           MATRIX A MUST HAVE THE SAME NUMBER OF COLUMNS AS MATRIX B
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           MATRIX B IS ATTACHED TO THE BOTTOM OF MATRIX A .
C           THE RESULTANT MATRIX R CONTAINS N+L ROWS AND M COLUMNS.
C
C     ..................................................................
C
      SUBROUTINE RTIE(A,B,R,N,M,MSA,MSB,L)
      DIMENSION A(1),B(1),R(1)
C
      NN=N
      IR=0
      NX=NN
      MSX=MSA
      DO 9 J=1,M
      DO 8 II=1,2
      DO 7 I=1,NN
      IR=IR+1
      R(IR)=0.0
C
C        LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
      CALL LOC(I,J,IJ,NN,M,MSX)
C
C        TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
      IF(IJ) 2,7,2
C
C        MOVE ELEMENT TO MATRIX R
C
    2 GO TO(3,4),II
    3 R(IR)=A(IJ)
      GO TO 7
    4 R(IR)=B(IJ)
    7 CONTINUE
C
C        REPEAT ABOVE FOR MATRIX B
C
      MSX=MSB
    8 NN=L
C
C        RESET FOR NEXT COLUMN
C
      MSX=MSA
    9 NN=NX
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RTMI
C
C        PURPOSE
C           TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM FCT(X)=0
C           BY MEANS OF MUELLER-S ITERATION METHOD.
C
C        USAGE
C           CALL RTMI (X,F,FCT,XLI,XRI,EPS,IEND,IER)
C           PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C        DESCRIPTION OF PARAMETERS
C           X      - RESULTANT ROOT OF EQUATION FCT(X)=0.
C           F      - RESULTANT FUNCTION VALUE AT ROOT X.
C           FCT    - NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED.
C           XLI    - INPUT VALUE WHICH SPECIFIES THE INITIAL LEFT BOUND
C                    OF THE ROOT X.
C           XRI    - INPUT VALUE WHICH SPECIFIES THE INITIAL RIGHT BOUND
C                    OF THE ROOT X.
C           EPS    - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE
C                    ERROR OF RESULT X.
C           IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C           IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C                     IER=0 - NO ERROR,
C                     IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS
C                             FOLLOWED BY IEND SUCCESSIVE STEPS OF
C                             BISECTION,
C                     IER=2 - BASIC ASSUMPTION FCT(XLI)*FCT(XRI) LESS
C                             THAN OR EQUAL TO ZERO IS NOT SATISFIED.
C
C        REMARKS
C           THE PROCEDURE ASSUMES THAT FUNCTION VALUES AT INITIAL
C           BOUNDS XLI AND XRI HAVE NOT THE SAME SIGN. IF THIS BASIC
C           ASSUMPTION IS NOT SATISFIED BY INPUT VALUES XLI AND XRI, THE
C           PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C           BY THE USER.
C
C        METHOD
C           SOLUTION OF EQUATION FCT(X)=0 IS DONE BY MEANS OF MUELLER-S
C           ITERATION METHOD OF SUCCESSIVE BISECTIONS AND INVERSE
C           PARABOLIC INTERPOLATION, WHICH STARTS AT THE INITIAL BOUNDS
C           XLI AND XRI. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
C           FCT(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
C           REQUIRES TWO EVALUATIONS OF FCT(X). FOR TEST ON SATISFACTORY
C           ACCURACY SEE FORMULAE (3,4) OF MATHEMATICAL DESCRIPTION.
C           FOR REFERENCE, SEE G. K. KRISTIANSEN, ZERO OF ARBITRARY
C           FUNCTION, BIT, VOL. 3 (1963), PP.205-206.
C
C     ..................................................................
C
      SUBROUTINE RTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER)
C
C
C     PREPARE ITERATION
      IER=0
      XL=XLI
      XR=XRI
      X=XL
      TOL=X
      F=FCT(TOL)
      IF(F)1,16,1
    1 FL=F
      X=XR
      TOL=X
      F=FCT(TOL)
      IF(F)2,16,2
    2 FR=F
      IF(SIGN(1.,FL)+SIGN(1.,FR))25,3,25
C
C     BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED.
C     GENERATE TOLERANCE FOR FUNCTION VALUES.
    3 I=0
      TOLF=100.*EPS
C
C
C     START ITERATION LOOP
    4 I=I+1
C
C     START BISECTION LOOP
      DO 13 K=1,IEND
      X=.5*(XL+XR)
      TOL=X
      F=FCT(TOL)
      IF(F)5,16,5
    5 IF(SIGN(1.,F)+SIGN(1.,FR))7,6,7
C
C     INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR
    6 TOL=XL
      XL=XR
      XR=TOL
      TOL=FL
      FL=FR
      FR=TOL
    7 TOL=F-FL
      A=F*TOL
      A=A+A
      IF(A-FR*(FR-FL))8,9,9
    8 IF(I-IEND)17,17,9
    9 XR=X
      FR=F
C
C     TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP
      TOL=EPS
      A=ABS(XR)
      IF(A-1.)11,11,10
   10 TOL=TOL*A
   11 IF(ABS(XR-XL)-TOL)12,12,13
   12 IF(ABS(FR-FL)-TOLF)14,14,13
   13 CONTINUE
C     END OF BISECTION LOOP
C
C     NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND
C     SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION
C     VALUES AT RIGHT BOUNDS. ERROR RETURN.
      IER=1
   14 IF(ABS(FR)-ABS(FL))16,16,15
   15 X=XL
      F=FL
   16 RETURN
C
C     COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION
   17 A=FR-F
      DX=(X-XL)*FL*(1.+F*(A-TOL)/(A*(FR-FL)))/TOL
      XM=X
      FM=F
      X=XL-DX
      TOL=X
      F=FCT(TOL)
      IF(F)18,16,18
C
C     TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP
   18 TOL=EPS
      A=ABS(X)
      IF(A-1.)20,20,19
   19 TOL=TOL*A
   20 IF(ABS(DX)-TOL)21,21,22
   21 IF(ABS(F)-TOLF)16,16,22
C
C     PREPARATION OF NEXT BISECTION LOOP
   22 IF(SIGN(1.,F)+SIGN(1.,FL))24,23,24
   23 XR=X
      FR=F
      GO TO 4
   24 XL=X
      FL=F
      XR=XM
      FR=FM
      GO TO 4
C     END OF ITERATION LOOP
C
C
C     ERROR RETURN IN CASE OF WRONG INPUT DATA
   25 IER=2
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RTNI
C
C        PURPOSE
C           TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM F(X)=0
C           BY MEANS OF NEWTON-S ITERATION METHOD.
C
C        USAGE
C           CALL RTNI (X,F,DERF,FCT,XST,EPS,IEND,IER)
C           PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C        DESCRIPTION OF PARAMETERS
C           X      - RESULTANT ROOT OF EQUATION F(X)=0.
C           F      - RESULTANT FUNCTION VALUE AT ROOT X.
C           DERF   - RESULTANT VALUE OF DERIVATIVE AT ROOT X.
C           FCT    - NAME OF THE EXTERNAL SUBROUTINE USED. IT COMPUTES
C                    TO GIVEN ARGUMENT X FUNCTION VALUE F AND DERIVATIVE
C                    DERF. ITS PARAMETER LIST MUST BE X,F,DERF.
C           XST    - INPUT VALUE WHICH SPECIFIES THE INITIAL GUESS OF
C                    THE ROOT X.
C           EPS    - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE
C                    ERROR OF RESULT X.
C           IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C           IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C                     IER=0 - NO ERROR,
C                     IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
C                     IER=2 - AT ANY ITERATION STEP DERIVATIVE DERF WAS
C                             EQUAL TO ZERO.
C
C        REMARKS
C           THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
C           IF AT ANY ITERATION STEP DERIVATIVE OF F(X) IS EQUAL TO 0.
C           POSSIBLY THE PROCEDURE WOULD BE SUCCESSFUL IF IT IS STARTED
C           ONCE MORE WITH ANOTHER INITIAL GUESS XST.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           THE EXTERNAL SUBROUTINE FCT(X,F,DERF) MUST BE FURNISHED
C           BY THE USER.
C
C        METHOD
C           SOLUTION OF EQUATION F(X)=0 IS DONE BY MEANS OF NEWTON-S
C           ITERATION METHOD, WHICH STARTS AT THE INITIAL GUESS XST OF
C           A ROOT X. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF
C           F(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP
C           REQUIRES ONE EVALUATION OF F(X) AND ONE EVALUATION OF THE
C           DERIVATIVE OF F(X). FOR TEST ON SATISFACTORY ACCURACY SEE
C           FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
C           FOR REFERENCE, SEE R. ZURMUEHL, PRAKTISCHE MATHEMATIK FUER
C           INGENIEURE UND PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/
C           HEIDELBERG, 1963, PP.12-17.
C
C     ..................................................................
C
      SUBROUTINE RTNI(X,F,DERF,FCT,XST,EPS,IEND,IER)
C
C
C     PREPARE ITERATION
      IER=0
      X=XST
      TOL=X
      CALL FCT(TOL,F,DERF)
      TOLF=100.*EPS
C
C
C     START ITERATION LOOP
      DO 6 I=1,IEND
      IF(F)1,7,1
C
C     EQUATION IS NOT SATISFIED BY X
    1 IF(DERF)2,8,2
C
C     ITERATION IS POSSIBLE
    2 DX=F/DERF
      X=X-DX
      TOL=X
      CALL FCT(TOL,F,DERF)
C
C     TEST ON SATISFACTORY ACCURACY
      TOL=EPS
      A=ABS(X)
      IF(A-1.)4,4,3
    3 TOL=TOL*A
    4 IF(ABS(DX)-TOL)5,5,6
    5 IF(ABS(F)-TOLF)7,7,6
    6 CONTINUE
C     END OF ITERATION LOOP
C
C
C     NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
      IER=1
    7 RETURN
C
C     ERROR RETURN IN CASE OF ZERO DIVISOR
    8 IER=2
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE RTWI
C
C        PURPOSE
C           TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM X=FCT(X)
C           BY MEANS OF WEGSTEIN-S ITERATION METHOD.
C
C        USAGE
C           CALL RTWI (X,VAL,FCT,XST,EPS,IEND,IER)
C           PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C        DESCRIPTION OF PARAMETERS
C           X      - RESULTANT ROOT OF EQUATION X=FCT(X).
C           VAL    - RESULTANT VALUE OF X-FCT(X) AT ROOT X.
C           FCT    - NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED.
C           XST    - INPUT VALUE WHICH SPECIFIES THE INITIAL GUESS OF
C                    THE ROOT X.
C           EPS    - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE
C                    ERROR OF RESULT X.
C           IEND   - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED.
C           IER    - RESULTANT ERROR PARAMETER CODED AS FOLLOWS
C                     IER=0 - NO ERROR,
C                     IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS,
C                     IER=2 - AT ANY ITERATION STEP THE DENOMINATOR OF
C                             ITERATION FORMULA WAS EQUAL TO ZERO.
C
C        REMARKS
C           THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2
C           IF AT ANY ITERATION STEP THE DENOMINATOR OF ITERATION
C           FORMULA WAS EQUAL TO ZERO. THAT MEANS THAT THERE IS AT
C           LEAST ONE POINT IN THE RANGE IN WHICH ITERATION MOVES WITH
C           DERIVATIVE OF FCT(X) EQUAL TO 1.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED
C           BY THE USER.
C
C        METHOD
C           SOLUTION OF EQUATION X=FCT(X) IS DONE BY MEANS OF
C           WEGSTEIN-S ITERATION METHOD, WHICH STARTS AT THE INITIAL
C           GUESS XST OF A ROOT X. ONE ITERATION STEP REQUIRES ONE
C           EVALUATION OF FCT(X). FOR TEST ON SATISFACTORY ACCURACY SEE
C           FORMULAE (2) OF MATHEMATICAL DESCRIPTION.
C           FOR REFERENCE, SEE
C           (1) G. N. LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS,
C               ILIFFE, LONDON, 1960, PP.134-138,
C           (2) J. WEGSTEIN, ALGORITHM 2, CACM, VOL.3, ISS.2 (1960),
C               PP.74,
C           (3) H.C. THACHER, ALGORITHM 15, CACM, VOL.3, ISS.8 (1960),
C               PP.475,
C           (4) J.G. HERRIOT, ALGORITHM 26, CACM, VOL.3, ISS.11 (1960),
C               PP.603.
C
C     ..................................................................
C
      SUBROUTINE RTWI(X,VAL,FCT,XST,EPS,IEND,IER)
C
C
C     PREPARE ITERATION
      IER=0
      TOL=XST
      X=FCT(TOL)
      A=X-XST
      B=-A
      TOL=X
      VAL=X-FCT(TOL)
C
C
C     START ITERATION LOOP
      DO 6 I=1,IEND
      IF(VAL)1,7,1
C
C     EQUATION IS NOT SATISFIED BY X
    1 B=B/VAL-1.
      IF(B)2,8,2
C
C     ITERATION IS POSSIBLE
    2 A=A/B
      X=X+A
      B=VAL
      TOL=X
      VAL=X-FCT(TOL)
C
C     TEST ON SATISFACTORY ACCURACY
      TOL=EPS
      D=ABS(X)
      IF(D-1.)4,4,3
    3 TOL=TOL*D
    4 IF(ABS(A)-TOL)5,5,6
    5 IF(ABS(VAL)-10.*TOL)7,7,6
    6 CONTINUE
C     END OF ITERATION LOOP
C
C
C     NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN.
      IER=1
    7 RETURN
C
C     ERROR RETURN IN CASE OF ZERO DIVISOR
    8 IER=2
      RETURN
      END
C
C     ..................................................................
C
C        SUBROUTINE SADD
C
C        PURPOSE
C           ADD A SCALAR TO EACH ELEMENT OF A MATRIX TO FORM A RESULTANT
C           MATRIX
C
C        USAGE
C           CALL SADD(A,C,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           C - SCALAR
C           R - NAME OF OUTPUT MATRIX
C           N - NUMBER OF ROWS IN MATRIX A AND R
C           M - NUMBER OF COLUMNS IN MATRIX A AND R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           SCALAR IS ADDED TO EACH ELEMENT OF MATRIX
C
C     ..................................................................
C
      SUBROUTINE SADD(A,C,R,N,M,MS)
      DIMENSION A(1),R(1)
C
C        COMPUTE VECTOR LENGTH, IT
C
      CALL LOC(N,M,IT,N,M,MS)
C
C        ADD SCALAR
C
      DO 1 I=1,IT
    1 R(I)=A(I)+C
      RETURN
      END
C
C	..................................................................
C
C	   SUBROUTINE SCLA
C
C	   PURPOSE
C	      SET EACH ELEMENT OF A MATRIX EQUAL TO A GIVEN SCALAR
C
C	   USAGE
C	      CALL SCLA (A,C,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      C - SCALAR
C	      N - NUMBER OF ROWS IN MATRIX A
C	      M - NUMBER OF COLUMNS IN MATRIX A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      EACH ELEMENT OF MATRIX A IS REPLACED BY SCALAR C
C
C	..................................................................
C
	SUBROUTINE SCLA(A,C,N,M,MS)
	DIMENSION A(1)
C
C	   COMPUTE VECTOR LENGTH, IT
C
	CALL LOC(N,M,IT,N,M,MS)
C
C	   REPLACE BY SCALAR
C
	DO 1 I=1,IT
1	A(I)=C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SCMA
C
C	   PURPOSE
C	      MULTIPLY COLUMN OF MATRIX BY A SCALAR AND ADD TO ANOTHER
C	      COLUMN OF THE SAME MATRIX
C
C	   USAGE
C	      CALL SCMA(A,C,N,LA,LB)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - NAME OF MATRIX
C	      C  - SCALAR
C	      N  - NUMBER OF ROWS IN A
C	      LA - COLUMN IN A TO BE MULTIPLIED BY SCALAR
C	      LB - COLUMN IN A TO WHICH PRODUCT IS ADDED
C	           IF 0 IS SPECIFIED, PRODUCT REPLACES ELEMENTS IN LA
C
C	   REMARKS
C	      MATRIX A MUST BE A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EACH ELEMENT OF COLUMN LA IS MULTIPLIED BY SCALAR C AND THE
C	      PRODUCT IS ADDED TO THE CORRESPONDING ELEMENT OF COLUMN LB.
C	      COLUMN LA REMAINS UNAFFECTED BY THE OPERATION.
C	      IF PARAMETER LB CONTAINS ZERO, MULTIPLICATION BY THE SCALAR
C	      IS PERFORMED AND THE PRODUCT REPLACES ELEMENTS IN LA.
C
C	..................................................................
C
	SUBROUTINE SCMA(A,C,N,LA,LB)
	DIMENSION A(1)
C
C	   LOCATE STARTING POINT OF BOTH COLUMNS
C
	ILA=N*(LA-1)
	ILB=N*(LB-1)
C
	DO 3 I=1,N
	ILA=ILA+1
	ILB=ILB+1
C
C	   CHECK LB FOR ZERO
C
	IF(LB) 1,2,1
C
C	   IF NOT MULTIPLY BY CONSTANT AND ADD TO SECOND COLUMN
C
1	A(ILB)=A(ILA)*C+A(ILB)
	GO TO 3
C
C	   OTHERWISE, MULTIPLY COLUMN BY CONSTANT
C
2	A(ILA)=A(ILA)*C
3	CONTINUE
	RETURN
	END
C
C     ..................................................................
C
C        SUBROUTINE SDIV
C
C        PURPOSE
C           DIVIDE EACH ELEMENT OF A MATRIX BY A SCALAR TO FORM A
C           RESULTANT MATRIX
C
C        USAGE
C           CALL SDIV(A,C,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           C - SCALAR
C           R - NAME OF OUTPUT MATRIX
C           N - NUMBER OF ROWS IN MATRIX A AND R
C           M - NUMBER OF COLUMNS IN MATRIX A AND R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           IF SCALAR IS ZERO, DIVISION IS PERFORMED ONLY ONCE TO CAUSE
C           FLOATING POINT OVERFLOW CONDITION
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           EACH ELEMENT OF MATRIX IS DIVIDED BY SCALAR
C
C     ..................................................................
C
      SUBROUTINE SDIV(A,C,R,N,M,MS)
      DIMENSION A(1),R(1)
C
C        COMPUTE VECTOR LENGTH, IT
C
      CALL LOC(N,M,IT,N,M,MS)
C
C        DIVIDE BY SCALAR (IF SCALAR IS ZERO, DIVIDE ONLY ONCE)
C
      IF(C) 2,1,2
    1 IT=1
    2 DO 3 I=1,IT
    3 R(I)=A(I)/C
      RETURN
      END
C
C	..................................................................
C
C	   SUBROUTINE SE15
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
C	      VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
C	      EQUIDISTANTLY SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL SE15(Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF SMOOTHED FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
C	      SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
C	      LEAST-SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 5
C	      SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
C	      HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
C
C	..................................................................
C
	SUBROUTINE SE15(Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
C
C	   TEST OF DIMENSION
	IF(NDIM-5)3,1,1
C
C	   PREPARE LOOP
1	A=Y(1)+Y(1)
	C=Y(2)+Y(2)
	B=.2*(A+Y(1)+C+Y(3)-Y(5))
	C=.1*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4))
C
C	   START LOOP
	DO 2 I=5,NDIM
	A=B
	B=C
	C=.2*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I))
2	Z(I-4)=A
C	   END OF LOOP
C
C	   UPDATE LAST FOUR COMPONENTS
	A=Y(NDIM)+Y(NDIM)
	A=.1*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2)
     1      +Y(NDIM-3))
	Z(NDIM-3)=B
	Z(NDIM-2)=C
	Z(NDIM-1)=A
	Z(NDIM)=A+A-C
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
3	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SE35
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A
C	      VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO
C	      EQUIDISTANTLY SPACED ARGUMENT VALUES.
C
C	   USAGE
C	      CALL SE35(Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF SMOOTHED FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS Y AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 5
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y.  IF Y IS
C	            DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN
C	      EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH
C	      SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE
C	      LEAST-SQUARES POLYNOMIAL OF DEGREE 3 RELEVANT TO THE 5
C	      SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2.  (SEE
C	      HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.)
C
C	..................................................................
C
	SUBROUTINE SE35(Y,Z,NDIM,IER)
C
C
	DIMENSION Y(1),Z(1)
C
C	   TEST OF DIMENSION
	IF(NDIM-5)4,1,1
C
C	   PREPARE LOOP
1	B=Y(1)
	C=Y(2)
C
C	   START LOOP
	DO 3 I=5,NDIM
	A=B
	B=C
	C=Y(I-2)
C
C	   GENERATE FOURTH CENTRAL DIFFERENCE
	D=C-B-Y(I-1)
	D=D+D+C
	D=D+D+A+Y(I)
C
C	   CHECK FIRST TWO COMPONENTS
	IF(I-5)2,2,3
2	Z(1)=A-.01428571*D
	Z(2)=B+.05714286*D
3	Z(I-2)=C-.08571429*D
C	   END OF LOOP
C
C	   UPDATE LAST TWO COMPONENTS
	Z(NDIM-1)=Y(NDIM-1)+.05714286*D
	Z(NDIM)=Y(NDIM)-.01428571*D
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 5
4	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SG13
C
C	   PURPOSE
C	      TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN
C	      VECTORS OF ARGUMENT VALUES AND CORRESPONDING FUNCTION
C	      VALUES.
C
C	   USAGE
C	      CALL SG13(X,Y,Z,NDIM,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X     -  GIVEN VECTOR OF ARGUMENT VALUES (DIMENSION NDIM)
C	      Y     -  GIVEN VECTOR OF FUNCTION VALUES CORRESPONDING TO X
C	               (DIMENSION NDIM)
C	      Z     -  RESULTING VECTOR OF SMOOTHED FUNCTION VALUES
C	               (DIMENSION NDIM)
C	      NDIM  -  DIMENSION OF VECTORS X,Y,AND Z
C	      IER   -  RESULTING ERROR PARAMETER
C	               IER = -1  - NDIM IS LESS THAN 3
C	               IER =  0  - NO ERROR
C
C	   REMARKS
C	      (1)  IF IER=-1 THERE HAS BEEN NO COMPUTATION.
C	      (2)   Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y.  IF
C	            X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED.
C
C	   SUBROUTINES AND SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED
C	      VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST-
C	      SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE
C	      POINTS (X(I+K),Y(I+K)) K = -1,0,1.(SEE HILDEBRAND, F.B.,
C	      INTRODUCTION  TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/
C	      TORONTO/LONDON, 1956, PP.258-311.)
C
C	..................................................................
C
	SUBROUTINE SG13(X,Y,Z,NDIM,IER)
C
C
	DIMENSION X(1),Y(1),Z(1)
C
C	   TEST OF DIMENSION
	IF(NDIM-3)7,1,1
C
C	   START LOOP
1	DO 6 I=3,NDIM
	XM=.3333333*(X(I-2)+X(I-1)+X(I))
	YM=.3333333*(Y(I-2)+Y(I-1)+Y(I))
	T1=X(I-2)-XM
	T2=X(I-1)-XM
	T3=X(I)-XM
	XM=T1*T1+T2*T2+T3*T3
	IF(XM)3,3,2
2	XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM
C
C	   CHECK FIRST POINT
3	IF(I-3)4,4,5
4	H=XM*T1+YM
5	Z(I-2)=H
6	H=XM*T2+YM
C	   END OF LOOP
C
C	   UPDATE LAST TWO COMPONENTS
	Z(NDIM-1)=H
	Z(NDIM)=XM*T3+YM
	IER=0
	RETURN
C
C	   ERROR EXIT IN CASE NDIM IS LESS THAN 3
7	IER=-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SICI
C
C	   PURPOSE
C	      COMPUTES THE SINE AND COSINE INTEGRAL
C
C	   USAGE
C	      CALL SICI(SI,CI,X)
C
C	   DESCRIPTION OF PARAMETERS
C	      SI    - THE RESULTANT VALUE SI(X)
C	      CI    - THE RESULTANT VALUE CI(X)
C	      X     - THE ARGUMENT OF SI(X) AND CI(X)
C
C	   REMARKS
C	      THE ARGUMENT VALUE REMAINS UNCHANGED
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      DEFINITION
C	      SI(X)=INTEGRAL(SIN(T)/T)
C	      CI(X)=INTEGRAL(COS(T)/T)
C	      EVALUATION
C	      REDUCTION OF RANGE USING SYMMETRY.
C	      DIFFERENT APPROXIMATIONS ARE USED FOR ABS(X) GREATER
C	      THAN 4 AND FOR ABS(X) LESS THAN 4.
C	      REFERENCE
C	      LUKE AND WIMP, 'POLYNOMIAL APPROXIMATIONS TO INTEGRAL
C	      TRANSFORMS',  MATHEMATICAL TABLES AND OTHER AIDS TO
C	      COMPUTATION, VOL. 15, 1961, ISSUE 74, PP. 174-178.
C
C	..................................................................
C
	SUBROUTINE SICI(SI,CI,X)
	Z=ABS(X)
	IF(Z-4.)1,1,4
1	Y=(4.-Z)*(4.+Z)
	SI=-1.570797E0
	IF(Z)3,2,3
2	CI=-1.7E38                                                                0
	RETURN
3	SI=X*(((((1.753141E-9*Y+1.568988E-7)*Y+1.374168E-5)*Y+6.939889E-4)
     1*Y+1.964882E-2)*Y+4.395509E-1+SI/X)
	CI=((5.772156E-1+ALOG(Z))/Z-Z*(((((1.386985E-10*Y+1.584996E-8)*Y
     1+1.725752E-6)*Y+1.185999E-4)*Y+4.990920E-3)*Y+1.315308E-1))*Z
	RETURN
4	SI=SIN(Z)
	Y=COS(Z)
	Z=4./Z
	U=((((((((4.048069E-3*Z-2.279143E-2)*Z+5.515070E-2)*Z-7.261642E-2)
     1*Z+4.987716E-2)*Z-3.332519E-3)*Z-2.314617E-2)*Z-1.134958E-5)*Z
     2+6.250011E-2)*Z+2.583989E-10
	V=(((((((((-5.108699E-3*Z+2.819179E-2)*Z-6.537283E-2)*Z
     1+7.902034E-2)*Z-4.400416E-2)*Z-7.945556E-3)*Z+2.601293E-2)*Z
     2-3.764000E-4)*Z-3.122418E-2)*Z-6.646441E-7)*Z+2.500000E-1
	CI=Z*(SI*V-Y*U)
	SI=-Z*(SI*U+Y*V)
	IF(X)5,6,6
5	SI=3.141593E0-SI
6	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SIGNT
C
C	   PURPOSE
C	      TO PERFORM A NON-PARAMETRIC SIGN TEST, GIVEN TWO SETS OF
C	      MATCHED OBSERVATIONS.  IT TESTS THE NULL HYPOTHESIS THAT THE
C	      DIFFERENCES BETWEEN EACH PAIR OF MATCHED OBSERVATIONS HAS A
C	      MEDIAN EQUAL TO ZERO.
C
C	   USAGE
C	      CALL SIGNT (N,A,B,K,M,P,IE)
C
C	   DESCRIPTION OF PARAMETERS
C	      N - NUMBER OF OBSERVATIONS IN SETS A AND B
C	      A - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE FIRST
C	          SAMPLE, A
C	      B - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE SECOND
C	          SAMPLE, B
C	      K - OUTPUT VARIABLE CONTAINING THE NUMBER OF PAIRS OF
C	          OBSERVATIONS FROM THE TWO SAMPLES WHOSE DIFFERENCES ARE
C	          NON-ZERO
C	      M - OUTPUT VARIABLE CONTAINING THE NUMBER OF PLUS OR MINUS
C	          DIFFERENCES, WHICHEVER IS FEWER.
C	      P - COMPUTED PROBABILITY OF AS FEW AS M NUMBER OF PAIRS
C	          HAVING THE SAME SIGN, ASSUMING THAT THE SAMPLES CAME
C	          FROM THE SAME POPULATION.
C	      IE- 0, IF THERE IS NO ERROR.
C	          1, IF K IS ZERO.  IN THIS CASE, P IS SET TO 1.0 AND
C	          M TO 0.
C
C	   REMARKS
C	      IF K IS LESS THAN OR EQUAL TO 25, THE PROBABILITY WILL BE
C	      COMPUTED USING THE BINOMIAL DISTRIBUTION.  IF K IS GREATER
C	      THAN 25, THE PROBABILITY WILL BE COMPUTED USING THE NORMAL
C	      APPROXIMATION TO THE BINOMIAL DISTRIBUTION.
C	      P COMPUTED IS THE PROBABILITY FOR A ONE-TAILED TEST.  THUS,
C	      FOR A TWO TAILED TEST, DOUBLE THE VALUE FOR P.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NDTR
C
C	   METHOD
C	      REFER TO DIXON AND MASSEY, INTRODUCTION TO STATISTICAL
C	      ANALYSIS (MCGRAW-HILL, 1957).
C
C	..................................................................
C
	SUBROUTINE SIGNT (N,A,B,K,M,P,IE)
C
	DIMENSION A(1),B(1)
	DOUBLE PRECISION FN,FD
C
C	   INITIALIZATION
C
	IE=0
	K=0
	MPLUS=0
	MMINS=0
C
C	   FIND (+) OR (-) DIFFERENCE
C
	DO 40 I=1,N
	D=A(I)-B(I)
	IF(D) 20, 40, 30
C
C	   (-) DIFFERENCE
C
20	K=K+1
	MMINS=MMINS+1
	GO TO 40
C
C	   (+) DIFFERENCE
C
30	K=K+1
	MPLUS=MPLUS+1
C
40	CONTINUE
	IF(K) 41,41,42
41	IE=1
	P=1.0
	M=0
	GO TO 95
42	FK=K
C
C	   FIND THE NUMBER OF FEWER SIGNS
C
	IF(MPLUS-MMINS) 45, 45, 50
45	M=MPLUS
	GO TO 55
50	M=MMINS
C
C	   TEST WHETHER K IS GREATER THAN 25
C
55	IF(K-25) 60, 60, 77
C
C	   K IS LESS THAN OR EQUAL TO 25
C
60	P=1.0
	IF(M) 75, 75, 65
65	FN=1.0
	FD=1.0
	DO 70 I=1,M
	FI=I
	FN=FN*(FK-(FI-1.0))
	FD=FD*FI
70	P=P+FN/FD
C
75	P=P/(2.0**K)
	GO TO 95
C
C	   K IS GREATER THAN 25.  COMPUTE MEAN, STANDARD DEVIATION, AND Z
C
77	U=0.5*FK
	S=0.5*SQRT(FK)
	FM=M
	IF(FM-U) 80, 85, 85
80	CON=0.5
	GO TO 90
85	CON=0.0
90	Z=(FM+CON-U)/S
C
C	   COMPUTE P ASSOCIATED WITH THE VALUE AS EXTREME AS Z
C
	CALL NDTR (Z,P,D)
C
95	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SIMQ
C
C	   PURPOSE
C	      OBTAIN SOLUTION OF A SET OF SIMULTANEOUS LINEAR EQUATIONS,
C	      AX=B
C
C	   USAGE
C	      CALL SIMQ(A,B,N,KS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - MATRIX OF COEFFICIENTS STORED COLUMNWISE.  THESE ARE
C	          DESTROYED IN THE COMPUTATION.  THE SIZE OF MATRIX A IS
C	          N BY N.
C	      B - VECTOR OF ORIGINAL CONSTANTS (LENGTH N). THESE ARE
C	          REPLACED BY FINAL SOLUTION VALUES, VECTOR X.
C	      N - NUMBER OF EQUATIONS AND VARIABLES. N MUST BE .GT. ONE.
C	      KS - OUTPUT DIGIT
C	           0 FOR A NORMAL SOLUTION
C	           1 FOR A SINGULAR SET OF EQUATIONS
C
C	   REMARKS
C	      MATRIX A MUST BE GENERAL.
C	      IF MATRIX IS SINGULAR , SOLUTION VALUES ARE MEANINGLESS.
C	      AN ALTERNATIVE SOLUTION MAY BE OBTAINED BY USING MATRIX
C	      INVERSION (MINV) AND MATRIX PRODUCT (GMPRD).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      METHOD OF SOLUTION IS BY ELIMINATION USING LARGEST PIVOTAL
C	      DIVISOR. EACH STAGE OF ELIMINATION CONSISTS OF INTERCHANGING
C	      ROWS WHEN NECESSARY TO AVOID DIVISION BY ZERO OR SMALL
C	      ELEMENTS.
C	      THE FORWARD SOLUTION TO OBTAIN VARIABLE N IS DONE IN
C	      N STAGES. THE BACK SOLUTION FOR THE OTHER VARIABLES IS
C	      CALCULATED BY SUCCESSIVE SUBSTITUTIONS. FINAL SOLUTION
C	      VALUES ARE DEVELOPED IN VECTOR B, WITH VARIABLE 1 IN B(1),
C	      VARIABLE 2 IN B(2),........, VARIABLE N IN B(N).
C	      IF NO PIVOT CAN BE FOUND EXCEEDING A TOLERANCE OF 0.0,
C	      THE MATRIX IS CONSIDERED SINGULAR AND KS IS SET TO 1. THIS
C	      TOLERANCE CAN BE MODIFIED BY REPLACING THE FIRST STATEMENT.
C
C	..................................................................
C
	SUBROUTINE SIMQ(A,B,N,KS)
	DIMENSION A(1),B(1)
C
C	   FORWARD SOLUTION
C
	TOL=0.0
	KS=0
	JJ=-N
	DO 65 J=1,N
	JY=J+1
	JJ=JJ+N+1
	BIGA=0
	IT=JJ-J
	DO 30 I=J,N
C
C	   SEARCH FOR MAXIMUM COEFFICIENT IN COLUMN
C
	IJ=IT+I
	IF(ABS(BIGA)-ABS(A(IJ))) 20,30,30
20	BIGA=A(IJ)
	IMAX=I
30	CONTINUE
C
C	   TEST FOR PIVOT LESS THAN TOLERANCE (SINGULAR MATRIX)
C
	IF(ABS(BIGA)-TOL) 35,35,40
35	KS=1
	RETURN
C
C	   INTERCHANGE ROWS IF NECESSARY
C
40	I1=J+N*(J-2)
	IT=IMAX-J
	DO 50 K=J,N
	I1=I1+N
	I2=I1+IT
	SAVE=A(I1)
	A(I1)=A(I2)
	A(I2)=SAVE
C
C	   DIVIDE EQUATION BY LEADING COEFFICIENT
C
50	A(I1)=A(I1)/BIGA
	SAVE=B(IMAX)
	B(IMAX)=B(J)
	B(J)=SAVE/BIGA
C
C	   ELIMINATE NEXT VARIABLE
C
	IF(J-N) 55,70,55
55	IQS=N*(J-1)
	DO 65 IX=JY,N
	IXJ=IQS+IX
	IT=J-IX
	DO 60 JX=JY,N
	IXJX=N*(JX-1)+IX
	JJX=IXJX+IT
60	A(IXJX)=A(IXJX)-(A(IXJ)*A(JJX))
65	B(IX)=B(IX)-(B(J)*A(IXJ))
C
C	   BACK SOLUTION
C
70	NY=N-1
	IT=N*N
	DO 80 J=1,NY
	IA=IT-J
	IB=N-J
	IC=N
	DO 80 K=1,J
	B(IB)=B(IB)-A(IA)*B(IC)
	IA=IA-N
80	IC=IC-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SMO
C
C	   PURPOSE
C	      TO SMOOTH OR FILTER SERIES A BY WEIGHTS W.
C
C	   USAGE
C	      CALL SMO (A,N,W,M,L,R)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - INPUT VECTOR OF LENGTH N CONTAINING TIME SERIES DATA.
C	      N - LENGTH OF SERIES A.
C	      W - INPUT VECTOR OF LENGTH M CONTAINING WEIGHTS.
C	      M - NUMBER OF ITEMS IN WEIGHT VECTOR.  M MUST BE AN ODD
C	          INTEGER.  (IF M IS AN EVEN INTEGER, ANY FRACTION
C	          RESULTING FROM THE CALCULATION OF (L*(M-1))/2 IN (1)
C	          AND (2) BELOW WILL BE TRUNCATED.)
C	      L - SELECTION INTEGER.  FOR EXAMPLE, L=12 MEANS THAT WEIGHTS
C	          ARE APPLIED TO EVERY 12-TH ITEM OF A.  L=1 APPLIES
C	          WEIGHTS TO SUCCESSIVE ITEMS OF A.  FOR MONTHLY DATA,
C	          L=12 GIVES YEAR-TO-YEAR AVERAGES AND L=1 GIVES MONTH-TO-
C	          MONTH AVERAGES.
C	      R - OUTPUT VECTOR OF LENGTH N.  FROM IL TO IH ELEMENTS OF
C	          THE VECTOR R ARE FILLED WITH THE SMOOTHED SERIES AND
C	          OTHER ELEMENTS WITH ZERO, WHERE
C	               IL=(L*(M-1))/2+1  ................ (1)
C	               IH=N-(L*(M-1))/2  ................ (2)
C
C	   REMARKS
C	      N MUST BE GREATER THAN OR EQUAL TO THE PRODUCT OF L*M.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO THE ARTICLE 'FORTRAN SUBROUTINES FOR TIME SERIES
C	      ANALYSIS', BY J. R. HEALY AND B. P. BOGERT, COMMUNICATIONS
C	      OF ACM, V.6, NO.1, JANUARY, 1963.
C
C	..................................................................
C
	SUBROUTINE SMO (A,N,W,M,L,R)
	DIMENSION A(1),W(1),R(1)
C
C	INITIALIZATION
C
	DO 110 I=1,N
110	R(I)=0.0
	IL=(L*(M-1))/2+1
	IH=N-(L*(M-1))/2
C
C	SMOOTH SERIES A BY WEIGHTS W
C
	DO 120 I=IL,IH
	K=I-IL+1
	DO 120 J=1,M
	IP=(J*L)-L+K
120	R(I)=R(I)+A(IP)*W(J)
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE PROGRAM FOR REAL AND COMPLEX ROOTS OF A REAL POLY-
C	   NOMIAL - SMPRT
C
C	   PURPOSE
C	      COMPUTES THE REAL AND COMPLEX ROOTS OF A REAL POLYNOMIAL
C	      WHOSE COEFFICIENTS ARE INPUT.
C
C	   REMARKS
C	      THE ORDER OF THE POLYNOMIAL MUST BE GREATER THAN ONE AND
C	      LESS THAN THIRTY SEVEN
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      POLRT
C
C	   METHOD
C	      READS A CONTROL CARD CONTAINING THE IDENTIFICATION CODE AND
C	      THE ORDER OF THE POLYNOMIAL WHOSE COEFFICIENTS ARE
C	      CONTAINED ON THE FOLLOWING DATA CARDS. THE COEFFICIENTS
C	      ARE THEN READ AND THE ROOTS ARE COMPUTED.
C	      MORE THAN ONE CONTROL CARD AND CORRESPONDING DATA CAN BE
C	      PROCESSED. EXECUTION IS TERMINATED BY A BLANK CONTROL CARD.
C
C	..................................................................
C
	DIMENSION A(37),W(37),ROOTR(37),ROOTI(37)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION A,W,ROOTR,ROOTI
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
C	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
C	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
5	READ(5,10)ID,IORD
10	FORMAT(1X,I4,3X,I2)
	IF(ID+IORD)100,100,20
20	WRITE(6,30)ID,IORD
30	FORMAT(1H1,61HREAL AND COMPLEX ROOTS OF A POLYNOMIAL USING SUBROUT
     1INE POLRT///  17H FOR POLYNOMIAL  ,I4,2X,10HOF ORDER  ,I2//1H ,
     226HTHE INPUT COEFFICIENTS ARE,//)
	J=IORD+1
	READ(5,40)(A(I),I=1,J)
40	FORMAT(7F10.0)
	WRITE(6,50)(A(I),I=1,J)
50	FORMAT(6E16.7)
	CALL POLRT(A,W,IORD,ROOTR,ROOTI,IER)
	IF(IER-1)90,60,70
60	WRITE(6,65)
65	FORMAT(//1H ,33HORDER OF POLYNOMIAL LESS THAN ONE)
	GO TO 5
70	IF(IER-3)75,80,78
75	WRITE(6,77)
77	FORMAT(//1H ,35HORDER OF POLYNOMIAL GREATER THAN 36)
	GO TO 5
78	WRITE(6,79)
79	FORMAT(//1H ,31H HIGH ORDER COEFFICIENT IS ZERO)
	GO TO 5
80	WRITE(6,85)
85	FORMAT(//1H ,49HUNABLE TO DETERMINE ROOT. THOSE ALREADY FOUND ARE)
90	WRITE(6,95)
95	FORMAT(//1H ,5X,9HREAL ROOT,6X,12HCOMPLEX ROOT//)
	DO 96 I=1,IORD
96	WRITE(6,97)ROOTR(I),ROOTI(I)
97	FORMAT(1H ,2E16.7)
	GO TO 5
  100	STOP
	END
C
C     ..................................................................
C
C        SUBROUTINE SMPY
C
C        PURPOSE
C           MULTIPLY EACH ELEMENT OF A MATRIX BY A SCALAR TO FORM A
C           RESULTANT MATRIX
C
C        USAGE
C           CALL SMPY(A,C,R,N,M,MS)
C
C        DESCRIPTION OF PARAMETERS
C           A - NAME OF INPUT MATRIX
C           C - SCALAR
C           R - NAME OF OUTPUT MATRIX
C           N - NUMBER OF ROWS IN MATRIX A AND R
C           M - NUMBER OF COLUMNS IN MATRIX A AND R
C           MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C                  0 - GENERAL
C                  1 - SYMMETRIC
C                  2 - DIAGONAL
C
C        REMARKS
C           NONE
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           LOC
C
C        METHOD
C           SCALAR IS MULTIPLIED BY EACH ELEMENT OF MATRIX
C
C     ..................................................................
C
      SUBROUTINE SMPY(A,C,R,N,M,MS)
      DIMENSION A(1),R(1)
C
C        COMPUTE VECTOR LENGTH, IT
C
      CALL LOC(N,M,IT,N,M,MS)
C
C        MULTIPLY BY SCALAR
C
      DO 1 I=1,IT
    1 R(I)=A(I)*C
      RETURN
      END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM - SOLN
C
C	   PURPOSE
C	      SOLUTION OF A SET OF SIMULTANEOUS EQUATIONS
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      SIMQ
C	      MATIN
C	      MXOUT
C	      LOC
C
C	   METHOD
C	      A MATRIX OF SIMULTANEOUS EQUATIONS COEFFICIENTS AND A VECTOR
C	      OF CONSTANTS ARE READ FROM THE STANDARD INPUT DEVICE. THE
C	      SOLUTION IS OBTAINED AND LISTED ON THE STANDARD OUTPUT
C	      DEVICE. THIS PROCEDURE IS REPEATED FOR OTHER SETS OF
C	      EQUATIONS UNTIL A BLANK CARD IS ENCOUNTERED.
C
C	..................................................................
C
C	   MATRIX IS DIMENSIONED FOR 2500 ELEMENTS. THEREFORE, NUMBER OF
C	   EQUATIONS TO BE SOLVED CANNOT EXCEED 50 UNLESS DIMENSION
C	   STATEMENT IS CHANGED
cC
c	DIMENSION A(2500),B(50)
cC
c10	FORMAT(1H1,34HSOLUTION OF SIMULTANEOUS EQUATIONS)
c11	FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4)
c12	FORMAT(1H0,20HEXECUTION TERMINATED)
c13	FORMAT(1H0,47HROW AND COLUMN DIMENSIONS NOT EQUAL FOR MATRIX ,I4)
c14	FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4)
c15	FORMAT(1H0,18HGO ON TO NEXT CASE)
c16	FORMAT(1H0,38HSTRUCTURE CODE IS NOT ZERO FOR MATRIX ,I4)
c17	FORMAT(1H1,17HORIGINAL B VECTOR,////)
c18	FORMAT(1H1,15HSOLUTION VALUES,////)
c19	FORMAT(1H0,18HMATRIX IS SINGULAR)
c20	FORMAT(7F10.0)
c21	FORMAT(I3,10X,E16.6)
c22	FORMAT(1H0,11HEND OF CASE)
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
cC	..................................................................
cC
c	WRITE (6,10)
c25	CALL MATIN(ICOD,A,2500,N,M,MS,IER)
c	IF(N) 30,95,30
c30	IF(IER-1) 45,35,40
c35	WRITE(6,11) ICOD
c	GO TO 90
c40	WRITE(6,14) ICOD
c	GO TO 95
c45	IF(N-M) 50,55,50
c50	WRITE(6,13) ICOD
c	GO TO 90
c55	IF(MS) 60,65,60
c60	WRITE(6,16) ICOD
c	GO TO 90
c65	CALL MXOUT(ICOD,A,N,M,MS,60,120,2)
c	READ(5,20)(B(I),I=1,N)
c	WRITE(6,17)
c	DO 70 I=1,N
c70	WRITE(6,21) I,B(I)
c	CALL SIMQ(A,B,N,KS)
c	IF(KS-1) 80,75,80
c75	WRITE(6,19)
c	WRITE(6,15)
c	GO TO 25
c80	WRITE(6,18)
c	DO 85 I=1,N
c85	WRITE(6,21) I,B(I)
c	WRITE(6,22)
c	GO TO 25
c90	READ(5,20)(B(I),I=1,N)
c	WRITE(6,15)
c	GO TO 25
c95	WRITE(6,12)
c	STOP
c	END
C
C	..................................................................
C
C	   SUBROUTINE SRANK
C
C	   PURPOSE
C	      TEST CORRELATION BETWEEN TWO VARIABLES BY MEANS OF SPEARMAN
C	      RANK CORRELATION COEFFICIENT
C
C	   USAGE
C	      CALL SRANK(A,B,R,N,RS,T,NDF,NR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - INPUT VECTOR OF N OBSERVATIONS FOR FIRST VARIABLE
C	      B   - INPUT VECTOR OF N OBSERVATIONS FOR SECOND VARIABLE
C	      R   - OUTPUT VECTOR FOR RANKED DATA, LENGTH IS 2*N. SMALLEST
C	            OBSERVATION IS RANKED 1, LARGEST IS RANKED N. TIES
C	            ARE ASSIGNED AVERAGE OF TIED RANKS.
C	      N   - NUMBER OF OBSERVATIONS
C	      RS  - SPEARMAN RANK CORRELATION COEFFICIENT (OUTPUT)
C	      T   - TEST OF SIGNIFICANCE OF RS (OUTPUT)
C	      NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT)
C	      NR  - CODE, 0 FOR UNRANKED DATA IN A AND B, 1 FOR RANKED
C	            DATA IN A AND B (INPUT)
C
C	   REMARKS
C	      T IS SET TO ZERO IF N IS LESS THAN TEN
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANK
C	      TIE
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 9
C
C	..................................................................
C
	SUBROUTINE SRANK(A,B,R,N,RS,T,NDF,NR)
	DIMENSION A(1),B(1),R(1)
C
	FNNN=N*N*N-N
C
C	   DETERMINE WHETHER DATA IS RANKED
C
	IF(NR-1) 5, 10, 5
C
C	   RANK DATA IN A AND B VECTORS AND ASSIGN TIED OBSERVATIONS
C	   AVERAGE OF TIED RANKS
C
5	CALL RANK (A,R,N)
	CALL RANK (B,R(N+1),N)
	GO TO 40
C
C	   MOVE RANKED DATA TO R VECTOR
C
10	DO 20 I=1,N
20	R(I)=A(I)
	DO 30 I=1,N
	J=I+N
30	R(J)=B(I)
C
C	   COMPUTE SUM OF SQUARES OF RANK DIFFERENCES
C
40	D=0.0
	DO 50 I=1,N
	J=I+N
50	D=D+(R(I)-R(J))*(R(I)-R(J))
C
C	   COMPUTE TIED SCORE INDEX
C
	KT=1
	CALL TIE (R,N,KT,TSA)
	CALL TIE (R(N+1),N,KT,TSB)
C
C	   COMPUTE SPEARMAN RANK CORRELATION COEFFICIENT
C
	IF(TSA) 60,55,60
55	IF(TSB) 60,57,60
57	RS=1.0-6.0*D/FNNN
	GO TO 70
60	X=FNNN/12.0-TSA
	Y=X+TSA-TSB
	RS=(X+Y-D)/(2.0*(SQRT(X*Y)))
C
C	   COMPUTE T AND DEGREES OF FREEDOM IF N IS 10 OR LARGER
C
	T=0.0
70	IF(N-10) 80,75,75
75	T=RS*SQRT(FLOAT(N-2)/(1.0-RS*RS))
80	NDF=N-2
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SRATE
C
C	   PURPOSE
C	      TO COMPUTE THE PROPORTION OF SUBJECTS SURVIVING, THE
C	      SURVIVAL RATES AND THE STANDARD ERRORS FOR SUCCESSIVELY
C	      REDUCED TIME PERIODS.  THE SURVIVAL RATE IS COMPUTED FOR
C	      EACH OF K PERIODS, WHERE K IS A CONSTANT TO BE SPECIFIED AND
C	      IS LESS THAN OR EQUAL TO N (WHERE N = TOTAL NUMBER OF
C	      PERIODS).
C
C	   USAGE
C	      CALL SRATE (N,K,X,IE)
C
C	   DESCRIPTION OF PARAMETERS
C	      N - THE TOTAL NUMBER OF PERIODS AFTER TREATMENT OR DIAGNOSIS
C	      K - THE SPECIFIED PERIOD UP TO WHICH SURVIVAL RATES ARE TO
C	          BE CALCULATED
C	      X - AN INPUT AND OUTPUT MATRIX (N X 9) CONTAINING THE
C	          FOLLOWING INFORMATION
C	          FOR INPUT--STORED IN THE N ROWS OF EACH COLUMN
C	             COL 1 - NUMBER OF SUBJECTS ALIVE AT THE BEGINNING OF
C	                     PERIOD
C	             COL 2 - NUMBER OF SUBJECTS WHICH DIED DURING THE
C	                     PERIOD
C	             COL 3 - NUMBER OF SUBJECTS LOST TO FOLLOW-UP DURING
C	                     THE PERIOD
C	             COL 4 - NUMBER OF SUBJECTS WITHDRAWN ALIVE DURING THE
C	                     PERIOD
C	               FOR OUTPUT--STORED IN THE FIRST K ROWS OF EACH
C	               COLUMN
C	             COL 5 - EFFECTIVE NUMBER EXPOSED TO THE RISK OF DYING
C	             COL 6 - PROPORTION WHO DIED DURING THE PERIOD
C	             COL 7 - PROPORTION WHO SURVIVED DURING THE PERIOD
C	             COL 8 - SURVIAL RATE
C	             COL 9 - STANDARD ERROR OF THE SURVIVAL RATE
C	      IE- 1, IF K IS NOT IN THE CLOSED INTERVAL (0,N).
C	          2, IF THE NUMBER OF SUBJECTS ALIVE AT THE BEGINNING
C	          OF PERIOD I IS LESS THAN THE SUM OF THOSE WHICH DIED,
C	          WERE LOST, OR WERE WITHDRAWN DURING PERIOD I (I=1,...N)
C	          3, IF THE NUMBER OF SUBJECTS WHICH DIED, WERE LOST, OR
C	          WERE WITHDRAWN IN PERIOD I IS NOT EQUAL TO THE NUMBER
C	          ALIVE AT THE BEGINNING OF PERIOD I LESS THE NUMBER
C	          ALIVE AT THE BEGINNING OF PERIOD I + 1 (I=1,...N-1)
C
C	   REMARKS
C	      IF THE SUBJECTS IN A GIVEN GROUP ARE ALL DIAGNOSED OR
C	      TREATED AT THE SAME TIME, THE CONSTANT K MAY BE SET EQUAL TO
C	      N .  IF THE SUBJECTS IN A GIVEN GOUP ENTER THE STUDY AT
C	      VARYING TIMES, K CAN BE NO GREATER THAN N-1.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO S. J. CUTLER AND F. EDERER 'MAXIMUM UTILIZATION OF
C	      THE LIFE TABLE METHOD IN ANALYZING SURVIVAL', JOURNAL OF
C	      CHRONIC DISEASES, DECEMBER, 1958.  PP 699-712.
C
C	..................................................................
C
	SUBROUTINE SRATE (N,K,X,IE)
C
	DIMENSION X(1)
C
C	   INITIALIZATION AND ERROR CHECKING
C
	IE=0
	NP4=4*N+1
	NP9=NP4+NP4+N-2
	DO 1 I=NP4,NP9
1	X(I)=0.0
	IF (K) 2,2,3
2	IE=1
	GO TO 45
3	IF(K-N) 4,4,2
4	DO 9 I=1,N
	NP4=I+N
	NP9=NP4+N
	NP1=NP9+N
	IF(INT(X(I)-X(NP4)-X(NP9)-X(NP1)+.01)) 5,6,6
5	IE=2
	GO TO 45
6	IF(I-N) 7,9,9
7	IF (INT(X(I+1)-X(I)+X(NP4)+X(NP9)+X(NP1)+.01)) 8,9,8
8	IE=3
	  GO TO 45
9	CONTINUE
15	L1=0
	L2=L1+N
	L3=L2+N
	L4=L3+N
	L5=L4+N
	L6=L5+N
	L7=L6+N
	L8=L7+N
	L9=L8+N
	LD=L2
	LE=L5
	LQ=L6
	SUM=0.0
C
	DO 40 I=1,K
C
C	   COMPUTE EFFECTIVE NUMBER EXPOSED TO RISK OF DYING
C
	L1=L1+1
	L3=L3+1
	L4=L4+1
	L5=L5+1
	X(L5)=X(L1)-(X(L3)+X(L4))/2.0
C
C	   COMPUTE PROPORTION OF DYING
C
	L2=L2+1
	L6=L6+1
	X(L6)=X(L2)/X(L5)
C
C	   COMPUTE PROPORTION OF SURVIVING
C
	L7=L7+1
	X(L7)=1.0-X(L6)
C
C	   COMPUTE SURVIVAL RATE
C
	L8=L8+1
	IF (I-1) 20, 20, 25
20	X(L8)=X(L7)
	GO TO 30
25	X(L8)=X(L8-1)*X(L7)
C
C	   COMPUTE STANDARD ERROR OF SURVIVAL RATE
C
30	L9=L9+1
	SUM=SUM+X(L6)/(X(L5)-X(L2))
40	X(L9)=X(L8)*SQRT(SUM)
C
45	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SRMA
C
C	   PURPOSE
C	      MULTIPLY ROW OF MATRIX BY A SCALAR AND ADD TO ANOTHER ROW
C	      OF THE SAME MATRIX
C
C	   USAGE
C	      CALL SRMA(A,C,N,M,LA,LB)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - NAME OF MATRIX
C	      C  - SCALAR
C	      N  - NUMBER OF ROWS IN A
C	      M  - NUMBER OF COLUMNS IN A
C	      LA - ROW IN A TO BE MULTIPLIED BY SCALAR
C	      LB - ROW IN A TO WHICH PRODUCT IS ADDED
C	           IF 0 IS SPECIFIED, PRODUCT REPLACES ELEMENTS IN ROW LA
C
C	   REMARKS
C	      MATRIX A MUST BE A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EACH ELEMENT OF ROW LA IS MULTIPLIED BY SCALAR C AND THE
C	      PRODUCT IS ADDED TO THE CORRESPONDING ELEMENT OF ROW LB.
C	      ROW LA REMAINS UNAFFECTED BY THE OPERATION.
C	      IF PARAMETER LB CONTAINS ZERO, MULTIPLICATION BY THE SCALAR
C	      IS PERFORMED AND THE PRODUCT REPLACES ELEMENTS IN ROW LA.
C
C	..................................................................
C
	SUBROUTINE SRMA(A,C,N,M,LA,LB)
	DIMENSION A(1)
C
	LAJ=LA-N
	LBJ=LB-N
	DO 3 J=1,M
C
C	   LOCATE ELEMENT IN BOTH ROWS
C
	LAJ=LAJ+N
	LBJ=LBJ+N
C
C	   CHECK LB FOR ZERO
C
	IF(LB) 1,2,1
C
C	   IF NOT, MULTIPLY BY CONSTANT AND ADD TO OTHER ROW
C
1	A(LBJ)=A(LAJ)*C+A(LBJ)
	GO TO 3
C
C	   OTHERWISE, MULTIPLY ROW BY CONSTANT
C
2	A(LAJ)=A(LAJ)*C
3	CONTINUE
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SSUB
C
C	   PURPOSE
C	      SUBTRACT A SCALAR FROM EACH ELEMENT OF A MATRIX TO FORM A
C	      RESULTANT MATRIX
C
C	   USAGE
C	      CALL SSUB(A,C,R,N,M,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF INPUT MATRIX
C	      C - SCALAR
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN MATRIX A AND R
C	      M - NUMBER OF COLUMNS IN MATRIX A AND R
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R)
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      SCALAR IS SUBTRACTED FROM EACH EACH ELEMENT OF MATRIX
C
C	..................................................................
C
	SUBROUTINE SSUB(A,C,R,N,M,MS)
	DIMENSION A(1),R(1)
C
C	   COMPUTE VECTOR LENGTH, IT
C
	CALL LOC(N,M,IT,N,M,MS)
C
C	   SUBTRACT SCALAR
C
	DO 1 I=1,IT
1	R(I)=A(I)-C
	RETURN
	END
C
C	..................................................................
C
C	   SAMPLE MAIN PROGRAM FOR STEP-WISE MULTIPLE REGRESSION - STEPR
C
C	   PURPOSE
C	      (1) READ THE PROBLEM PARAMETER CARD FOR A STEP-WISE MULTIPLE
C	      REGRESSION, (2) READ SUBSET SELECTION CARDS, (3) CALL THE
C	      SUBROUTINE TO CALCULATE MEANS, STANDARD DEVIATIONS, SIMPLE
C	      CORRELATION COEFFICIENTS, AND (4) CALL THE SUBROUTINE TO
C	      PERFORM EACH STEP OF REGRESSION ANALYSIS.
C
C	   REMARKS
C	       THE NUMBER OF OBSERVATIONS, N, MUST BE GREATER THAN M+2,
C	      WHERE M IS THE NUMBER OF VARIABLES.  IF SELECTION CARDS ARE
C	      NOT PRESENT, THIS PROGRAM CAN NOT PERFORM STEP-WISE MULTIPLE
C	      REGRESSION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      CORRE (WHICH, IN TURN, CALLS THE SUBROUTINE DATA)
C	      MSTR  (WHICH, IN TURN, CALLS THE SUBROUTINE LOC)
C	      STPRG (WHICH, IN TURN, CALLS THE SUBROUTINE STOUT)
C
C	   METHOD
C	      REFER TO C. A. BENNETT AND N. L. FRANKLIN, 'STATISTICAL
C	      ANALYSIS IN CHEMISTRY AND THE CHEMICAL INDUSTRY', JOHN WILEY
C	      AND SONS, 1954, APPENDIX 6A.
C
C	..................................................................
C
C	THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE
C	NUMBER OF VARIABLES, M..
cC
c	   DIMENSION XBAR(35),STD(35),D(35),B(35),T(35),IDX(35),L(35)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	PRODUCT OF M*M..
cC
c	   DIMENSION RX(1225)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
cC	(M+1)*M/2..
cC
c	   DIMENSION R(630)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 5..
cC
c	   DIMENSION NSTEP(5)
cC
cC	THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 11..
cC
c	   DIMENSION ANS(11)
cC
cC	..................................................................
cC
cC	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
cC	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
cC	   STATEMENT WHICH FOLLOWS.
cC
cC	DOUBLE PRECISION XBAR,STD,RX,R,B,T,ANS,YEST
cC
cC	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
cC	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
cC	   ROUTINE.
cC
cC	..................................................................
cC
c1	FORMAT(A4,A2,I5,2I2,F6.0,I1)
c2	FORMAT(53H0NUMBER OF SELECTIONS NOT SPECIFIED.  JOB TERMINATED.)
c3	FORMAT(35H1STEP-WISE MULTIPLE REGRESSION.....A4,A2)
c4	FORMAT(31H0VARIABLE     MEAN     STANDARD/4X,3HN0.16X,9HDEVIATION)
c5	FORMAT(4X,I2,F14.5,F12.5)
c6	FORMAT(19H1CORRELATION MATRIX)
c7	FORMAT(4H0ROWI3/(10F12.5))
c8	FORMAT(72I1)
c9	FORMAT(23H0NUMBER OF OBSERVATIONSI5)
c10	FORMAT(20H NUMBER OF VARIABLES3X,I5)
c11	FORMAT(21H NUMBER OF SELECTIONS2X,I5)
c12	FORMAT(28H0CONSTANT TO LIMIT VARIABLESF9.5)
c13	FORMAT(/15H1SELECTION.....I2)
c14	FORMAT(16X,18HTABLE OF RESIDUALS//9H CASE NO.5X,7HY VALUE5X,10HY E
c     1STIMATE6X,8HRESIDUAL)
c15	FORMAT(I7,F15.5,2F14.5)
c16	FORMAT(1H )
c17	FORMAT(1H1)
c18	FORMAT(1H0,'****COLUMN',I4,' OF SELECTION CARD',I5,' IS IN ERROR.
c     1 IT IS POSSIBLE THAT COLUMNS SUCCEEDING THAT COLUMN ARE ALSO'
c     2/' INCORRECT.  THE SELECTION IS IGNORED.****')
c19	FORMAT(1H0,'****SELECTION CARD',I5,' DOES NOT NAME ONE AND ONLY ON
c     1E DEPENDENT VARIABLE.  SELECTION IGNORED.****')
c20	FORMAT(1H0,'****EITHER THE MATRIX IS SINGULAR, OR THE RESIDUAL SUM
c     1 OF SQUARES IS NEGATIVE IMPLYING EXTREME ILL CONDITION.',/,' SELEC
c     2TION IGNORED.****')
c21	FORMAT(1H0,'****',I6,' OBSERVATIONS ARE TOO FEW TO ALLOW PARAMETER'
c     1 'ESTIMATION FOR',I5,' VARIABLES.  JOB TERMINATED.****')
cC	DOUBLE PRECISION TMPFIL,FILE
cC	OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC	OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC	FILE = TMPFIL('SSP')
cC	OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT',
cC	1	DISPOSE='DELETE')
cC
cC	   READ PROBLEM PARAMETER CARD
cC
c	LOGICAL EOF
c	CALL CHKEOF (EOF)
c100	READ (5,1) PR1,PR2,N,M,NS,PCT,NR
c	IF (EOF) GOTO 999
cC	   PR1.....PROBLEM CODE (MAY BE ALPHAMERIC)
cC	   PR2.....PROBLEM CODE (CONTINUED)
cC	   N ......NUMBER OF OBSERVATIONS
cC	   M ......NUMBER OF VARIABLES
cC	   NS......NUMBER OF SELECTIONS
cC	   PCT.....A CONSTANT VALUE OF PROPORTION OF SUM OF SQUARES THAT
cC	           WILL BE USED TO LIMIT VARIABLES ENTERING IN THE REGRES-
cC	           SION
cC	   NR......OPTION CODE FOR TABLE OF RESIDUALS
cC	             0 - IF IT IS NOT DESIRED
cC	             1 - IF IT IS DESIRED
cC
c	WRITE (6,3) PR1,PR2
c	WRITE (6,9) N
c	WRITE (6,10) M
c	IF(N-M-2) 101,101,102
c101	WRITE(6,21) N,M
c	STOP
c102	WRITE (6,11) NS
c	WRITE (6,12) PCT
cC
cC	LOGICAL TAPE 9 IS USED AS INTERMEDIATE STORAGE TO HOLD INPUT
cC	DATA.  THE INPUT DATA ARE WRITTEN ON LOGICAL TAPE 9 BY THE
cC	SPECIAL INPUT SUBROUTINE NAMED DATA.  THE STORED DATA MAY BE USED
cC	FOR RESIDUAL ANALYSIS.
cC
c	REWIND 9
cC
c	IO=0
c	X=0.0
cC
c	CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T)
cC
c	REWIND 9
cC
cC	   PRINT MEANS AND STANDARD DEVIATION
cC
c	WRITE (6,4)
c	DO 105 I=1,M
c105	WRITE (6,5) I,XBAR(I),STD(I)
cC
cC	   PRINT CORRELATION MATRIX
cC
c	WRITE (6,6)
c	DO 130 I=1,M
c	DO 125 J=1,M
c	IF(I-J) 110, 120, 120
c110	K=I+(J*J-J)/2
c	GO TO 125
c120	K=J+(I*I-I)/2
c125	T(J)=R(K)
c130	WRITE (6,7) I,(T(J),J=1,M)
cC
cC	   TEST NUMBER OF SELECTIONS
cC
c	IF(NS) 135, 135, 140
c135	WRITE (6,2)
c	GO TO 200
cC
cC	   SAVE THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS
cC
c140	CALL MSTR (RX,R,M,0,1)
cC
c	NSEL=1
c	GO TO 150
cC
cC	   COPY THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS
cC
c145	CALL MSTR (R,RX,M,1,0)
cC
cC	   READ A SELECTION CARD
cC
c150	WRITE (6,13) NSEL
c	READ (5,8) (IDX(J),J=1,M)
cC
cC	   IN EACH POSITION OF IDX, ONE OF THE FOLLOWING CODES MUST BE
cC	   SPECIFIED..
cC	     0 OR BLANK - INDEPENDENT VARIABLE AVAILABLE FOR SELECTION
cC	     1          - INDEPENDENT VARIABLE TO BE FORCED IN REGRESSION
cC	     2          - VARIABLE TO BE DELETED
cC	     3          - DEPENDENT VARIABLE
cC
c	N35=0
c	DO 155 K=1,M
c	IF (IDX(K)) 152,153,153
c152	WRITE (6,18) K,NSEL
c	GO TO 185
c153	IF (IDX(K)-3) 155,154,152
c154	N35=N35+1
c155	CONTINUE
c	IF (N35-1) 156,157,156
c156	WRITE (6,19) NSEL
c	GO TO 185
cC	   CALL THE SUBROUTINE TO PERFORM A STEP-WISE REGRESSION ANALYSIS
cC
c157	CALL STPRG (M,N,RX,XBAR,IDX,PCT,NSTEP,ANS,L,B,STD,T,D,IER)
c	IF (IER) 158,159,158
c158	WRITE (6,20)
c	GO TO 185
cC
cC	   FIND WHETHER TO PRINT THE TABLE OF RESIDUALS
cC
c159	IF(NR) 185, 185, 160
cC
cC	   PRINT THE TABLE OF RESIDUALS
cC
cC
c160	WRITE (6,13) NSEL
c	WRITE (6,16)
c	WRITE (6,14)
c	MM=NSTEP(1)
c	DO 180 I=1,N
c	READ (9) (D(J),J=1,M)
c	YEST=ANS(9)
c	K=NSTEP(4)
c	DO 170 J=1,K
c	KK=L(J)
c170	YEST=YEST+B(J)*D(KK)
c	RESI=D(MM)-YEST
c180	WRITE (6,15) I,D(MM),YEST,RESI
c	REWIND 9
cC
cC	   TEST TO SEE WHETHER ALL SELECTIONS ARE COMPLETED
cC
c185	IF(NSEL-NS) 190, 100, 100
c190	NSEL=NSEL+1
c	WRITE (6,17)
c	GO TO 145
cC
c200	CONTINUE
c999	STOP
c	END
C
C	..................................................................
C
C	   SAMPLE OUTPUT SUBROUTINE STOUT
C
C	   PURPOSE
C	      PRINT THE RESULT OF A STEP-WISE MULTIPLE REGRESSION.  THIS
C	      SUBROUTINE IS CALLED BY THE SUBROUTINE STPRG.
C
C	   USAGE
C	      CALL STOUT (NSTEP,ANS,L,B,S,T,NSTOP)
C
C	   DESCRIPTION OF PARAMETERS
C	      NSTEP - INPUT VECTOR OF LENGTH 5 CONTAINING THE FOLLOWING
C	              INFORMATION..
C	                NSTEP(1)  DEPENDENT VARIABLE
C	                NSTEP(2)  NUMBER OF VARIABLES FORCED TO ENTER
C	                          IN THE REGRESSION
C	                NSTEP(3)  NUMBER OF VARIABLES DELETED
C	                NSTEP(4)  THE LAST STEP NUMBER
C	                NSTEP(5)  THE LAST VARIABLE ENTERED
C	      ANS   - INPUT VECTOR OF LENGTH 11 CONTAINING THE FOLLOWING
C	              INFORMATION FOR THE LAST STEP..
C	                ANS(1)  SUM OF SQUARES REDUCED
C	                ANS(2)  PROPORTION REDUCED
C	                ANS(3)  CUMULATIVE SUM OF SQUARES REDUCED
C	                ANS(4)  CUMULATIVE PROPORTION REDUCED
C	                ANS(5)  SUM OF SQUARES OF THE DEPENDENT VARIABLE
C	                ANS(6)  MULTIPLE CORRELATION COEFFICIENT
C	                ANS(7)  F-VALUE FOR ANALYSIS VARIANCE (FOR THE
C	                        REGRESSION)
C	                ANS(8)  STANDARD ERROR OF ESTIMATE
C	                ANS(9)  INTERCEPT
C	                ANS(10) ADJUSTED MULTIPLE R
C	                ANS(11) ADJUSTED STANDARD ERROR OF ESTIMATE
C	      L     - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN-
C	              ING VARIABLES ENTERED IN THE REGRESSION.  L(1)=FIRST
C	              VARIABLE ENTERED, L(2)=SECOND VARIABLE ENTERED, ETC.
C	      B     - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN-
C	              ING REGRESSION COEFFICIENTS CORRESPONDING TO THE
C	              VARIABLES IN VECTOR L
C	      S     - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN-
C	              ING STANDARD ERRORS OF REGRESSION COEFFICIENTS
C	              CORRESPONDING TO THE VARIABLES IN VECTOR L
C	      T     - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN-
C	              ING COMPUTED T-VALUES CORRESPONDING TO THE VARIABLES
C	              IN VECTOR L
C	      NSTOP - OUTPUT OPTION CODE TO STOP THE STEP-WISE REGRESSION
C	                1 - IF THE STEP-WISE REGRESSION IS TO BE TERMI-
C	                    NATED BY SOME CRITERIA OTHER THAN PROPORTION
C	                    OF SUM OF SQUARES, SUCH AS F-TEST AND SO ON,
C	                    THIS SUBROUTINE MAY BE MODIFIED TO PERFORM
C	                    DESIRED TESTS.  WHEN IT BECOMES NO LONGER
C	                    NECESSARY TO CONTINUE THE STEP-WISE REGRES-
C	                    SION, SET NSTOP EQUAL TO 1.
C	                0 - IF THE STEP-WISE REGRESSION IS TO BE CONTINUED
C
C	   REMARKS
C	      THE CONTENTS OF THE VECTORS NSTEP, ANS, L ARE REQUIRED IN
C	      SUBSEQUENT STEPS AND MUST NOT BE DESTROYED.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C
C	..................................................................
C
	SUBROUTINE STOUT (NSTEP,ANS,L,B,S,T,NSTOP)
C
	DIMENSION NSTEP(1),ANS(1),L(1),B(1),S(1),T(1)
C
C	..................................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION ANS,B,S,T
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	..................................................................
C
1	FORMAT(/5H1STEPI3)
2	FORMAT(22H0VARIABLE ENTERED.....I2)
3	FORMAT(40H0SUM OF SQUARES REDUCED IN THIS STEP....F13.3)
4	FORMAT(40H PROPORTION REDUCED IN THIS STEP........F13.3)
5	FORMAT(40H0CUMULATIVE SUM OF SQUARES REDUCED......F13.3)
6	FORMAT(40H CUMULATIVE PROPORTION REDUCED..........F13.3,4H  OFF13.
     13)
7	FORMAT(4H0FORI3,18H VARIABLES ENTERED)
8	FORMAT(38H   MULTIPLE CORRELATION COEFFICIENT...F9.3)
9	FORMAT(38H   F-VALUE FOR ANALYSIS OF VARIANCE...F9.3)
10	FORMAT(38H   STANDARD ERROR OF ESTIMATE.........F9.3)
11	FORMAT(/57H   VARIABLE     REGRESSION     STD. ERROR OF     COMPUT
     1ED/56H    NUMBER      COEFFICIENT     REG. COEFF.      T-VALUE)
12	FORMAT(5X,I3,F18.5,F16.5,F14.3)
13	FORMAT(12H   INTERCEPTF14.5)
14	FORMAT(31H0DEPENDENT VARIABLE............I2)
15	FORMAT(31H NUMBER OF VARIABLES FORCED....I2)
16	FORMAT(31H NUMBER OF VARIABLES DELETED...I2)
17	FORMAT(20H   (FORCED VARIABLE))
18	FORMAT(38H        (ADJUSTED FOR D.F.)...........F9.3)
C
C	   TEST WHETHER THIS IS THE FIRST STEP
C
	IF(NSTEP(4)-1) 30, 30, 35
30	WRITE (6,14) NSTEP(1)
	WRITE (6,15) NSTEP(2)
	WRITE (6,16) NSTEP(3)
C
C	   PRINT THE RESULT OF A STEP
C
35	WRITE (6,1) NSTEP(4)
	WRITE (6,2) NSTEP(5)
	IF(NSTEP(4)-NSTEP(2)) 37, 37, 38
37	WRITE (6,17)
38	WRITE (6,3) ANS(1)
	WRITE (6,4) ANS(2)
	WRITE (6,5) ANS(3)
	WRITE (6,6) ANS(4), ANS(5)
	WRITE (6,7) NSTEP(4)
	WRITE (6,8) ANS(6)
	WRITE(6,18)ANS(10)
	WRITE (6,9) ANS(7)
	WRITE (6,10) ANS(8)
	WRITE(6,18)ANS(11)
	WRITE (6,11)
	N=NSTEP(4)
	DO 40 I=1,N
40	WRITE (6,12) L(I),B(I),S(I),T(I)
	WRITE (6,13) ANS(9)
C
	NSTOP=0
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE STPRG
C
C	   PURPOSE
C	      TO PERFORM A STEPWISE MULTIPLE REGRESSION ANALYSIS FOR A
C	      DEPENDENT VARIABLE AND A SET OF INDEPENDENT VARIABLES.  AT
C	      EACH STEP, THE VARIABLE ENTERED INTO THE REGRESSION EQUATION
C	      IS THAT WHICH EXPLAINS THE GREATEST AMOUNT OF VARIANCE
C	      BETWEEN IT AND THE DEPENDENT VARIABLE (I.E. THE VARIABLE
C	      WITH THE HIGHEST PARTIAL CORRELATION WITH THE DEPENDENT
C	      VARIABLE).  ANY VARIABLE CAN BE DESIGNATED AS THE DEPENDENT
C	      VARIABLE.  ANY INDEPENDENT VARIABLE CAN BE FORCED INTO OR
C	      DELETED FROM THE REGRESSION EQUATION, IRRESPECTIVE OF ITS
C	      CONTRIBUTION TO THE EQUATION.
C
C	   USAGE
C	      CALL STPRG (M,N,D,XBAR,IDX,PCT,NSTEP,ANS,L,B,S,T,LL,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      M    - TOTAL NUMBER OF VARIABLES IN DATA MATRIX
C	      N    - NUMBER OF OBSERVATIONS
C	      D    - INPUT MATRIX (M X M) OF SUMS OF CROSS-PRODUCTS OF
C	             DEVIATIONS FROM MEAN.  THIS MATRIX WILL BE DESTROYED.
C	      XBAR - INPUT VECTOR OF LENGTH M OF MEANS
C	      IDX  - INPUT VECTOR OF LENGTH M HAVING ONE OF THE FOLLOWING
C	             CODES FOR EACH VARIABLE.
C	               0 - INDEPENDENT VARIABLE AVAILABLE FOR SELECTION
C	               1 - INDEPENDENT VARIABLE TO BE FORCED INTO THE
C	                   REGRESSION EQUATION
C	               2 - VARIABLE NOT TO BE CONSIDERED IN THE EQUATION
C	               3 - DEPENDENT VARIABLE
C	             THIS VECTOR WILL BE DESTROYED
C	      PCT  - A CONSTANT VALUE INDICATING THE PROPORTION OF THE
C	             TOTAL VARIANCE TO BE EXPLAINED BY ANY INDEPENDENT
C	             VARIABLE.  THOSE INDEPENDENT VARIABLES WHICH FALL
C	             BELOW THIS PROPORTION WILL NOT ENTER THE REGRESSION
C	             EQUATION.  TO ENSURE THAT ALL VARIABLES ENTER THE
C	             EQUATION, SET PCT = 0.0.
C	      NSTEP- OUTPUT VECTOR OF LENGTH 5 CONTAINING THE FOLLOWING
C	             INFORMATION
C	                NSTEP(1)- THE NUMBER OF THE DEPENDENT VARIABLE
C	                NSTEP(2)- NUMBER OF VARIABLES FORCED INTO THE
C	                          REGRESSION EQUATION
C	                NSTEP(3)- NUMBER OF VARIABLE DELETED FROM THE
C	                          EQUATION
C	                NSTEP(4)- THE NUMBER OF THE LAST STEP
C	                NSTEP(5)- THE NUMBER OF THE LAST VARIABLE ENTERED
C	      ANS  - OUTPUT VECTOR OF LENGTH 11 CONTAINING THE FOLLOWING
C	             INFORMATION FOR THE LAST STEP
C	                ANS(1)- SUM OF SQUARES REDUCED BY THIS STEP
C	                ANS(2)- PROPORTION OF TOTAL SUM OF SQUARES REDUCED
C	                ANS(3)- CUMULATIVE SUM OF SQUARES REDUCED UP TO
C	                        THIS STEP
C	                ANS(4)- CUMULATIVE PROPORTION OF TOTAL SUM OF
C	                        SQUARES REDUCED
C	                ANS(5)- SUM OF SQUARES OF THE DEPENDENT VARIABLE
C	                ANS(6)- MULTIPLE CORRELATION COEFFICIENT
C	                ANS(7)- F RATIO FOR SUM OF SQUARES DUE TO
C	                        REGRESSION
C	                ANS(8)- STANDARD ERROR OF THE ESTIMATE (RESIDUAL
C	                        MEAN SQUARE)
C	                ANS(9)- INTERCEPT CONSTANT
C	                ANS(10)-MULTIPLE CORRELATION COEFFICIENT ADJUSTED
C	                        FOR DEGREES OF FREEDOM.
C	                ANS(11)-STANDARD ERROR OF THE ESTIMATE ADJUSTED
C	                        FOR DEGREES OF FREEDOM.
C	      L    - OUTPUT VECTOR OF LENGTH K, WHERE K IS THE NUMBER OF
C	             INDEPENDENT VARIABLES IN THE REGRESSION EQUATION.
C	             THIS VECTOR CONTAINS THE NUMBERS OF THE INDEPENDENT
C	             VARIABLES IN THE EQUATION.
C	      B    - OUTPUT VECTOR OF LENGTH K, CONTAINING THE PARTIAL
C	             REGRESSION COEFFICIENTS CORRESPONDING TO THE
C	             VARIABLES IN VECTOR L.
C	      S    - OUTPUT VECTOR OF LENGTH K, CONTAINING THE STANDARD
C	             ERRORS OF THE PARTIAL REGRESSION COEFFICIENTS,
C	             CORRESPONDING TO THE VARIABLES IN VECTOR L.
C	      T    - OUTPUT VECTOR OF LENGTH K, CONTAINING THE COMPUTED
C	             T-VALUES CORRESPONDING TO THE VARIABLES IN VECTOR L.
C	      LL   - WORKING VECTOR OF LENGTH M
C	      IER  - 0, IF THERE IS NO ERROR.
C	             1, IF RESIDUAL SUM OF SQUARES IS NEGATIVE OR IF THE
C	             PIVOTAL ELEMENT IN THE STEPWISE INVERSION PROCESS IS
C	             ZERO.  IN THIS CASE, THE VARIABLE WHICH CAUSES THIS
C	             ERROR IS NOT ENTERED IN THE REGRESSION, THE RESULT
C	             PRIOR TO THIS STEP IS RETAINED, AND THE CURRENT
C	             SELECTION IS TERMINATED.
C
C	   REMARKS
C	      THE NUMBER OF DATA POINTS MUST BE AT LEAST GREATER THAN THE
C	      NUMBER OF INDEPENDENT VARIABLES PLUS ONE.  FORCED VARIABLES
C	      ARE ENTERED INTO THE REGRESSION EQUATION BEFORE ALL OTHER
C	      INDEPENDENT VARIABLES.  WITHIN THE SET OF FORCED VARIABLES,
C	      THE ONE TO BE CHOSEN FIRST WILL BE THAT ONE WHICH EXPLAINS
C	      THE GREATEST AMOUNT OF VARIANCE.
C	      INSTEAD OF USING, AS A STOPPING CRITERION, A PROPORTION OF
C	      THE TOTAL VARIANCE, SOME OTHER CRITERION MAY BE ADDED TO
C	      SUBROUTINE STOUT.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      STOUT(NSTEP,ANS,L,B,S,T,NSTOP)
C	      THIS SUBROUTINE MUST BE PROVIDED BY THE USER.  IT IS AN
C	      OUTPUT ROUTINE WHICH WILL PRINT THE RESULTS OF EACH STEP OF
C	      THE REGRESSION ANALYSIS.  NSTOP IS AN OPTION CODE WHICH IS
C	      ONE IF THE STEPWISE REGRESSION IS TO BE TERMINATED, AND IS
C	      ZERO IF IT IS TO CONTINUE.  THE USER MUST CONSIDER THIS IF
C	      SOME OTHER STOPPING CRITERION THAN VARIANCE PROPORTION IS TO
C	      BE USED.
C
C	   METHOD
C	      THE ABBREVIATED DOOLITTLE METHOD IS USED TO (1) DECIDE VARI-
C	      ABLES ENTERING IN THE REGRESSION AND (2) COMPUTE REGRESSION
C	      COEFFICIENTS.  REFER TO C. A. BENNETT AND N. L. FRANKLIN,
C	      'STATISTICAL ANALYSIS IN CHEMISTRY AND THE CHEMICAL INDUS-
C	      TRY', JOHN WILEY AND SONS, 1954, APPENDIX 6A.
C
C	..................................................................
C
	SUBROUTINE STPRG (M,N,D,XBAR,IDX,PCT,NSTEP,ANS,L,B,S,T,LL,IER)
C
	DIMENSION D(1),XBAR(1),IDX(1),NSTEP(1),ANS(1),L(1),B(1),S(1),T(1),
     1LL(1)
C
C	..................................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION D,XBAR,ANS,B,S,T,RD,RE
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
C	   85,90,114,132,AND 134, MUST BE CHANGED TO DSQRT.
C
C	..................................................................
C
C	   INITIALIZATION
C
	IER=0
	ONM=N-1
	NFO=0
	NSTEP(3)=0
	ANS(3)=0.0
	ANS(4)=0.0
	NSTOP=0
C
C	   FIND DEPENDENT VARIABLE, NUMBER OF VARIABLES TO BE FORCED TO
C	   ENTER IN THE REGRESSION, AND NUMBER OF VARIABLES TO BE DELETED
C
	DO 30 I=1,M
	LL(I)=1
	IF(IDX(I)) 30, 30, 10
10	IF(IDX(I)-2) 15, 20, 25
15	NFO=NFO+1
	IDX(NFO)=I
	GO TO 30
20	NSTEP(3)=NSTEP(3)+1
	LL(I)=-1
	GO TO 30
25	MY=I
	NSTEP(1)=MY
	LY=M*(MY-1)
	LYP=LY+MY
	ANS(5)=D(LYP)
30	CONTINUE
	NSTEP(2)=NFO
C
C	   FIND THE MAXIMUM NUMBER OF STEPS
C
	MX=M-NSTEP(3)-1
C
C	   START SELECTION OF VARIABLES
C
	DO 140 NL=1,MX
	RD=0
	IF(NL-NFO) 35, 35, 55
C
C	   SELECT NEXT VARIABLE TO ENTER AMONG FORCED VARIABLES
C
35	DO 50 I=1,NFO
	K=IDX(I)
	IF(LL(K)) 50, 50, 40
40	LYP=LY+K
	IP=M*(K-1)+K
	RE=D(LYP)*D(LYP)/D(IP)
	IF(RD-RE) 45, 50, 50
45	RD=RE
	NEW=K
50	CONTINUE
	GO TO 75
C
C	   SELECT NEXT VARIABLE TO ENTER AMONG NON-FORCED VARIABLES
C
55	DO 70 I=1,M
	IF(I-MY) 60, 70, 60
60	IF(LL(I)) 70, 70, 62
62	LYP=LY+I
	IP=M*(I-1)+I
	RE=D(LYP)*D(LYP)/D(IP)
	IF(RD-RE) 64, 70, 70
64	RD=RE
	NEW=I
70	CONTINUE
C
C	   TEST WHETHER THE PROPORTION OF THE SUM OF SQUARES REDUCED BY
C	   THE LAST VARIABLE ENTERED IS GREATER THAN OR EQUAL TO THE
C	   SPECIFIED PROPORTION
C
75	IF(RD) 77,77,76
76	IF(ANS(5)-(ANS(3)+RD))77,77,78
77	IER=1
	GO TO 150
78	RE=RD/ANS(5)
	IF(RE-PCT) 150, 80, 80
C
C	   IT IS GREATER THAN OR EQUAL
C
80	LL(NEW)=0
	L(NL)=NEW
	ANS(1)=RD
	ANS(2)=RE
	ANS(3)=ANS(3)+RD
	ANS(4)=ANS(4)+RE
	NSTEP(4)=NL
	NSTEP(5)=NEW
C
C	   COMPUTE MULTIPLE CORRELATION, F-VALUE FOR ANALYSIS OF
C	   VARIANCE, AND STANDARD ERROR OF ESTIMATE
C
85	ANS(6)= SQRT(ANS(4))
	RD=NL
	RE=ONM-RD
	RE=(ANS(5)-ANS(3))/RE
	ANS(7)=(ANS(3)/RD)/RE
90	ANS(8)= SQRT(RE)
C
C	   DIVIDE BY THE PIVOTAL ELEMENT
C
	IP=M*(NEW-1)+NEW
	RD=D(IP)
	LYP=NEW-M
	DO 100 J=1,M
	LYP=LYP+M
	IF(LL(J)) 100, 94, 97
94	IF(J-NEW) 96, 98, 96
96	IJ=M*(J-1)+J
	D(IJ)=D(IJ)+D(LYP)*D(LYP)/RD
97	D(LYP)=D(LYP)/RD
	GO TO 100
98	D(IP)=1.0/RD
100	CONTINUE
C
C	   COMPUTE REGRESSION COEFFICIENTS
C
	LYP=LY+NEW
	B(NL)=D(LYP)
	IF(NL-1) 112, 112, 105
105	ID=NL-1
	DO 110 J=1,ID
	IJ=NL-J
	KK=L(IJ)
	LYP=LY+KK
	B(IJ)=D(LYP)
	DO 110 K=1,J
	IK=NL-K+1
	MK=L(IK)
	LYP=M*(MK-1)+KK
110	B(IJ)=B(IJ)-D(LYP)*B(IK)
C
C	   COMPUTE INTERCEPT
C
112	ANS(9)=XBAR(MY)
	DO 115 I=1,NL
	KK=L(I)
	ANS(9)=ANS(9)-B(I)*XBAR(KK)
	IJ=M*(KK-1)+KK
114	S(I)=ANS(8)* SQRT(D(IJ))
115	T(I)=B(I)/S(I)
C
C	   PERFORM A REDUCTION TO ELIMINATE THE LAST VARIABLE ENTERED
C
	IP=M*(NEW-1)
	DO 130 I=1,M
	IJ=I-M
	IK=NEW-M
	IP=IP+1
	IF(LL(I)) 130, 130, 120
120	DO 126 J=1,M
	IJ=IJ+M
	IK=IK+M
	IF(LL(J)) 126, 122, 122
122	IF(J-NEW) 124, 126, 124
124	D(IJ)=D(IJ)-D(IP)*D(IK)
126	CONTINUE
	D(IP)=D(IP)/(-RD)
130	CONTINUE
C
C	   ADJUST STANDARD ERROR OF THE ESTIMATE AND MULTIPLE CORRELATION
C	   COEFFICIENT
C
	RD=N-NSTEP(4)
	RD=ONM/RD
132	ANS(10)=SQRT(1.0-(1.0-ANS(6)*ANS(6))*RD)
134	ANS(11)=ANS(8)*SQRT(RD)
C
C	   CALL THE OUTPUT SUBROUTINE
	CALL STOUT (NSTEP,ANS,L,B,S,T,NSTOP)
C
C	   TEST WHETHER THE STEP-WISE REGRESSION WAS TERMINATED IN
C	   SUBROUTINE STOUT
C
	IF(NSTOP) 140, 140, 150
C
140	CONTINUE
C
150	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SUBMX
C
C	   PURPOSE
C	      BASED ON VECTOR S DERIVED FROM SUBROUTINE SUBST OR ABSNT,
C	      THIS SUBROUTINE COPIES FROM A LARGER MATRIX OF OBSERVATION
C	      DATA A SUBSET MATRIX OF THOSE OBSERVATIONS WHICH HAVE
C	      SATISFIED CERTAIN CONDITION.  THIS SUBROUTINE IS NORMALLY
C	      USED PRIOR TO STATISTICAL ANALYSES (E.G., MULTIPLE REGRES-
C	      SION, FACTOR ANALYSIS).
C
C	   USAGE
C	      CALL SUBMX (A,D,S,NO,NV,N)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - INPUT MATRIX OF OBSERVATIONS, NO BY NV.
C	      D  - OUTPUT MATRIX OF OBSERVATIONS, N BY NV.
C	      S -  INPUT VECTOR OF LENGTH NO CONTAINING THE CODES DERIVED
C	           FROM SUBROUTINE SUBST OR ABSNT.
C	      NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1.
C	      NV - NUMBER OF VARIABLES. NV MUST BE > OR = TO 1.
C	      N  - OUTPUT VARIABLE CONTAINING THE NUMBER OF NON-ZERO CODES
C	           IN VECTOR S.
C
C	   REMARKS
C	      MATRIX D CAN BE IN THE SAME LOCATION AS MATRIX A.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      IF S(I) CONTAINS A NON-ZERO CODE, I-TH OBSERVATION IS
C	      COPIED FROM THE INPUT MATRIX TO THE OUTPUT MATRIX.
C
C	..................................................................
C
	SUBROUTINE SUBMX (A,D,S,NO,NV,N)
	DIMENSION A(1),D(1),S(1)
C
	L=0
	LL=0
	DO 20 J=1,NV
	DO 15 I=1,NO
	L=L+1
	IF(S(I)) 15, 15, 10
10	LL=LL+1
	D(LL)=A(L)
15	CONTINUE
20	CONTINUE
C
C	   COUNT NON-ZERO CODES IN VECTOR S
C
	N=0
	DO 30 I=1,NO
	IF(S(I)) 30, 30, 25
25	N=N+1
30	CONTINUE
C
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE SUBST
C
C	   PURPOSE
C	      DERIVE A SUBSET VECTOR INDICATING WHICH OBSERVATIONS IN A
C	      SET HAVE SATISFIED CERTAIN CONDITIONS ON THE VARIABLES.
C
C	   USAGE
C	      CALL SUBST (A,C,R,B,S,NO,NV,NC)
C	      PARAMETER B MUST BE DEFINED BY AN EXTERNAL STATEMENT IN THE
C	      CALLING PROGRAM
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - OBSERVATION MATRIX, NO BY NV
C	      C  - INPUT MATRIX, 3 BY NC, OF CONDITIONS TO BE CONSIDERED.
C	           THE FIRST ELEMENT OF EACH COLUMN OF C REPRESENTS THE
C	           NUMBER OF THE VARIABLE (COLUMN OF THE MATRIX A) TO BE
C	           TESTED, THE SECOND ELEMENT OF EACH COLUMN IS A
C	           RELATIONAL CODE AS FOLLOWS
C	                1. FOR LT (LESS THAN)
C	                2. FOR LE (LESS THAN OR EQUAL TO)
C	                3. FOR EQ (EQUAL TO)
C	                4. FOR NE (NOT EQUAL TO)
C	                5. FOR GE (GREATER THAN OR EQUAL TO)
C	                6. FOR GT (GREATER THAN)
C	           THE THIRD ELEMENT OF EACH COLUMN IS A QUANTITY TO BE
C	           USED FOR COMPARISON WITH THE OBSERVATION VALUES. FOR
C	           EXAMPLE, THE FOLLOWING COLUMN IN C
C	                     2.
C	                     5.
C	                    92.5
C	           CAUSES THE SECOND VARIABLE TO BE TESTED FOR GREATER
C	           THAN OR EQUAL TO 92.5
C	      R  - WORKING VECTOR USED TO STORE INTERMEDIATE RESULTS OF
C	           ABOVE TESTS ON A SINGLE OBSERVATION. IF CONDITION IS
C	           SATISFIED, R(I) IS SET TO 1. IF IT IS NOT, R(I) IS SET
C	           TO 0. VECTOR LENGTH IS NC.
C	      B  - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER. IT
C	           CONSISTS OF A BOOLEAN EXPRESSION LINKING THE
C	           INTERMEDIATE VALUES STORED IN VECTOR R. THE BOOLEAN
C	           OPERATORS ARE '*' FOR'AND', '+' FOR 'OR'. EXAMPLE
C	                SUBROUTINE BOOL(R,T)
C	                DIMENSION R(3)
C	                T=R(1)*(R(2)+R(3))
C	                RETURN
C	                END
C	           THE ABOVE EXPRESSION IS TESTED FOR
C	                R(1).AND.(R(2).OR.R(3))
C	      S  - OUTPUT VECTOR INDICATING, FOR EACH OBSERVATION,
C	           WHETHER OR NOT PROPOSITION B IS SATISFIED. IF IT IS,
C	           S(I) IS NON-ZERO. IF IT IS NOT, S(I) IS ZERO. VECTOR
C	           LENGTH IS NO.
C	      NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1.
C	      NV - NUMBER OF VARIABLES. NV MUST BE > OR = TO 1.
C	      NC - NUMBER OF BASIC CONDITIONS TO BE SATISFIED. NC MUST BE
C	           GREATER THAN OR EQUAL TO 1.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      B  THE NAME OF ACTUAL SUBROUTINE SUPPLIED BY THE USER MAY
C	         BE DIFFERENT (E.G., BOOL), BUT SUBROUTINE SUBST ALWAYS
C	         CALLS IT AS B.  IN ORDER FOR SUBROUTINE SUBST TO DO THIS,
C	         THE NAME OF THE USER-SUPPLIED SUBROUTINE MUST BE
C	         DEFINED BY AN EXTERNAL STATEMENT IN THE CALLING PROGRAM.
C	         THE NAME MUST ALSO BE LISTED IN THE ''CALL SUBST''
C	         STATEMENT.  (SEE USAGE ABOVE)
C
C	   METHOD
C	      THE FOLLOWING IS DONE FOR EACH OBSERVATION.
C	      CONDITION MATRIX IS ANALYZED TO DETERMINE WHICH VARIABLES
C	      ARE TO BE EXAMINED. INTERMEDIATE VECTOR R IS FORMED. THE
C	      BOOLEAN EXPRESSION (IN SUBROUTINE B) IS THEN EVALUATED TO
C	      DERIVE THE ELEMENT IN SUBSET VECTOR S CORRESPONDING TO THE
C	      OBSERVATION.
C
C	..................................................................
C
	SUBROUTINE SUBST(A,C,R,B,S,NO,NV,NC)
	DIMENSION A(1),C(1),R(1),S(1)
C
	DO 9 I=1,NO
	IQ=I-NO
	K=-2
	DO 8 J=1,NC
C
C	   CLEAR R VECTOR
C
	R(J)=0.0
C
C	    LOCATE ELEMENT IN OBSERVATION MATRIX AND RELATIONAL CODE
C
	K=K+3
	IZ=C(K)
	IA=IQ+IZ*NO
	IGO=C(K+1)
C
C	    FORM R VECTOR
C
	Q=A(IA)-C(K+2)
	GO TO(1,2,3,4,5,6),IGO
1	IF(Q) 7,8,8
2	IF(Q) 7,7,8
3	IF(Q) 8,7,8
4	IF(Q) 7,8,7
5	IF(Q) 8,7,7
6	IF(Q) 8,8,7
7	R(J)=1.0
8	CONTINUE
C
C	   CALCULATE S VECTOR
C
9	CALL B(R,S(I))
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TAB1
C
C	   PURPOSE
C	      TABULATE FOR ONE VARIABLE IN AN OBSERVATION MATRIX (OR A
C	      MATRIX SUBSET), THE FREQUENCY AND PERCENT FREQUENCY OVER
C	      GIVEN CLASS INTERVALS. IN ADDITION, CALCULATE FOR THE SAME
C	      VARIABLE THE TOTAL, AVERAGE, STANDARD DEVIATION, MINIMUM,
C	      AND MAXIMUM.
C
C	   USAGE
C	      CALL TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - OBSERVATION MATRIX, NO BY NV
C	      S     - INPUT VECTOR GIVING SUBSET OF A. ONLY THOSE
C	              OBSERVATIONS WITH A CORRESPONDING NON-ZERO S(J) ARE
C	              CONSIDERED. VECTOR LENGTH IS NO.
C	      NOVAR - THE VARIABLE TO BE TABULATED. NOVAR MUST BE GREATER
C	              THAN OR EQUAL TO 1 AND LESS THAN OR EQUAL TO NV.
C	              AND UPPER LIMIT OF VARIABLE TO BE TABULATED
C	              IN UBO(1), UBO(2) AND UBO(3) RESPECTIVELY. IF
C	              LOWER LIMIT IS EQUAL TO UPPER LIMIT, THE PROGRAM
C	              USES THE MINIMUM AND MAXIMUM VALUES OF THE VARIABLE.
C	              NUMBER OF INTERVALS, UBO(2), MUST INCLUDE TWO CELLS
C	              FOR VALUES UNDER AND ABOVE LIMITS. VECTOR LENGTH
C	              IS 3.
C	      FREQ  - OUTPUT VECTOR OF FREQUENCIES. VECTOR LENGTH IS
C	              UBO(2).
C	      PCT   - OUTPUT VECTOR OF RELATIVE FREQUENCIES. VECTOR
C	              LENGTH IS UBO(2).
C	      STATS - OUTPUT VECTOR OF SUMMARY STATISTICS, I.E., TOTAL,
C	              AVERAGE, STANDARD DEVIATION, MINIMUM AND MAXIMUM.
C	              VECTOR LENGTH IS 5. IF S IS NULL, THEN TOTAL,AVERAGE
C	              AND STANDARD DEVIATION = 0, MIN=1.E75 AND MAX=-1.E75
C	      NO    - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1
C	      NV    - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV MUST
C	              BE GREATER THAN OR EQUAL TO 1.
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE INTERVAL SIZE IS CALCULATED FROM THE GIVEN INFORMATION
C	      OR OPTIONALLY FROM THE MINIMUM AND MAXIMUM VALUES FOR
C	      VARIABLE NOVAR. THE FREQUENCIES AND PERCENT FREQUENCIES ARE
C	      THEN CALCULATED ALONG WITH SUMMARY STATISTICS.
C	      THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS THAN THE
C	      NUMBER OF OBSERVATIONS USED.
C
C	..................................................................
C
	SUBROUTINE TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV)
	DIMENSION A(1),S(1),UBO(1),FREQ(1),PCT(1),STATS(1)
	DIMENSION WBO(3)
	DO 5 I=1,3
5	WBO(I)=UBO(I)
C
C	   CALCULATE MIN AND MAX
C
	VMIN=1.7E38
	VMAX=-1.7E38
	IJ=NO*(NOVAR-1)
	DO 30 J=1,NO
	IJ=IJ+1
	IF(S(J)) 10,30,10
10	IF(A(IJ)-VMIN) 15,20,20
15	VMIN=A(IJ)
20	IF(A(IJ)-VMAX) 30,30,25
25	VMAX=A(IJ)
30	CONTINUE
	STATS(4)=VMIN
	STATS(5)=VMAX
C
C	   DETERMINE LIMITS
C
	IF(UBO(1)-UBO(3)) 40,35,40
35	UBO(1)=VMIN
	UBO(3)=VMAX
40	INN=UBO(2)
C
C	   CLEAR OUTPUT AREAS
C
	DO 45 I=1,INN
	FREQ(I)=0.0
45	PCT(I)=0.0
	DO 50 I=1,3
50	STATS(I)=0.0
C
C	   CALCULATE INTERVAL SIZE
C
	SINT=ABS((UBO(3)-UBO(1))/(UBO(2)-2.0))
C
C	   TEST SUBSET VECTOR
C
	SCNT=0.0
	IJ=NO*(NOVAR-1)
	DO 75 J=1,NO
	IJ=IJ+1
	IF(S(J)) 55,75,55
55	SCNT=SCNT+1.0
C
C	   DEVELOP TOTAL AND FREQUENCIES
C
	STATS(1)=STATS(1)+A(IJ)
	STATS(3)=STATS(3)+A(IJ)*A(IJ)
	TEMP=UBO(1)-SINT
	INTX=INN-1
	DO 60 I=1,INTX
	TEMP=TEMP+SINT
	IF(A(IJ)-TEMP) 70,60,60
60	CONTINUE
	IF(A(IJ)-TEMP) 75,65,65
65	FREQ(INN)=FREQ(INN)+1.0
	GO TO 75
70	FREQ(I)=FREQ(I)+1.0
75	CONTINUE
	IF (SCNT)79,105,79
C
C	   CALCULATE RELATIVE FREQUENCIES
C
79	DO 80 I=1,INN
80	PCT(I)=FREQ(I)*100.0/SCNT
C
C	   CALCULATE MEAN AND STANDARD DEVIATION
C
	IF(SCNT-1.0) 85,85,90
85	STATS(2)=STATS(1)
	STATS(3)=0.0
	GO TO 95
90	STATS(2)=STATS(1)/SCNT
	STATS(3)=SQRT(ABS((STATS(3)-STATS(1)*STATS(1)/SCNT)/(SCNT-1.0)))
95	DO 100 I=1,3
100	UBO(I)=WBO(I)
105	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TAB2
C
C	   PURPOSE
C	      PERFORM A TWO-WAY CLASSIFICATION FOR TWO VARIABLES IN AN
C	      OBSERVATION MATRIX (OR A MATRIX SUBSET) OF THE FREQUENCY,
C	      PERCENT FREQUENCY, AND OTHER STATISTICS OVER GIVEN CLASS
C	      INTERVALS.
C
C	   USAGE
C	      CALL TAB2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO,NV)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - OBSERVATION MATRIX, NO BY NV
C	      S     - INPUT VECTOR GIVING SUBSET OF A. ONLY THOSE
C	              OBSERVATIONS WITH A CORRESPONDING NON-ZERO S(J) ARE
C	              CONSIDERED. VECTOR LENGTH IS NO.
C	      NOV   - VARIABLES TO BE CROSS-TABULATED. NOV(1) IS VARIABLE
C	                  1, NOV(2) IS VARIABLE 2. VECTOR LENGTH IS 2. NOV
C	                  MUST BE GREATER THAN OR EQUAL TO 1 AND LESS THAN
C	                  OR EQUAL TO NV.
C	      UBO   - 3 BY 2 MATRIX GIVING LOWER LIMIT, NUMBER OF
C	              INTERVALS, AND UPPER LIMIT OF BOTH VARIABLES TO BE
C	              TABULATED (FIRST COLUMN FOR VARIABLE 1, SECOND
C	              COLUMN FOR VARIABLE 2). IF LOWER LIMIT IS EQUAL TO
C	              UPPER LIMIT FOR VARIABLE 1, THE PROGRAM USES THE
C	              MINIMUM AND MAXIMUM VALUES ON EACH VARIABLE. NUMBER
C	              OF INTERVALS MUST INCLUDE TWO CELLS FOR UNDER AND
C	              ABOVE LIMITS.
C	      FREQ  - OUTPUT MATRIX OF FREQUENCIES IN THE TWO-WAY
C	              CLASSIFICATION. ORDER OF MATRIX IS INT1 BY INT2,
C	              WHERE INT1 IS THE NUMBER OF INTERVALS OF VARIABLE 1
C	              AND INT2 IS THE NUMBER OF INTERVALS OF VARIABLE 2.
C	              INT1 AND INT2 MUST BE SPECIFIED IN THE SECOND
C	              POSITION OF RESPECTIVE COLUMN OF UBO MATRIX.
C	      PCT   - OUTPUT MATRIX OF PERCENT FREQUENCIES, SAME ORDER
C	              AS FREQ.
C	      STAT1 - OUTPUT MATRIX SUMMARIZING TOTALS, MEANS, AND
C	              STANDARD DEVIATIONS FOR EACH CLASS INTERVAL OF
C	              VARIABLE 1. ORDER OF MATRIX IS 3 BY INT1.
C	      STAT2 - SAME AS STAT1 BUT OVER VARIABLE 2. ORDER OF MATRIX
C	              IS 3 BY INT2.
C	      NO    - NUMBER OF OBSERVATIONS. NO MUST BE GREATER THAN
C	              OR EQUAL TO 1.
C	      NV    - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV
C	              MUST BE GREATER THAN OR EQUAL TO 1.
C
C	   REMARKS
C	      IF S IS NULL, OUTPUT AREAS ARE SET TO ZERO
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      INTERVAL SIZES FOR BOTH VARIABLES ARE CALCULATED FROM THE
C	      GIVEN INFORMATION OR OPTIONALLY FROM THE MINIMUM AND MAXIMUM
C	      VALUES. THE FREQUENCY AND PERCENT FREQUENCY MATRICES ARE
C	      DEVELOPED. MATRICES STAT1 AND STAT2 SUMMARIZING TOTALS,
C	      MEANS, AND STANDARD DEVIATIONS ARE THEN CALCULATED.
C	      THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS THAN THE
C	      NUMBER OF OBSERVATIONS USED IN EACH CLASS INTERVAL.
C
C	..................................................................
C
	SUBROUTINE TAB2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO,NV)
	DIMENSION A(1),S(1),NOV(2),UBO(3,2),FREQ(1),PCT(1),STAT1(1),
     1STAT2(2),SINT(2)
	DIMENSION WBO(3,2)
	DO 5 I=1,3
	DO 5 J=1,2
5	WBO(I,J)=UBO(I,J)
C
C	   DETERMINE LIMITS
C
	DO 40 I=1,2
	IF(UBO(1,I)-UBO(3,I)) 40, 10, 40
10	VMIN=1.7E38
	VMAX=-1.7E38
	IJ=NO*(NOV(I)-1)
	DO 35 J=1,NO
	IJ=IJ+1
	IF(S(J)) 15,35,15
15	IF(A(IJ)-VMIN) 20,25,25
20	VMIN=A(IJ)
25	IF(A(IJ)-VMAX) 35,35,30
30	VMAX=A(IJ)
35	CONTINUE
	UBO(1,I)=VMIN
	UBO(3,I)=VMAX
40	CONTINUE
C
C	   CALCULATE INTERVAL SIZE
C
45	DO 50 I=1,2
50	SINT(I)=ABS((UBO(3,I)-UBO(1,I))/(UBO(2,I)-2.0))
C
C	   CLEAR OUTPUT AREAS
C
	INT1=UBO(2,1)
	INT2=UBO(2,2)
	INTT=INT1*INT2
	DO 55 I=1,INTT
	FREQ(I)=0.0
55	PCT(I)=0.0
	INTY=3*INT1
	DO 60 I=1,INTY
60	STAT1(I)=0.0
	INTZ=3*INT2
	DO 65 I=1,INTZ
65	STAT2(I)=0.0
C
C	   TEST SUBSET VECTOR
C
	SCNT=0.0
	INTY=INT1-1
	INTX=INT2-1
	IJ=NO*(NOV(1)-1)
	IJX=NO*(NOV(2)-1)
	DO 95 J=1,NO
	IJ=IJ+1
	IJX=IJX+1
	IF(S(J)) 70,95,70
70	SCNT=SCNT+1.0
C
C	   CALCULATE FREQUENCIES
C
	TEMP1=UBO(1,1)-SINT(1)
	DO 75 IY=1,INTY
	TEMP1=TEMP1+SINT(1)
	IF(A(IJ)-TEMP1) 80,75,75
75	CONTINUE
	IY=INT1
80	IYY=3*(IY-1)+1
	STAT1(IYY)=STAT1(IYY)+A(IJ)
	IYY=IYY+1
	STAT1(IYY)=STAT1(IYY)+1.0
	IYY=IYY+1
	STAT1(IYY)=STAT1(IYY)+A(IJ)*A(IJ)
	TEMP2=UBO(1,2)-SINT(2)
	DO 85 IX=1,INTX
	TEMP2=TEMP2+SINT(2)
	IF(A(IJX)-TEMP2) 90,85,85
85	CONTINUE
	IX=INT2
90	IJF=INT1*(IX-1)+IY
	FREQ(IJF)=FREQ(IJF)+1.0
	IX=3*(IX-1)+1
	STAT2(IX)=STAT2(IX)+A(IJX)
	IX=IX+1
	STAT2(IX)=STAT2(IX)+1.0
	IX=IX+1
	STAT2(IX)=STAT2(IX)+A(IJX)*A(IJX)
95	CONTINUE
	IF (SCNT)98,151,98
C
C	   CALCULATE PERCENT FREQUENCIES
C
98	DO 100 I=1,INTT
100	PCT(I)=FREQ(I)*100.0/SCNT
C
C	   CALCULATE TOTALS, MEANS, STANDARD DEVIATIONS
C
	IXY=-1
	DO 120 I=1,INT1
	IXY=IXY+3
	ISD=IXY+1
	TEMP1=STAT1(IXY)
	SUM=STAT1(IXY-1)
	IF(TEMP1-1.0) 120,105,110
105	STAT1(ISD)=0.0
	GO TO 115
110	STAT1(ISD)=SQRT(ABS((STAT1(ISD)-SUM*SUM/TEMP1)/(TEMP1-1.0)))
115	STAT1(IXY)=SUM/TEMP1
120	CONTINUE
	IXX=-1
	DO 140 I=1,INT2
	IXX=IXX+3
	ISD=IXX+1
	TEMP2=STAT2(IXX)
	SUM=STAT2(IXX-1)
	IF(TEMP2-1.0) 140,125,130
125	STAT2(ISD)=0.0
	GO TO 135
130	STAT2(ISD)=SQRT(ABS((STAT2(ISD)-SUM*SUM/TEMP2)/(TEMP2-1.0)))
135	STAT2(IXX)=SUM/TEMP2
140	CONTINUE
	DO 150 I=1,3
	DO 150 J=1,2
150	UBO(I,J)=WBO(I,J)
151	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TALLY
C
C	   PURPOSE
C	      CALCULATE TOTAL, MEAN, STANDARD DEVIATION, MINIMUM, MAXIMUM
C	      FOR EACH VARIABLE IN A SET (OR A SUBSET) OF OBSERVATIONS
C
C	   USAGE
C	      CALL TALLY(A,S,TOTAL,AVER,SD,VMIN,VMAX,NO,NV,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - OBSERVATION MATRIX, NO BY NV
C	      S     - INPUT VECTOR INDICATING SUBSET OF A. ONLY THOSE
C	              OBSERVATIONS WITH A NON-ZERO S(J) ARE CONSIDERED.
C	              VECTOR LENGTH IS NO.
C	      TOTAL - OUTPUT VECTOR OF TOTALS OF EACH VARIABLE. VECTOR
C	              LENGTH IS NV.
C	      AVER  - OUTPUT VECTOR OF AVERAGES OF EACH VARIABLE. VECTOR
C	              LENGTH IS NV.
C	      SD    - OUTPUT VECTOR OF STANDARD DEVIATIONS OF EACH
C	              VARIABLE. VECTOR LENGTH IS NV.
C	      VMIN  - OUTPUT VECTOR OF MINIMA OF EACH VARIABLE. VECTOR
C	              LENGTH IS NV.
C	      VMAX  - OUTPUT VECTOR OF MAXIMA OF EACH VARIABLE. VECTOR
C	              LENGTH IS NV.
C	      NO    - NUMBER OF OBSERVATIONS
C	      NV    - NUMBER OF VARIABLES FOR EACH OBSERVATION
C	      IER   - ZERO, IF NO ERROR.
C	            - 1, IF S IS NULL.  VMIN=-1.E75, VMAX=SD=AVER=1.E75.
C	            - 2, IF S HAS ONLY ONE NON-ZERO ELEMENT. VMIN=VMAX.
C	              SD=0.0
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      ALL OBSERVATIONS CORRESPONDING TO A NON-ZERO ELEMENT IN S
C	      VECTOR ARE ANALYZED FOR EACH VARIABLE IN MATRIX A.
C	      TOTALS ARE ACCUMULATED AND MINIMUM AND MAXIMUM VALUES ARE
C	      FOUND. FOLLOWING THIS, MEANS AND STANDARD DEVIATIONS ARE
C	      CALCULATED.  THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS
C	      THAN THE NUMBER OF OBSERVATIONS USED.
C
C	..................................................................
C
	SUBROUTINE TALLY(A,S,TOTAL,AVER,SD,VMIN,VMAX,NO,NV)
	DIMENSION A(1),S(1),TOTAL(1),AVER(1),SD(1),VMIN(1),VMAX(1)
C
C	   CLEAR OUTPUT VECTORS AND INITIALIZE VMIN,VMAX
C
	IER=0
	DO 1 K=1,NV
	TOTAL(K)=0.0
	AVER(K)=1.7E38
	SD(K)=1.7E38
	VMIN(K)=-1.7E38
1	VMAX(K)=1.7E38
C
C	   TEST SUBSET VECTOR
C
	SCNT=0.0
	DO 7 J=1,NO
	IJ=J-NO
	IF(S(J)) 2,7,2
2	SCNT=SCNT+1.0
C
C	   CALCULATE TOTAL, MINIMA, MAXIMA
C
	DO 6 I=1,NV
	IJ=IJ+NO
	TOTAL(I)=TOTAL(I)+A(IJ)
	IF(A(IJ)-VMIN(I)) 3,4,4
3	VMIN(I)=A(IJ)
4	IF(A(IJ)-VMAX(I)) 6,6,5
5	VMAX(I)=A(IJ)
6	SD(I)=SD(I)+A(IJ)*A(IJ)
7	CONTINUE
C
C	   CALCULATE MEANS AND STANDARD DEVIATIONS
C
	IF (SCNT)8,8,9
8	IER=1
	GO TO 15
9	DO 10 I=1,NV
10	AVER(I)=TOTAL(I)/SCNT
	IF (SCNT-1.0) 13,11,13
11	IER=2
	DO 12 I=1,NV
12	SD(I)=0.0
	GO TO 15
13	DO 14 I=1,NV
14	SD(I)=SQRT(ABS((SD(I)-TOTAL(I)*TOTAL(I)/SCNT)/(SCNT-1.0)))
15	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TCNP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN CHEBYSHEV POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B.
C
C	   USAGE
C	      CALL TCNP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-(1+B)/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR CHEBYSHEV POLYNOMIALS T(N,X)
C	      T(N+1,X)=2*X*T(N,X)-T(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE T(0,X)=1, T(1,X)=X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X = A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE TCNP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+C(2)*B
	POL(2)=C(2)*A
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.
	WORK(2)=B
	WORK(3)=0.
	WORK(4)=A
	XD=A+A
	X0=B+B
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT CHEBYSHEV POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.
C
	DO 5 K=2,J
	H=P-WORK(2*K-3)+X0*WORK(2*K-2)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
	POL(K-1)=POL(K-1)+H*C(J)
5	P=XD*P
	WORK(2*J-1)=0.
	WORK(2*J)=P
6	POL(J)=C(J)*P
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TCSP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN SHIFTED CHEBYSHEV POLYNOMIALS WITH
C	      INDEPENDENT VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH
C	      INDEPENDENT VARIABLE Z, WHERE X=A*Z+B.
C
C	   USAGE
C	      CALL TCSP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (0,1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-B/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=1/(ZR-ZL) AND B=-ZL/(ZR-ZL).
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION FOR
C	      SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X)
C	      TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE TCSP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	XD=A+A
	X0=B+B-1.
	POL(1)=C(1)+C(2)*X0
	POL(2)=C(2)*XD
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.
	WORK(2)=X0
	WORK(3)=0.
	WORK(4)=XD
	XD=XD+XD
	X0=X0+X0
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT SHIFTED CHEBYSHEV
C	   POLYNOMIAL AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.
C
	DO 5 K=2,J
	H=P-WORK(2*K-3)+X0*WORK(2*K-2)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
	POL(K-1)=POL(K-1)+H*C(J)
5	P=XD*P
	WORK(2*J-1)=0.
	WORK(2*J)=P
6	POL(J)=C(J)*P
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TEAS
C
C	   PURPOSE
C	      CALCULATE THE LIMIT OF A GIVEN SEQUENCE BY MEANS OF THE
C	      EPSILON-ALGORITHM.
C
C	   USAGE
C	      CALL TEAS(X,N,FIN,EPS,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      X      - VECTOR WHOSE COMPONENTS ARE TERMS OF THE GIVEN
C	               SEQUENCE. ON RETURN THE COMPONENTS OF VECTOR X
C	               ARE DESTROYED.
C	      N      - DIMENSION OF INPUT VECTOR X.
C	      FIN    - RESULTANT SCALAR CONTAINING ON RETURN THE LIMIT
C	               OF THE GIVEN SEQUENCE.
C	      EPS    - AN INPUT VALUE, WHICH SPECIFIES THE UPPER BOUND
C	               OF THE RELATIVE (ABSOLUTE) ERROR IF THE COMPONENTS
C	               OF X ARE ABSOLUTELY GREATER (LESS) THAN ONE.
C	               CALCULATION IS TERMINATED AS SOON AS THREE TIMES IN
C	               SUCCESSION THE RELATIVE (ABSOLUTE) DIFFERENCE
C	               BETWEEN NEIGHBOURING TERMS IS NOT GREATER THAN EPS.
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - REQUIRED ACCURACY NOT REACHED WITH
C	                         MAXIMAL NUMBER OF ITERATIONS
C	                IER=-1 - INTEGER N IS LESS THAN TEN.
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE N LESS THAN TEN.
C	      THE CHARACTER OF THE GIVEN INFINITE SEQUENCE MUST BE
C	      RECOGNIZABLE BY THOSE N COMPONENTS OF THE INPUT VECTOR X.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE CONVERGENCE OF THE GIVEN SEQUENCE IS ACCELERATED BY
C	      MEANS OF THE E(2)-TRANSFORMATION, USED IN AN ITERATIVE WAY.
C	      FOR REFERENCE, SEE
C	      ALGORITHM 215,SHANKS, CACM 1963, NO. 11, PP. 662. AND
C	      P. WYNN, SINGULAR RULES FOR CERTAIN NON-LINEAR ALGORITHMS
C	      BIT VOL. 3, 1963, PP. 175-195.
C
C	..................................................................
C
	SUBROUTINE TEAS(X,N,FIN,EPS,IER)
C
	DIMENSION X(1)
C
C	   TEST ON WRONG INPUT PARAMETER N
C
	NEW=N
	IF(NEW-10)1,2,2
1	IER=-1
	RETURN
C
C	   CALCULATE INITIAL VALUES FOR THE EPSILON ARRAY
C
2	ISW1=0
	ISW2=0
	W1=1.E38
	W7=X(4)-X(3)
	IF(W7)3,4,3
3	W1=1./W7
C
4	W5=1.E38
	W7=X(2)-X(1)
	IF(W7)5,6,5
5	W5=1./W7
C
6	W4=X(3)-X(2)
	IF(W4)9,7,9
7	W4=1.E38
	T=X(2)
	W2=X(3)
8	W3=1.E38
	GO TO 17
C
9	W4=1./W4
C
	T=1.E38
	W7=W4-W5
	IF(W7)10,11,10
10	T=X(2)+1./W7
C
11	W2=W1-W4
	IF(W2)15,12,15
12	W2=1.E38
	IF(T-1.E38)13,14,14
13	ISW2=1
14	W3=W4
	GO TO 17
C
15	W2=X(3)+1./W2
	W7=W2-T
	IF(W7)16,8,16
16	W3=W4+1./W7
C
17	ISW1=ISW2
	ISW2=0
	IMIN=4
C
C	   CALCULATE DIAGONALS OF THE EPSILON ARRAY IN A DO-LOOP
C
	DO 40 I=5,NEW
	IAUS=I-IMIN
	W4=1.E38
	W5=X(I-1)
	W7=X(I)-X(I-1)
	IF(W7)18,24,18
18	W4=1./W7
C
	IF(W1-1.E38)19,25,25
19	W6=W4-W1
C
C	   TEST FOR NECESSITY OF A SINGULAR RULE
C
	IF(ABS(W6)-ABS(W4)*1.E-4)20,20,22
20	ISW2=1
	IF(W6)22,21,22
21	W5=1.E38
	W6=W1
	IF(W2-1.E38)28,26,26
22	W5=X(I-1)+1./W6
C
C	   FIRST TEST FOR LOSS OF SIGNIFICANCE
C
	IF(ABS(W5)-ABS(X(I-1))*1.E-5)23,24,24
23	IF(W5)36,24,36
C
24	W7=W5-W2
	IF(W7)27,25,27
25	W6=1.E38
26	ISW2=0
	X(IAUS)=W2
	GO TO 37
27	W6=W1+1./W7
28	IF(ISW1-1)33,29,29
C
C	   CALCULATE X(IAUS) WITH HELP OF SINGULAR RULE
C
29	IF(W2-1.E38)30,32,32
30	W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2)
	IF(1.+W7)31,38,31
31	X(IAUS)=W7*W2/(1.+W7)
	GO TO 39
C
32	X(IAUS)=W5+T-X(I-2)
	GO TO 39
C
33	W7=W6-W3
	IF(W7)34,38,34
34	X(IAUS)=W2+1./W7
C
C	   SECOND TEST FOR LOSS OF SIGNIFICANCE
C
	IF(ABS(X(IAUS))-ABS(W2)*1.E-5)35,37,37
35	IF(X(IAUS))36,37,36
C
36	NEW=IAUS-1
	ISW2=0
	GO TO 41
C
37	IF(W2-1.E38)39,38,38
38	X(IAUS)=1.E38
	IMIN=I
C
39	W1=W4
	T=W2
	W2=W5
	W3=W6
	ISW1=ISW2
40	ISW2=0
C
	NEW=NEW-IMIN
C
C	   TEST FOR ACCURACY
C
41	IEND=NEW-1
	DO 47 I=1,IEND
	W1=ABS(X(I)-X(I+1))
	W2=ABS(X(I+1))
	IF(W1-EPS)44,44,42
42	IF(W2-1.)46,46,43
43	IF(W1-EPS*W2)44,44,46
44	ISW2=ISW2+1
	IF(3-ISW2)45,45,47
45	FIN=X(I)
	IER=0
	RETURN
C
46	ISW2=0
47	CONTINUE
C
	IF(NEW-6)48,2,2
48	FIN=X(NEW)
	IER=1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TETRA
C
C	   PURPOSE
C	      COMPUTE A TETRACHORIC CORRELATION COEFFICIENT BETWEEN TWO
C	      VARIABLES WHERE DATA IN BOTH VARIABLES HAVE BEEN REDUCED
C	      ARTIFICIALLY TO TWO CATEGORIES.
C
C	   USAGE
C	      CALL TETRA (N,U,V,HU,HV,R,RS,IE)
C
C	   DESCRIPTION OF PARAMETERS
C	      N  - NUMBER OF OBSERVATIONS
C	      U  - INPUT VECTOR OF LENGTH N CONTAINING THE FIRST VARIABLE
C	           REDUCED TO TWO CATEGORIES
C	      V  - INPUT VECTOR OF LENGTH N CONTAINING THE SECOND VARIABLE
C	           REDUCED TO TWO CATEGORIES
C	      HU - INPUT NUMERICAL CODE INDICATING THE HIGHER CATEGORY OF
C	           THE FIRST VARIABLE.  IF ANY VALUE OF VARIABLE U IS
C	           EQUAL TO OR GREATER THAN HU, IT WILL BE CLASSIFIED AS
C	           THE HIGHER CATEGORY, OTHERWISE AS THE LOWER CATEGORY.
C	      HV - SAME AS HU EXCEPT THAT HV IS FOR THE SECOND VARIABLE.
C	      R  - TETRACHORIC CORRELATION COMPUTED
C	      RS - STANDARD ERROR OF TETRACHORIC CORRELATION COMPUTED
C	      IE - ERROR CODE
C	           0 - NO ERROR
C	           1 - UNABLE TO COMPUTE A TETRACHORIC CORRELATION DUE TO
C	               THE FACT THAT AT LEAST ONE CELL SHOWS ZERO FRE-
C	               QUENCY IN THE 2X2 CONTINGENCY TABLE CONSTRUCTED
C	               FROM INPUT DATA.  IN THIS CASE, R AND RS ARE SET
C	               TO 10**75.  (SEE GUILFORD, 1956)
C	           2 - THE ROOT SOLVER GIVES MULTIPLE ROOTS, OR NO ROOTS,
C	               R, IN THE INTERVAL (-1,1) INCLUSIVE. R AND RS ARE
C	               SET TO 10**75.
C	           3 - UNABLE TO COMPUTE A SATISFACTORY VALUE OF TETRA-
C	               CHORIC CORRELATION USING NEWTON-RAPHSON METHOD OF
C	               APPROXIMATION TO THE ROOT OF THE EQUATION.  R AND
C	               RS ARE SET TO 10**75.  SEE SUBROUTINE POLRT ERROR
C	               INDICATORS.
C	           4 - HIGH ORDER COEFFICIENT OF THE POLYNOMIAL IS ZERO.
C	               SEE SUBROUTINE POLRT ERROR INDICATORS.
C
C	   REMARKS
C	      VALUES OF VARIABLES U AND V MUST BE NUMERICAL, AND
C	      ALPHABETIC AND SPECIAL CHARACTERS MUST NOT BE USED.
C	      FOR A DEPENDABLE RESULT FOR TETRACHORIC CORRELATION,
C	      IT IS RECOMMENDED THAT N BE AT LEAST 200 OR GREATER.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NDTRI
C	      POLRT--THIS POLYNOMIAL ROOT ROUTINE WAS SELECTED BECAUSE OF
C	             ITS SMALL STORAGE REQUIREMENT.  OTHER SSP ROUTINES
C	             WHICH COULD REPLACE POLRT ARE PRQD AND PRBM.  THEIR
C	             USE WOULD REQUIRE MODIFICATION OF TETRA.
C
C	   METHOD
C	      REFER TO J. P. GUILFORD, 'FUNDAMENTAL STATISTICS IN PSYCHO-
C	      LOGY AND EDUCATION', MCGRAW-HILL, NEW YORK, 1956, CHAPTER 13
C	      AND W. P. ELDERTON, 'FREQUENCY CURVES AND CORRELATION' 4-TH
C	      ED., CAMBRIDGE UNIVERSITY PRESS, 1953, CHAPTER 9.
C
C	..................................................................
C
	SUBROUTINE TETRA (N,U,V,HU,HV,R,RS,IE)
C
	DIMENSION XCOF(8),COF(8),ROOTR(7),ROOTI(7)
	DIMENSION U(1),V(1)
	DOUBLE PRECISION X31,X32,X312,X322
C
C	   CONSTRUCT A 2X2 CONTINGENCY TABLE
C
	A=0.0
	B=0.0
	C=0.0
	D=0.0
	DO 40 I=1,N
	IF(U(I)-HU) 10, 25, 25
10	IF(V(I)-HV) 15, 20, 20
15	D=D+1.0
	GO TO 40
20	B=B+1.0
	GO TO 40
25	IF(V(I)-HV) 30, 35, 35
30	C=C+1.0
	GO TO 40
35	A=A+1.0
40	CONTINUE
C
C	   TEST WHETHER ANY CELL IN THE CONTINGENCY TABLE IS ZERO.
C	   IF SO, RETURN TO THE CALLING ROUTINE WITH R=0.0 AND IE=1.
C
	IE=0
	IF(A) 60, 60, 45
45	IF(B) 60, 60, 50
50	IF(C) 60, 60, 55
55	IF(D) 60, 60, 70
60	IE=1
	GO TO 86
C
C	   COMPUTE P1, Q1, P2, AND Q2
C
70	FN=N
	P1=(A+C)/FN
	Q1=(B+D)/FN
	P2=(A+B)/FN
	Q2=(C+D)/FN
C
C	   FIND THE STANDARD NORMAL DEVIATES AT Q1 AND Q2, AND THE
C	   ORDINATES AT THOSE POINTS
C
	CALL NDTRI (Q1,X1,Y1,ER)
	CALL NDTRI (Q2,X2,Y2,ER)
C
C	   COMPUTE THE TETRACHORIC CORRELATION COEFFICIENT
C
	IF(X1) 76, 72, 76
72	IF(X2) 76, 74, 76
74	R=0.0
	GO TO 90
76	XCOF(1)=-((A*D-B*C)/(Y1*Y2*FN*FN))
	XCOF(2)=1.0
	XCOF(3)=X1*X2/2.0
	XCOF(4)=(X1*X1-1.0)*(X2*X2-1.0)/6.0
	X31=DBLE(X1)
	X32=DBLE(X2)
	X312=X31**2
	X322=X32**2
	XCOF(5)=SNGL(X31*(X312-3.0D0)*X32*(X322-3.0D0)/24.0D0)
	XCOF(6)=SNGL((X312*(X312-6.0D0)+3.0D0)*(X322*(X322-6.0D0)+3.0D0)
     1        /120.0D0)
	XCOF(7)=SNGL(X31*(X312*(X312-10.0D0)+15.0D0)*X32*(X322*(X322-10.0
     1        D0)+15.0D0)/720.0D0)
	XCOF(8)=SNGL((((X312-15.0D0)*X312+45.0D0)*X312-15.0D0)*(((X322-
     1        15.0D0)*X322+45.0D0)*X322-15.0D0)/5040.0D0)
C
	CALL POLRT (XCOF,COF,7,ROOTR,ROOTI,IER)
C
	J=0
	IF(IER) 78, 78, 84
78	DO 82 I=1,7
	IF(ABS(ROOTI(I))-.5*ABS(ROOTR(I))*1.0E-6)79,79,82
79	R=ROOTR(I)
	IF(ABS(R)-1.0)81,81,80
80	R=1.7E38                                                                  0
	GO TO 82
81	J=J+1
82	CONTINUE
	IF(J-1)83,88,83
83	IE=2
	GO TO 86
C
C	   UNABLE TO COMPUTE R
C
84	IE=IER
86	R=1.7E38
	RS=R
	GO TO 100
88	IF(R-1.7E38)90,83,83
C
C	   STANDARD ERROR OF R=0.0
C
90	RS= SQRT(P1*P2*Q1*Q2)/(Y1*Y2* SQRT(FN))
C
100	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TEUL
C
C	   PURPOSE
C	      COMPUTE THE SUM OF FCT(K) FOR K FROM ONE UP TO INFINITY.
C
C	   USAGE
C	      CALL TEUL(FCT,SUM,MAX,EPS,IER)
C	      PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT.
C
C	   DESCRIPTION OF PARAMETERS
C	      FCT    - NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED.
C	               IT COMPUTES THE K-TH TERM OF THE SERIES TO ANY
C	               GIVEN INDEX K.
C	      SUM    - RESULTANT VALUE CONTAINING ON RETURN THE SUM OF
C	               THE GIVEN SERIES.
C	      MAX    - INPUT VALUE, WHICH SPECIFIES THE MAXIMAL NUMBER
C	               OF TERMS OF THE SERIES THAT ARE RESPECTED.
C	      EPS    - INPUT VALUE, WHICH SPECIFIES THE UPPER BOUND OF
C	               THE RELATIVE ERROR.
C	               SUMMATION IS STOPPED AS SOON AS FIVE TIMES IN
C	               SUCCESSION THE ABSOLUTE VALUE OF THE TERMS OF THE
C	               TRANSFORMED SERIES ARE FOUND TO BE LESS THAN
C	               EPS*(ABSOLUTE VALUE OF CURRENT SUM).
C	      IER    - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING
C	               FORM
C	                IER=0  - NO ERROR
C	                IER=1  - REQUIRED ACCURACY NOT REACHED WITH
C	                         MAXIMAL NUMBER OF TERMS
C	                IER=-1 - THE INTEGER MAX IS LESS THAN ONE.
C
C	   REMARKS
C	      NO ACTION BESIDES ERROR MESSAGE IN CASE MAX LESS THAN ONE.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      THE EXTERNAL FUNCTION SUBPROGRAM FCT(K) MUST BE FURNISHED
C	      BY THE USER.
C
C	   METHOD
C	      EVALUATION IS DONE BY MEANS OF A SUITABLY REFINED EULER
C	      TRANSFORMATION. FOR REFERENCE, SEE
C	      F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS,
C	      MCGRAW/HILL, NEW YORK/TORONTO/LONDON, 1956, PP.155-160, AND
C	      P. NAUR, REPORT ON THE ALGORITHMIC LANGUAGE ALGOL 60,
C	      CACM, VOL.3, ISS.5 (1960), PP.311.
C
C	..................................................................
C
	SUBROUTINE TEUL (FCT,SUM,MAX,EPS,IER)
C
	DIMENSION Y(15)
C
C	   TEST ON WRONG INPUT PARAMETER MAX
C
	IF(MAX)1,1,2
1	IER=-1
	GOTO 12
C
C	   INITIALIZE EULER TRANSFORMATION
C
2	IER=1
	I=1
	M=1
	N=1
	Y(1)=FCT(N)
	SUM=Y(1)*.5
C
C	   START EULER-LOOP
C
3	J=0
4	I=I+1
	IF(I-MAX)5,5,12
5	N=I
	AMN=FCT(N)
	DO 6 K=1,M
	AMP=(AMN+Y(K))*.5
	Y(K)=AMN
6	AMN=AMP
C
C	   CHECK EULER TRANSFORMATION
C
	IF(ABS(AMN)-ABS(Y(M)))7,9,9
7	IF(M-15)8,9,9
8	M=M+1
	Y(M)=AMN
	AMN=.5*AMN
C
C	   UPDATE SUM
C
9	SUM=SUM+AMN
	IF(ABS(AMN)-EPS*ABS(SUM))10,10,3
C
C	   TEST END OF PROCEDURE
C
10	J=J+1
	IF(J-5)4,11,11
11	IER=0
12	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE THEP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN HERMITE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL THEP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTOR POL AND C
C	      C     - COEFFICIENT VECTOR OF GIVEN EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-C,C) IN X TO THE RANGE (ZL,ZR) IN Z WHERE
C	      ZL=-(C+B)/A AND ZR=(C-B)/A.
C	      FOR GIVEN ZL, ZR AND C WE HAVE A=2C/(ZR-ZL) AND
C	      B=-C(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR HERMITE POLYNOMIALS H(N,X)
C	      H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE H(0,X)=1,H(1,X)=2*X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE THEP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	XD=A+A
	X0=B+B
	POL(1)=C(1)+C(2)*X0
	POL(2)=C(2)*XD
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.
	WORK(2)=X0
	WORK(3)=0.
	WORK(4)=XD
	FI=2.
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT HERMITE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	P=0.
C
	DO 5 K=2,J
	H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.
	WORK(2*J)=P*XD
	FI=FI+2.
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TIE
C
C	   PURPOSE
C	      CALCULATE CORRECTION FACTOR DUE TO TIES
C
C	   USAGE
C	      CALL TIE(R,N,KT,T)
C
C	   DESCRIPTION OF PARAMETERS
C	      R  - INPUT VECTOR OF RANKS OF LENGTH N CONTAINING VALUES
C	           1 TO N
C	      N  - NUMBER OF RANKED VALUES
C	      KT - INPUT CODE FOR CALCULATION OF CORRECTION FACTOR
C	                 1   SOLVE EQUATION 1
C	                 2   SOLVE EQUATION 2
C	      T  - CORRECTION FACTOR (OUTPUT)
C	               EQUATION 1   T=SUM(CT**3-CT)/12
C	               EQUATION 2   T=SUM(CT*(CT-1)/2)
C	             WHERE CT IS THE NUMBER OF OBSERVATIONS TIED FOR A
C	                   GIVEN RANK
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      VECTOR IS SEARCHED FOR SUCCESSIVELY LARGER RANKS. TIES ARE
C	      COUNTED AND CORRECTION FACTOR 1 OR 2 SUMMED.
C
C	..................................................................
C
	SUBROUTINE TIE(R,N,KT,T)
	DIMENSION R(1)
C
C	   INITIALIZATION
C
	T=0.0
	Y=0.0
5	X=1.0E38
	IND=0
C
C	   FIND NEXT LARGEST RANK
C
	DO 30 I=1,N
	IF(R(I)-Y) 30,30,10
10	IF(R(I)-X) 20,30,30
20	X=R(I)
	IND=IND+1
30	CONTINUE
C
C	   IF ALL RANKS HAVE BEEN TESTED, RETURN
C
	IF(IND) 90,90,40
40	Y=X
	CT=0.0
C
C	   COUNT TIES
C
	DO 60 I=1,N
	IF(R(I)-X) 60,50,60
50	CT=CT+1.0
60	CONTINUE
C
C	   CALCULATE CORRECTION FACTOR
C
	IF(CT) 70,5,70
70	IF(KT-1) 75,80,75
75	T=T+CT*(CT-1.)/2.0
	GO TO 5
80	T=T+(CT*CT*CT-CT)/12.0
	GO TO 5
90	RETURN
	END
C	RETURNS T VALUE CORRESPONDING TO GIVEN P
C	USES ZINV
C	ABRAMOWITZ 26.7.5
	FUNCTION TINV(P,N)
	REAL N4
	X=ZINV(P)
	N4=N*4
	X2=X*X
	TINV=X+((X2+1)+((3+X2*(16+5*X2))+(-15+X2*(17+
     A X2*(19+3*X2)))/N4)/N4/6.)/N4*X
	RETURN
	END
C
C
C	..................................................................
C
C	   SUBROUTINE TLAP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN LAGUERRE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL TLAP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (0,C) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-B/A AND ZR=(C-B)/A.
C	      FOR GIVEN ZL, ZR AND C WE HAVE A=C/(ZR-ZL) AND
C	      B=-C*ZL/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR LAGUERRE POLYNOMIALS L(N,X)
C	      L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE L(0,X)=1, L(1,X)=1-X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE TLAP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+C(2)-B*C(2)
	POL(2)=-C(2)*A
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.
	WORK(2)=1.D0-B
	WORK(3)=0.
	WORK(4)=-A
	FI=1.
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT LAGUERRE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	FI=FI+1.
	Q=1./FI
	Q1=Q-1.
	Q2=1.-Q1-B*Q
	Q=Q*A
	P=0.
C
	DO 5 K=2,J
	H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.
	WORK(2*J)=-Q*P
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TLEP
C
C	   PURPOSE
C	      A SERIES EXPANSION IN LEGENDRE POLYNOMIALS WITH INDEPENDENT
C	      VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT
C	      VARIABLE Z, WHERE X=A*Z+B
C
C	   USAGE
C	      CALL TLEP(A,B,POL,N,C,WORK)
C
C	   DESCRIPTION OF PARAMETERS
C	      A     - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION
C	      B     - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION
C	      POL   - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE)
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	      N     - DIMENSION OF COEFFICIENT VECTORS POL AND C
C	      C     - GIVEN COEFFICIENT VECTOR OF EXPANSION
C	              COEFFICIENTS ARE ORDERED FROM LOW TO HIGH
C	              POL AND C MAY BE IDENTICALLY LOCATED
C	      WORK  - WORKING STORAGE OF DIMENSION 2*N
C
C	   REMARKS
C	      COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING
C	      WITH COEFFICIENT VECTOR POL.
C	      OPERATION IS BYPASSED IN CASE N LESS THAN 1.
C	      THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS
C	      THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE
C	      ZL=-(1+B)/A AND ZR=(1-B)/A.
C	      FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL)
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION
C	      FOR LEGENDRE POLYNOMIALS P(N,X)
C	      P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1),
C	      WHERE THE FIRST TERM IN BRACKETS IS THE INDEX,
C	      THE SECOND IS THE ARGUMENT.
C	      STARTING VALUES ARE P(0,X)=1, P(1,X)=X.
C	      THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF
C	      X=A*Z+B TOGETHER WITH
C	      SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N)
C	      =SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N).
C
C	..................................................................
C
	SUBROUTINE TLEP(A,B,POL,N,C,WORK)
C
	DIMENSION POL(1),C(1),WORK(1)
C
C	   TEST OF DIMENSION
	IF(N-1)2,1,3
C
C	   DIMENSION LESS THAN 2
1	POL(1)=C(1)
2	RETURN
C
3	POL(1)=C(1)+B*C(2)
	POL(2)=A*C(2)
	IF(N-2)2,2,4
C
C	   INITIALIZATION
4	WORK(1)=1.
	WORK(2)=B
	WORK(3)=0.
	WORK(4)=A
	FI=1.
C
C	   CALCULATE COEFFICIENT VECTOR OF NEXT LEGENDRE POLYNOMIAL
C	   AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL
	DO 6 J=3,N
	FI=FI+1.
	Q=1./FI-1.
	Q1=1.-Q
	P=0.
C
	DO 5 K=2,J
	H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3)
	P=WORK(2*K-2)
	WORK(2*K-2)=H
	WORK(2*K-3)=P
5	POL(K-1)=POL(K-1)+H*C(J)
	WORK(2*J-1)=0.
	WORK(2*J)=A*P*Q1
6	POL(J)=C(J)*WORK(2*J)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TPRD
C
C	   PURPOSE
C	      TRANSPOSE A MATRIX AND POSTMULTIPLY BY ANOTHER TO FORM
C	      A RESULTANT MATRIX
C
C	   USAGE
C	      CALL TPRD(A,B,R,N,M,MSA,MSB,L)
C
C	   DESCRIPTION OF PARAMETERS
C	      A - NAME OF FIRST INPUT MATRIX
C	      B - NAME OF SECOND INPUT MATRIX
C	      R - NAME OF OUTPUT MATRIX
C	      N - NUMBER OF ROWS IN A AND B
C	      M - NUMBER OF COLUMNS IN A AND ROWS IN R
C	      MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C	      MSB - SAME AS MSA EXCEPT FOR MATRIX B
C	      L - NUMBER OF COLUMNS IN B AND R
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      MATRIX TRANSPOSE OF A IS NOT ACTUALLY CALCULATED. INSTEAD,
C	      ELEMENTS IN MATRIX A ARE TAKEN COLUMNWISE RATHER THAN
C	      ROWWISE FOR MULTIPLICATION BY MATRIX B.
C	      THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT
C	      MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES
C	                    A                B                R
C	                 GENERAL          GENERAL          GENERAL
C	                 GENERAL          SYMMETRIC        GENERAL
C	                 GENERAL          DIAGONAL         GENERAL
C	                 SYMMETRIC        GENERAL          GENERAL
C	                 SYMMETRIC        SYMMETRIC        GENERAL
C	                 SYMMETRIC        DIAGONAL         GENERAL
C	                 DIAGONAL         GENERAL          GENERAL
C	                 DIAGONAL         SYMMETRIC        GENERAL
C	                 DIAGONAL         DIAGONAL         DIAGONAL
C
C	..................................................................
C
	SUBROUTINE TPRD(A,B,R,N,M,MSA,MSB,L)
	DIMENSION A(1),B(1),R(1)
C
C	   SPECIAL CASE FOR DIAGONAL BY DIAGONAL
C
	MS=MSA*10+MSB
	IF(MS-22) 30,10,30
10	DO 20 I=1,N
20	R(I)=A(I)*B(I)
	RETURN
C
C	   MULTIPLY TRANSPOSE OF A BY B
C
30	IR=1
	DO 90 K=1,L
	DO 90 J=1,M
	R(IR)=0.0
	DO 80 I=1,N
	IF(MS) 40,60,40
40	CALL LOC(I,J,IA,N,M,MSA)
	CALL LOC(I,K,IB,N,L,MSB)
	IF(IA) 50,80,50
50	IF(IB) 70,80,70
60	IA=N*(J-1)+I
	IB=N*(K-1)+I
70	R(IR)=R(IR)+A(IA)*B(IB)
80	CONTINUE
90	IR=IR+1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TRACE
C
C	   PURPOSE
C	      COMPUTE CUMULATIVE PERCENTAGE OF EIGENVALUES GREATER THAN
C	      OR EQUAL TO A CONSTANT SPECIFIED BY THE USER.  THIS SUB-
C	      ROUTINE NORMALLY OCCURS IN A SEQUENCE OF CALLS TO SUB-
C	      ROUTINES CORRE, EIGEN, TRACE, LOAD, AND VARMX IN THE PER-
C	      FORMANCE OF A FACTOR ANALYSIS.
C
C	   USAGE
C	      CALL TRACE (M,R,CON,K,D)
C
C	   DESCRIPTION OF PARAMETERS
C	      M     - NUMBER OF VARIABLES. M MUST BE > OR = TO 1
C	      R     - INPUT MATRIX (SYMMETRIC AND STORED IN COMPRESSED
C	              FORM WITH ONLY UPPER TRIANGLE BY COLUMN IN CORE)
C	              CONTAINING EIGENVALUES IN DIAGONAL.  EIGENVALUES ARE
C	              ARRANGED IN DESCENDING ORDER.  THE ORDER OF MATRIX R
C	              IS M BY M.  ONLY M*(M+1)/2 ELEMENTS ARE IN STORAGE.
C	              (STORAGE MODE OF 1)
C	      CON   - A CONSTANT USED TO DECIDE HOW MANY EIGENVALUES TO
C	              RETAIN.  CUMULATIVE PERCENTAGE OF EIGENVALUES
C	              WHICH ARE GREATER THAN OR EQUAL TO THIS VALUE IS
C	              CALCULATED.
C	      K     - OUTPUT VARIABLE CONTAINING THE NUMBER OF EIGENVALUES
C	              GREATER THAN OR EQUAL TO CON.  (K IS THE NUMBER OF
C	              FACTORS.)
C	      D     - OUTPUT VECTOR OF LENGTH M CONTAINING CUMULATIVE
C	              PERCENTAGE OF EIGENVALUES WHICH ARE GREATER THAN
C	              OR EQUAL TO CON.
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      EACH EIGENVALUE GREATER THAN OR EQUAL TO CON IS DIVIDED BY M
C	      AND THE RESULT IS ADDED TO THE PREVIOUS TOTAL TO OBTAIN
C	      THE CUMULATIVE PERCENTAGE FOR EACH EIGENVALUE.
C
C	..................................................................
C
	SUBROUTINE TRACE (M,R,CON,K,D)
	DIMENSION R(1),D(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C	   STATEMENT WHICH FOLLOWS.
C
C	DOUBLE PRECISION R,D
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   ...............................................................
C
	FM=M
	L=0
	DO 100 I=1,M
	L=L+I
100	D(I)=R(L)
	K=0
C
C	TEST WHETHER I-TH EIGENVALUE IS GREATER
C	THAN OR EQUAL TO THE CONSTANT
C
	DO 110 I=1,M
	IF(D(I)-CON) 120, 105, 105
105	K=K+1
110	D(I)=D(I)/FM
C
C	COMPUTE CUMULATIVE PERCENTAGE OF EIGENVALUES
C
120	DO 130 I=2,K
130	D(I)=D(I)+D(I-1)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TTEST
C
C	   PURPOSE
C	      TO FIND CERTAIN T-STATISTICS ON THE MEANS OF POPULATIONS.
C
C	   USAGE
C	      CALL TTEST (A,NA,B,NB,NOP,NDF,ANS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - INPUT VECTOR OF LENGTH NA CONTAINING DATA.
C	      NA  - NUMBER OF OBSERVATIONS IN A.
C	      B   - INPUT VECTOR OF LENGTH NB CONTAINING DATA.
C	      NB  - NUMBER OF OBSERVATIONS IN B.
C	      NOP - OPTIONS FOR VARIOUS HYPOTHESES..
C	            NOP=1--- THAT POPULATION MEAN OF B = GIVEN VALUE A.
C	                     (SET NA=1)
C	            NOP=2--- THAT POPULATION MEAN OF B = POPULATION MEAN
C	                     OF A, GIVEN THAT THE VARIANCE OF B = THE
C	                     VARIANCE OF A.
C	            NOP=3--- THAT POPULATION MEAN OF B = POPULATION MEAN
C	                     OF A, GIVEN THAT THE VARIANCE OF B IS NOT
C	                     EQUAL TO THE VARIANCE OF A.
C	            NOP=4--- THAT POPULATION MEAN OF B = POPULATION MEAN
C	                     OF A, GIVEN NO INFORMATION ABOUT VARIANCES OF
C	                     A AND B.  (SET NA=NB)
C	      NDF - OUTPUT VARIABLE CONTAINING DEGREES OF FREEDOM ASSOCI-
C	            ATED WITH T-STATISTIC CALCULATED.
C	      ANS - T-STATISTIC FOR GIVEN HYPOTHESIS.
C
C	   REMARKS
C	      NA AND NB MUST BE GREATER THAN 1, EXCEPT THAT NA=1 IN
C	      OPTION 1. NA AND NB MUST BE THE SAME IN OPTION 4.
C	      IF NOP IS OTHER THAN 1, 2, 3 OR 4, DEGREES OF FREEDOM AND
C	      T-STATISTIC WILL NOT BE CALCULATED.  NDF AND ANS WILL BE
C	      SET TO ZERO.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      REFER TO OSTLE, BERNARD, 'STATISTICS IN RESEARCH', IOWA
C	      STATE COLLEGE PRESS, 1954, CHAPTER 5.
C
C	..................................................................
C
	SUBROUTINE TTEST (A,NA,B,NB,NOP,NDF,ANS)
	DIMENSION A(1),B(1)
C
C	INITIALIZATION
C
	NDF=0
	ANS=0.0
C
C	CALCULATE THE MEAN OF A
C
	AMEAN=0.0
	DO 110 I=1,NA
110	AMEAN=AMEAN+A(I)
	FNA=NA
	AMEAN=AMEAN/FNA
C
C	CALCULATE THE MEAN OF B
C
115	BMEAN=0.0
	DO 120 I=1,NB
120	BMEAN=BMEAN+B(I)
	FNB=NB
	BMEAN=BMEAN/FNB
C
	IF(NOP-4) 122, 180, 200
122	IF(NOP-1) 200, 135, 125
C
C	CALCULATE THE VARIANCE OF A
C
125	SA2=0.0
	DO 130 I=1,NA
130	SA2=SA2+(A(I)-AMEAN)**2
	SA2=SA2/(FNA-1.0)
C
C	CALCULATE THE VARIANCE OF B
C
135	SB2=0.0
	DO 140 I=1,NB
140	SB2=SB2+(B(I)-BMEAN)**2
	SB2=SB2/(FNB-1.0)
C
	GO TO (150,160,170), NOP
C
C	   OPTION 1
C
150	ANS=((BMEAN-AMEAN)/SQRT(SB2))*SQRT(FNB)
	NDF=NB-1
	GO TO 200
C
C	   OPTION 2
C
160	NDF=NA+NB-2
	FNDF=NDF
	S=SQRT(((FNA-1.0)*SA2+(FNB-1.0)*SB2)/FNDF)
	ANS=((BMEAN-AMEAN)/S)*(1.0/SQRT(1.0/FNA+1.0/FNB))
	GO TO 200
C
C	   OPTION 3
C
170	ANS=(BMEAN-AMEAN)/SQRT(SA2/FNA+SB2/FNB)
	A1=(SA2/FNA+SB2/FNB)**2
	A2=(SA2/FNA)**2/(FNA+1.0)+(SB2/FNB)**2/(FNB+1.0)
	NDF=A1/A2-2.0+0.5
	GO TO 200
C
C	   OPTION 4
C
180	SD=0.0
	D=BMEAN-AMEAN
	DO 190 I=1,NB
190	SD=SD+(B(I)-A(I)-D)**2
	SD=SQRT(SD/(FNB-1.0))
	ANS=(D/SD)*SQRT(FNB)
	NDF=NB-1
C
200	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE TWOAV
C
C	   PURPOSE
C	      TEST WHETHER A NUMBER OF SAMPLES ARE FROM THE SAME
C	      POPULATION BY THE FRIEDMAN TWO-WAY ANALYSIS OF VARIANCE TEST
C
C	   USAGE
C	      CALL TWOAV(A,R,N,M,W,XR,NDF,NR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - INPUT MATRIX, N BY M, OF ORIGINAL DATA
C	      R   - OUTPUT MATRIX, N BY M, OF RANKED DATA
C	      N   - NUMBER OF GROUPS
C	      M   - NUMBER OF CASES IN EACH GROUP
C	      W   - WORK AREA OF LENGTH 2*M
C	      XR  - FRIEDMAN STATISTIC (OUTPUT)
C	      NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT)
C	      NR  - CODE, 0 FOR UNRANKED DATA IN A, 1 FOR RANKED DATA
C	            IN A (INPUT)
C
C	   REMARKS
C	      NONE
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANK
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 7
C
C	..................................................................
C
	SUBROUTINE TWOAV (A,R,N,M,W,XR,NDF,NR)
	DIMENSION A(1),R(1),W(1)
C
C	   DETERMINE WHETHER DATA IS RANKED
C
	IF(NR-1) 10, 30, 10
C
C	   RANK DATA IN EACH GROUP AND ASSIGN TIED OBSERVATIONS AVERAGE
C	   OF TIED RANK
C
10	DO 20 I=1,N
	IJ=I-N
	IK=IJ
	DO 15 J=1,M
	IJ=IJ+N
15	W(J)=A(IJ)
	CALL RANK (W,W(M+1),M)
	DO 20 J=1,M
	IK=IK+N
	IW=M+J
20	R(IK)=W(IW)
	GO TO 35
30	NM=N*M
	DO 32 I=1,NM
32	R(I)=A(I)
C
C	   CALCULATE SUM OF SQUARES OF SUMS OF RANKS
C
35	RTSQ=0.0
	IR=0
	DO 50 J=1,M
	RT=0.0
	DO 40 I=1,N
	IR=IR+1
40	RT=RT+R(IR)
50	RTSQ=RTSQ+RT*RT
C
C	   CALCULATE FRIEDMAN TEST VALUE, XR
C
	FNM=N*(M+1)
	FM=M
	XR=(12.0/(FM*FNM))*RTSQ-3.0*FNM
C
C	   FIND DEGREES OF FREEDOM
C
	NDF=M-1
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE UTEST
C
C	   PURPOSE
C	      TEST WHETHER TWO INDEPENDENT GROUPS ARE FROM THE SAME
C	      POPULATION BY MEANS OF MANN-WHITNEY U-TEST
C
C	   USAGE
C	      CALL UTEST(A,R,N1,N2,U,Z,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - INPUT VECTOR OF CASES CONSISTING OF TWO INDEPENDENT
C	           GROUPS . SMALLER GROUP PRECEDES LARGER GROUP. LENGTH
C	           IS N1+N2.
C	      R  - OUTPUT VECTOR OF RANKS. SMALLEST VALUE IS RANKED 1,
C	           LARGEST IS RANKED N. TIES ARE ASSIGNED AVERAGE OF TIED
C	           RANKS. LENGTH IS N1+N2.
C	      N1 - NUMBER OF CASES IN SMALLER GROUP
C	      N2 - NUMBER OF CASES IN LARGER GROUP
C	      U  - STATISTIC USED TO TEST HOMOGENEITY OF THE TWO
C	           GROUPS (OUTPUT)
C	      Z  - MEASURE OF SIGNIFICANCE OF U IN TERMS OF NORMAL
C	           DISTRIBUTION (OUTPUT)
C	      IER- 0, IF NO ERROR.
C	         - 1, IF ALL VALUES OF ONE GROUP ARE TIED.
C
C	   REMARKS
C	      Z IS SET TO ZERO IF N2 IS LESS THAN 20
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANK
C	      TIE
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 6
C
C	..................................................................
C
	SUBROUTINE UTEST(A,R,N1,N2,U,Z,IER)
	DIMENSION A(1),R(1)
	IER=0
C
C	   RANK SCORES FROM BOTH GROUP TOGETHER IN ASCENDING ORDER, AND
C	   ASSIGN TIED OBSERVATIONS AVERAGE OF TIED RANKS
C
	N=N1+N2
	CALL RANK(A,R,N)
	Z=0.0
C
C	   SUM RANKS IN LARGER GROUP
C
	R2=0.0
	NP=N1+1
	DO 10 I=NP,N
10	R2=R2+R(I)
C
C	   CALCULATE U
C
	FNX=N1*N2
	FN=N
	FN2=N2
	UP=FNX+FN2*((FN2+1.0)/2.0)-R2
	U=FNX-UP
	IF(UP-U) 20,30,30
20	U=UP
C
C	   TEST FOR N2 LESS THAN 20
C
30	IF(N2-20) 80,40,40
C
C	   COMPUTE STANDARD DEVIATION
C
40	KT=1
	CALL TIE(R,N,KT,TS)
	IF(TS) 50,60,50
50	IF (TS-(FN*FN*FN-FN)/12)52,51,52
51	IER=1
	GO TO 80
52	S=SQRT((FNX/(FN*(FN-1.0)))*(((FN*FN*FN-FN)/12.0)-TS))
	GO TO 70
60	S=SQRT(FNX*(FN+1.0)/12.0)
C
C	   COMPUTE Z
C
70	Z=(U-FNX*0.5)/S
80	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE VARMX
C
C	   PURPOSE
C	      PERFORM ORTHOGONAL ROTATIONS OF A FACTOR MATRIX.  THIS
C	      SUBROUTINE NORMALLY OCCURS IN A SEQUENCE OF CALLS TO SUB-
C	      ROUTINES CORRE, EIGEN, TRACE, LOAD, VARMX IN THE PERFORMANCE
C	      OF A FACTOR ANALYSIS.
C
C	   USAGE
C	      CALL VARMX (M,K,A,NC,TV,H,F,D,IER)
C
C	   DESCRIPTION OF PARAMETERS
C	      M     - NUMBER OF VARIABLES AND NUMBER OF ROWS OF MATRIX A.
C	      K     - NUMBER OF FACTORS.
C	      A     - INPUT IS THE ORIGINAL FACTOR MATRIX, AND OUTPUT IS
C	              THE ROTATED FACTOR MATRIX.  THE ORDER OF MATRIX A
C	              IS M X K.
C	      NC    - OUTPUT VARIABLE CONTAINING THE NUMBER OF ITERATION
C	              CYCLES PERFORMED.
C	      TV    - OUTPUT VECTOR CONTAINING THE VARIANCE OF THE FACTOR
C	              MATRIX FOR EACH ITERATION CYCLE.  THE VARIANCE PRIOR
C	              TO THE FIRST ITERATION CYCLE IS ALSO CALCULATED.
C	              THIS MEANS THAT NC+1 VARIANCES ARE STORED IN VECTOR
C	              TV.  MAXIMUM NUMBER OF ITERATION CYCLES ALLOWED IN
C	              THIS SUBROUTINE IS 50.  THEREFORE, THE LENGTH OF
C	              VECTOR TV IS 51.
C	      H     - OUTPUT VECTOR OF LENGTH M CONTAINING THE ORIGINAL
C	              COMMUNALITIES.
C	      F     - OUTPUT VECTOR OF LENGTH M CONTAINING THE FINAL
C	              COMMUNALITIES.
C	      D     - OUTPUT VECTOR OF LENGTH M CONTAINING THE DIFFERENCES
C	              BETWEEN THE ORIGINAL AND FINAL COMMUNALITIES.
C	      IER   - ERROR INDICATOR
C	              IER=0 - NO ERROR
C	              IER=1 - CONVERGENCE WAS NOT ACHIEVED IN 50 CYCLES
C	                      OF ROTATION
C
C	   REMARKS
C	      IF VARIANCE COMPUTED AFTER EACH ITERATION CYCLE DOES NOT
C	      INCREASE FOR FOUR SUCCESSIVE TIMES, THE SUBROUTINE STOPS
C	      ROTATION.
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      NONE
C
C	   METHOD
C	      KAISER'S VARIMAX ROTATION AS DESCRIBED IN 'COMPUTER PROGRAM
C	      FOR VARIMAX ROTATION IN FACTOR ANALYSIS' BY THE SAME AUTHOR,
C	      EDUCATIONAL AND PSYCHOLOGICAL MEASUREMENT, VOL XIX, NO. 3,
C	      1959.
C
C	..................................................................
C
	SUBROUTINE VARMX (M,K,A,NC,TV,H,F,D,IER)
	DIMENSION A(1),TV(1),H(1),F(1),D(1)
C
C	   ...............................................................
C
C	   IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C	   C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C
C	DOUBLE PRECISION A,TV,H,F,D,TVLT,CONS,AA,BB,CC,DD,U,T,B,COS4T,
C    1                 SIN4T,TAN4T,SINP,COSP,CTN4T,COS2T,SIN2T,COST,SINT
C
C	   THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C	   APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C	   ROUTINE.
C
C	   THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C	   CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  SQRT IN STATEMENTS
C	   115, 290, 330, 350, AND 355 MUST BE CHANGED TO DSQRT.  ABS IN
C	   STATEMENTS 280, 320, AND 375 MUST BE CHANGED TO DABS.
C
C	   ...............................................................
C
C	INITIALIZATION
C
	IER=0
	EPS=0.00116
	TVLT=0.0
	LL=K-1
	NV=1
	NC=0
	FN=M
	FFN=FN*FN
	CONS=0.7071066
C
C	CALCULATE ORIGINAL COMMUNALITIES
C
	DO 110 I=1,M
	H(I)=0.0
	DO 110 J=1,K
	L=M*(J-1)+I
110	H(I)=H(I)+A(L)*A(L)
C
C	CALCULATE NORMALIZED FACTOR MATRIX
C
	DO 120 I=1,M
115	H(I)= SQRT(H(I))
	DO 120 J=1,K
	L=M*(J-1)+I
120	A(L)=A(L)/H(I)
	GO TO 132
C
C	CALCULATE VARIANCE FOR FACTOR MATRIX
C
130	NV=NV+1
	TVLT=TV(NV-1)
132	TV(NV)=0.0
	DO 150 J=1,K
	AA=0.0
	BB=0.0
	LB=M*(J-1)
	DO 140 I=1,M
	L=LB+I
	CC=A(L)*A(L)
	AA=AA+CC
140	BB=BB+CC*CC
150	TV(NV)=TV(NV)+(FN*BB-AA*AA)/FFN
	IF(NV-51)160,155,155
155	IER=1
	GO TO 430
C
C	PERFORM CONVERGENCE TEST
C
160	IF((TV(NV)-TVLT)-(1.E-7)) 170, 170, 190
170	NC=NC+1
	IF(NC-3) 190, 190, 430
C
C	ROTATION OF TWO FACTORS CONTINUES UP TO
C	THE STATEMENT 120.
C
190	DO 420 J=1,LL
	L1=M*(J-1)
	II=J+1
C
C	   CALCULATE NUM AND DEN
C
	DO 420 K1=II,K
	L2=M*(K1-1)
	AA=0.0
	BB=0.0
	CC=0.0
	DD=0.0
	DO 230 I=1,M
	L3=L1+I
	L4=L2+I
	U=(A(L3)+A(L4))*(A(L3)-A(L4))
	T=A(L3)*A(L4)
	T=T+T
	CC=CC+(U+T)*(U-T)
	DD=DD+2.0*U*T
	AA=AA+U
230	BB=BB+T
	T=DD-2.0*AA*BB/FN
	B=CC-(AA*AA-BB*BB)/FN
C
C	   COMPARISON OF NUM AND DEN
C
	IF(T-B) 280, 240, 320
240	IF((T+B)-EPS) 420, 250, 250
C
C	   NUM + DEN IS GREATER THAN OR EQUAL TO THE
C	   TOLERANCE FACTOR
C
250	COS4T=CONS
	SIN4T=CONS
	GO TO 350
C
C	   NUM IS LESS THAN DEN
C
280	TAN4T= ABS(T)/ ABS(B)
	IF(TAN4T-EPS) 300, 290, 290
290	COS4T=1.0/ SQRT(1.0+TAN4T*TAN4T)
	SIN4T=TAN4T*COS4T
	GO TO 350
300	IF(B) 310, 420, 420
310	SINP=CONS
	COSP=CONS
	GO TO 400
C
C	   NUM IS GREATER THAN DEN
C
320	CTN4T= ABS(T/B)
	IF(CTN4T-EPS) 340, 330, 330
330	SIN4T=1.0/ SQRT(1.0+CTN4T*CTN4T)
	COS4T=CTN4T*SIN4T
	GO TO 350
340	COS4T=0.0
	SIN4T=1.0
C
C	   DETERMINE COS THETA AND SIN THETA
C
350	COS2T= SQRT((1.0+COS4T)/2.0)
	SIN2T=SIN4T/(2.0*COS2T)
355	COST= SQRT((1.0+COS2T)/2.0)
	SINT=SIN2T/(2.0*COST)
C
C	   DETERMINE COS PHI AND SIN PHI
C
	IF(B) 370, 370, 360
360	COSP=COST
	SINP=SINT
	GO TO 380
370	COSP=CONS*COST+CONS*SINT
375	SINP= ABS(CONS*COST-CONS*SINT)
380	IF(T) 390, 390, 400
390	SINP=-SINP
C
C	   PERFORM ROTATION
C
400	DO 410 I=1,M
	L3=L1+I
	L4=L2+I
	AA=A(L3)*COSP+A(L4)*SINP
	A(L4)=-A(L3)*SINP+A(L4)*COSP
410	A(L3)=AA
420	CONTINUE
	GO TO 130
C
C	DENORMALIZE VARIMAX LOADINGS
C
430	DO 440 I=1,M
	DO 440 J=1,K
	L=M*(J-1)+I
440	A(L)=A(L)*H(I)
C
C	CHECK ON COMMUNALITIES
C
	NC=NV-1
	DO 450 I=1,M
450	H(I)=H(I)*H(I)
	DO 470 I=1,M
	F(I)=0.0
	DO 460 J=1,K
	L=M*(J-1)+I
460	F(I)=F(I)+A(L)*A(L)
470	D(I)=H(I)-F(I)
	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE WTEST
C
C	   PURPOSE
C	      TEST DEGREE OF ASSOCIATION AMONG A NUMBER OF VARIABLES BY
C	      THE KENDALL COEFFICIENT OF CONCORDANCE
C
C	   USAGE
C	      CALL WTEST(A,R,N,M,WA,W,CS,NDF,NR)
C
C	   DESCRIPTION OF PARAMETERS
C	      A   - INPUT MATRIX, N BY M, OF ORIGINAL DATA
C	      R   - OUTPUT MATRIX, N BY M, OF RANKED DATA.SMALLEST VALUE
C	            IS RANKED 1, LARGEST IS RANKED N. TIES ARE ASSIGNED
C	            AVERAGE OF TIED RANKS
C	      N   - NUMBER OF VARIABLES
C	      M   - NUMBER OF CASES
C	      WA  - WORK AREA VECTOR OF LENGTH 2*M
C	      W   - KENDALL COEFFICIENT OF CONCORDANCE(OUTPUT)
C	      CS  - CHI-SQUARE (OUTPUT)
C	      NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT)
C	      NR  - CODE, 0 FOR UNRANKED DATA IN A, 1 FOR RANKED DATA
C	            IN A (INPUT)
C
C	   REMARKS
C	      CHI-SQUARE IS SET TO ZERO IF M IS 7 OR SMALLER
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      RANK
C	      TIE
C
C	   METHOD
C	      DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE
C	      BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956,
C	      CHAPTER 9
C	..................................................................
C
C
	SUBROUTINE WTEST (A,R,N,M,WA,W,CS,NDF,NR)
	DIMENSION A(1),R(1),WA(1)
C
	FM=M
	FN=N
C
C	   DETERMINE WHETHER DATA IS RANKED
C	   RANK DATA FOR ALL VARIABLES ASSIGNING TIED OBSERVATIONS AVERAGE
C	   OF TIED RANKS AND COMPUTE CORRECTION FOR TIED SCORES
C
	T=0.0
	KT=1
	DO 20 I=1,N
	IJ=I-N
	IK=IJ
	IF(NR-1) 5,2,5
2	DO 3 J=1,M
	IJ=IJ+N
	K=M+J
3	WA(K)=A(IJ)
	GO TO 15
5	DO 10 J=1,M
	IJ=IJ+N
10	WA(J)=A(IJ)
	CALL RANK(WA,WA(M+1),M)
15	CALL TIE(WA(M+1),M,KT,TI)
	T=T+TI
	DO 20 J=1,M
	IK=IK+N
	IW=M+J
20	R(IK)=WA(IW)
C
C	   CALCULATE VECTOR OF SUMS OF RANKS
C
	IR=0
	DO 40 J=1,M
	WA(J)=0.0
	DO 40 I=1,N
	IR=IR+1
40	WA(J)=WA(J)+R(IR)
C
C	   COMPUTE MEAN OF SUMS OF RANKS
C
	SM=0.0
	DO 50 J=1,M
50	SM=SM+WA(J)
	SM=SM/FM
C
C	   COMPUTE SUM OF SQUARES OF DEVIATIONS
C
	S=0.0
	DO 60 J=1,M
60	S=S+(WA(J)-SM)*(WA(J)-SM)
C
C	   COMPUTE W
C
	W=S/(((FN*FN)*(FM*FM*FM-FM)/12.0)-FN*T)
C
C	   COMPUTE DEGREES OF FREEDOM AND CHI-SQUARE IF M IS OVER 7
C
	CS=0.0
	NDF=0
	IF(M-7) 70,70,65
65	CS=FN*(FM-1.0)*W
	NDF=M-1
70	RETURN
	END
C
C	..................................................................
C
C	   SUBROUTINE XCPY
C
C	   PURPOSE
C	      COPY A PORTION OF A MATRIX
C
C	   USAGE
C	      CALL XCPY(A,R,L,K,NR,MR,NA,MA,MS)
C
C	   DESCRIPTION OF PARAMETERS
C	      A  - NAME OF INPUT MATRIX
C	      R  - NAME OF OUTPUT MATRIX
C	      L  - ROW OF A WHERE FIRST ELEMENT OF R CAN BE FOUND
C	      K  - COLUMN OF A WHERE FIRST ELEMENT OF R CAN BE FOUND
C	      NR - NUMBER OF ROWS TO BE COPIED INTO R
C	      MR - NUMBER OF COLUMNS TO BE COPIED INTO R
C	      NA - NUMBER OF ROWS IN A
C	      MA - NUMBER OF COLUMNS IN A
C	      MS  - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A
C	             0 - GENERAL
C	             1 - SYMMETRIC
C	             2 - DIAGONAL
C
C	   REMARKS
C	      MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A
C	      MATRIX R IS ALWAYS A GENERAL MATRIX
C
C	   SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C	      LOC
C
C	   METHOD
C	      MATRIX R IS FORMED BY COPYING A PORTION OF MATRIX A. THIS
C	      IS DONE BY EXTRACTING NR ROWS AND MR COLUMNS OF MATRIX A,
C	      STARTING WITH ELEMENT AT ROW L, COLUMN K
C
C	..................................................................
C
	SUBROUTINE XCPY(A,R,L,K,NR,MR,NA,MA,MS)
	DIMENSION A(1),R(1)
C
C	   INITIALIZE
C
	IR=0
	L2=L+NR-1
	K2=K+MR-1
C
	DO 5 J=K,K2
	DO 5 I=L,L2
	IR=IR+1
	R(IR)=0.0
C
C	   LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE
C
	CALL LOC(I,J,IA,NA,MA,MS)
C
C	   TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX
C
	IF(IA) 4,5,4
4	R(IR)=A(IA)
5	CONTINUE
	RETURN
	END
C^  DECEMBER   09    1974
C	GIVES AREA UNDER NORMAL DISTRIBUTION CURVE
C	FOR PROBABILITY P
C	ABRANOWITZ  26.2.23
	FUNCTION ZINV(P)
	T=SQRT(ALOG(1./(P*P)))
	ZINV=T-(2.515517+T*(0.802853+T*0.010328))/(1.+T
     * *(1.432788+T*(0.189269+T*0.001308)))
	RETURN
	END
