Frozen Fish 1: Amiga/FrozenFish-Apr94.iso/bbs/alib/d1xx/d142/scisubr.lha/SciSubr/SciSubr.zoo/SSP2.For

Text File | 1987-11-18 | 441KB | 16,197 lines

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
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
c10    FORMAT (2I5,F10.0)
c20    FORMAT(1H1,62HINTEGRATION OF TABULATED VALUES FOR DY/DX USING SUBR
c     1OUTINE QSF//1H ,10HFUNCTION  ,I5,3X,I5,17H TABULATED VALUES,
c     25X,10HINTERVAL =,E15.8//)
c22    FORMAT(1H ,17HILLEGAL CONDITION/)
c23    FORMAT(1H ,45HNUMBER OF TABULATED VALUES IS LESS THAN THREE)
c30    FORMAT(1H ,7X,'RESULTANT VALUE OF INTEGRAL AT EACH STEP IS ',/
c     1(1H ,6E15.8))
c32    FORMAT(7F10.0)
cC    OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN')
cC    OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT')
cC
c35    READ(5,10)ICOD,NUMBR,SPACE
c    IF(ICOD+NUMBR)70,70,38
c38    WRITE(6,20)ICOD,NUMBR,SPACE
c50    READ(5,32)(Z(I),I=1,NUMBR)
c    IF(NUMBR-3)100,55,55
c55    CALL QSF(SPACE,Z,Z,NUMBR)
c60    WRITE(6,30)(Z(I),I=1,NUMBR)
c    GO TO 35
c   70    STOP
c100    WRITE(6,22)
c    WRITE (6,23)
c    GO TO 35
c200    WRITE(6,22)
c    GO TO 35
c    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
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')
c5    READ(5,10)ID,IORD
c10    FORMAT(1X,I4,3X,I2)
c    IF(ID+IORD)100,100,20
c20    WRITE(6,30)ID,IORD
c30    FORMAT(1H1,61HREAL AND COMPLEX ROOTS OF A POLYNOMIAL USING SUBROUT
c     1INE POLRT///  17H FOR POLYNOMIAL  ,I4,2X,10HOF ORDER  ,I2//1H ,
c     226HTHE INPUT COEFFICIENTS ARE,//)
c    J=IORD+1
c    READ(5,40)(A(I),I=1,J)
c40    FORMAT(7F10.0)
c    WRITE(6,50)(A(I),I=1,J)
c50    FORMAT(6E16.7)
c    CALL POLRT(A,W,IORD,ROOTR,ROOTI,IER)
c    IF(IER-1)90,60,70
c60    WRITE(6,65)
c65    FORMAT(//1H ,33HORDER OF POLYNOMIAL LESS THAN ONE)
c    GO TO 5
c70    IF(IER-3)75,80,78
c75    WRITE(6,77)
c77    FORMAT(//1H ,35HORDER OF POLYNOMIAL GREATER THAN 36)
c    GO TO 5
c78    WRITE(6,79)
c79    FORMAT(//1H ,31H HIGH ORDER COEFFICIENT IS ZERO)
c    GO TO 5
c80    WRITE(6,85)
c85    FORMAT(//1H ,49HUNABLE TO DETERMINE ROOT. THOSE ALREADY FOUND ARE)
c90    WRITE(6,95)
c95    FORMAT(//1H ,5X,9HREAL ROOT,6X,12HCOMPLEX ROOT//)
c    DO 96 I=1,IORD
c96    WRITE(6,97)ROOTR(I),ROOTI(I)
c97    FORMAT(1H ,2E16.7)
c    GO TO 5
c  100    STOP
c    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