C C .................................................................. C C SUBROUTINE ABSNT C C PURPOSE C TEST MISSING OR ZERO VALUES FOR EACH OBSERVATION IN C MATRIX A. C C USAGE C CALL ABSNT (A,S,NO,NV) C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C S - OUTPUT VECTOR OF LENGTH NO INDICATING THE FOLLOWING C CODES FOR EACH OBSERVATION. C 1 THERE IS NOT A MISSING OR ZERO VALUE. C 0 AT LEAST ONE VALUE IS MISSING OR ZERO. C NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1. C NV - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV MUST BE C GREATER THAN OR EQUAL TO 1. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C A TEST IS MADE FOR EACH ROW (OBSERVATION) OF THE MATRIX A. C IF THERE IS NOT A MISSING OR ZERO VALUE, 1 IS PLACED IN C S(J). IF AT LEAST ONE VALUE IS MISSING OR ZERO, 0 IS PLACED C IN S(J). C C .................................................................. C SUBROUTINE ABSNT(A,S,NO,NV) DIMENSION A(1),S(1) C DO 20 J=1,NO IJ=J-NO S(J)=1.0 DO 10 I=1,NV IJ=IJ+NO IF(A(IJ)) 10,5,10 5 S(J)=0 GO TO 20 10 CONTINUE 20 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE ACFI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION C VALUES. C C USAGE C CALL ACFI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - THE ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT C VALUES OF THE TABLE (POSSIBLY DESTROYED). C VAL - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION C VALUES OF THE TABLE (DESTROYED). C Y - THE RESULTING INTERPOLATED FUNCTION VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND C FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS C DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN C THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME C AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY C ELEMENT BY INTERCHANGING OF TABLE POINTS). C FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO C ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL. C DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS C CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED- C DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406. C C .................................................................. C SUBROUTINE ACFI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) IER=2 IF(NDIM)20,20,1 1 Y=VAL(1) DELT2=0. IF(NDIM-1)20,20,2 C C PREPARATIONS FOR INTERPOLATION LOOP 2 P2=1. P3=Y Q2=0. Q3=1. C C C START INTERPOLATION LOOP DO 16 I=2,NDIM II=0 P1=P2 P2=P3 Q1=Q2 Q2=Q3 Z=Y DELT1=DELT2 JEND=I-1 C C COMPUTATION OF INVERTED DIFFERENCES 3 AUX=VAL(I) DO 10 J=1,JEND H=VAL(I)-VAL(J) IF(ABS(H)-1.E-6*ABS(VAL(I)))4,4,9 4 IF(ARG(I)-ARG(J))5,17,5 5 IF(J-JEND)8,6,6 C C INTERCHANGE ROW I WITH ROW I+II 6 II=II+1 III=I+II IF(III-NDIM)7,7,19 7 VAL(I)=VAL(III) VAL(III)=AUX AUX=ARG(I) ARG(I)=ARG(III) ARG(III)=AUX GOTO 3 C C COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1 8 VAL(I)=1.7E38 0 GOTO 10 C C COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J) 9 VAL(I)=(ARG(I)-ARG(J))/H 10 CONTINUE C INVERTED DIFFERENCES ARE COMPUTED C C COMPUTATION OF NEW Y P3=VAL(I)*P2+(X-ARG(I-1))*P1 Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1 IF(Q3)11,12,11 11 Y=P3/Q3 GOTO 13 12 Y=1.7E38 0 13 DELT2=ABS(Z-Y) IF(DELT2-EPS)19,19,14 14 IF(I-8)16,15,15 15 IF(DELT2-DELT1)16,18,18 16 CONTINUE C END OF INTERPOLATION LOOP C C RETURN C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 17 IER=3 RETURN C C TEST VALUE DELT2 STARTS OSCILLATING 18 Y=Z IER=1 RETURN C C THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS 19 IER=0 20 RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR MATRIX ADDITION - ADSAM C C PURPOSE C MATRIX ADDITION SAMPLE PROGRAM C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C MADD C MATIN C MXOUT C LOC C C METHOD C TWO INPUT MATRICES ARE READ FROM THE STANDARD INPUT DEVICE. C THEY ARE ADDED AND THE RESULTANT MATRIX IS LISTED ON C THE STANDARD OUTPUT DEVICE. THIS CAN BE REPEATED FOR ANY C NUMBER OF PAIRS OF MATRICES UNTIL A BLANK CARD IS C ENCOUNTERED C C .................................................................. C C MATRICES ARE DIMENSIONED FOR 1000 ELEMENTS. THEREFORE, PRODUCT C OF NUMBER OF ROWS BY NUMBER OF COLUMNS CANNOT EXCEED 1000. C c DIMENSION A(1000),B(1000),R(1000) cC c10 FORMAT(1H1,15HMATRIX ADDITION) c11 FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4) c12 FORMAT(1H0,20HEXECUTION TERMINATED) c13 FORMAT(1H0,32HMATRIX DIMENSIONS NOT CONSISTENT) c14 FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4) c15 FORMAT(1H0,18HGO ON TO NEXT CASE) c16 FORMAT(1H0,11HEND OF CASE) cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC .................................................................. cC c WRITE(6,10) c20 CALL MATIN(ICODA,A,1000,NA,MA,MSA,IER) c IF( NA ) 25,95,25 c25 IF(IER-1) 40,30,35 c30 WRITE(6,11) ICODA c GO TO 45 c35 WRITE(6,14) ICODA c37 WRITE(6,12) c GO TO 95 c40 CALL MXOUT(ICODA,A,NA,MA,MSA,60,120,2) c45 CALL MATIN(ICODB,B,1000,NB,MB,MSB,IER) c IF(IER-1) 60,50,55 c50 WRITE(6,11) ICODB c WRITE(6,15) c GO TO 20 c55 WRITE(6,14) ICODB c GO TO 37 c60 IF(NA-NB) 75,70,75 c70 IF(MA-MB) 75,80,75 c75 WRITE(6,13) c WRITE(6,15) c GO TO 20 c80 CALL MXOUT(ICODB,B,NB,MB,MSB,60,120,2) c ICODR=ICODA+ICODB c CALL MADD(A,B,R,NA,MA,MSA,MSB) c MSR=MSA c IF(MSA-MSB) 90,90,85 c85 MSR=MSB c90 CALL MXOUT(ICODR,R,NA,MA,MSR,60,120,2) c WRITE(6,16) c GO TO 20 c 95 CONTINUE c END C C .................................................................. C C SUBROUTINE AHI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND C DERIVATIVE VALUES. C C USAGE C CALL AHI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - THE ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT C VALUES OF THE TABLE (NOT DESTROYED). C VAL - THE INPUT VECTOR (DIMENSION 2*NDIM) OF FUNCTION C AND DERIVATIVE VALUES OF THE TABLE (DESTROYED). C FUNCTION AND DERIVATIVE VALUES MUST BE STORED IN C PAIRS, THAT MEANS BEGINNING WITH FUNCTION VALUE AT C POINT ARG(1) EVERY FUNCTION VALUE MUST BE FOLLOWED C BY THE VALUE OF DERIVATIVE AT THE SAME POINT. C Y - THE RESULTING INTERPOLATED FUNCTION VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND C FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE C PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG C WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES, C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF C HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND C GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION, C JACM, VOL.11, ISS.3 (1964), PP.352-356. C C .................................................................. C SUBROUTINE AHI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) IER=2 H2=X-ARG(1) IF(NDIM-1)2,1,3 1 Y=VAL(1)+VAL(2)*H2 2 RETURN C C VECTOR ARG HAS MORE THAN 1 ELEMENT. C THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE C USED. 3 I=1 DO 5 J=2,NDIM H1=H2 H2=X-ARG(J) Y=VAL(I) VAL(I)=Y+VAL(I+1)*H1 H=H1-H2 IF(H)4,13,4 4 VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H 5 I=I+2 VAL(I)=VAL(I)+VAL(I+1)*H2 C END OF FIRST STEP C C PREPARE AITKEN SCHEME DELT2=0. IEND=I-1 C C START AITKEN-LOOP DO 9 I=1,IEND DELT1=DELT2 Y=VAL(1) M=(I+3)/2 H1=ARG(M) DO 6 J=1,I K=I+1-J L=(K+1)/2 H=ARG(L)-H1 IF(H)6,14,6 6 VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H DELT2=ABS(Y-VAL(1)) IF(DELT2-EPS)11,11,7 7 IF(I-5)9,8,8 8 IF(DELT2-DELT1)9,12,12 9 CONTINUE C END OF AITKEN-LOOP C 10 Y=VAL(1) RETURN C C THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS 11 IER=0 GOTO 10 C C TEST VALUE DELT2 STARTS OSCILLATING 12 IER=1 RETURN C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 13 Y=VAL(1) 14 IER=3 RETURN END C C .................................................................. C C SUBROUTINE ALI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION C VALUES. C C USAGE C CALL ALI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - THE ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - THE INPUT VECTOR (DIMENSION NDIM) OF ARGUMENT C VALUES OF THE TABLE (NOT DESTROYED). C VAL - THE INPUT VECTOR (DIMENSION NDIM) OF FUNCTION C VALUES OF THE TABLE (DESTROYED). C Y - THE RESULTING INTERPOLATED FUNCTION VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - AN INPUT CONSTANT WHICH IS USED AS UPPER BOUND C FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES ATSG, ATSM OR ATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE C PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG C WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES, C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF C LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50. C C .................................................................. C SUBROUTINE ALI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) IER=2 DELT2=0. IF(NDIM-1)9,7,1 C C START OF AITKEN-LOOP 1 DO 6 J=2,NDIM DELT1=DELT2 IEND=J-1 DO 2 I=1,IEND H=ARG(I)-ARG(J) IF(H)2,13,2 2 VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H DELT2=ABS(VAL(J)-VAL(IEND)) IF(J-2)6,6,3 3 IF(DELT2-EPS)10,10,4 4 IF(J-5)6,5,5 5 IF(DELT2-DELT1)6,11,11 6 CONTINUE C END OF AITKEN-LOOP C 7 J=NDIM 8 Y=VAL(J) 9 RETURN C C THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS 10 IER=0 GOTO 8 C C TEST VALUE DELT2 STARTS OSCILLATING 11 IER=1 12 J=IEND GOTO 8 C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 13 IER=3 GOTO 12 END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR ANALYSIS OF VARIANCE - ANOVA C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD FOR ANALYSIS OF VARI- C ANCE, (2) CALL THE SUBROUTINES FOR THE CALCULATION OF SUMS C OF SQUARES, DEGREES OF FREEDOM AND MEAN SQUARE, AND C (3) PRINT FACTOR LEVELS, GRAND MEAN AND ANALYSIS OF VARI- C ANCE TABLE. C C REMARKS C THE PROGRAM HANDLES ONLY COMPLETE FACTORIAL DESIGNS. THERE- C FORE, OTHER EXPERIMENTAL DESIGN MUST BE REDUCED TO THIS FORM C PRIOR TO THE USE OF THE PROGRAM. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C AVDAT C AVCAL C MEANQ C C METHOD C THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O. C HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', C EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS, C 1962, CHAPTER 20. C C .................................................................. C C THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE C CUMULATIVE PRODUCT OF EACH FACTOR LEVEL PLUS ONE (LEVEL(I)+1) C FOR I=1 TO K, WHERE K IS THE NUMBER OF FACTORS.. C c DIMENSION X(3000) cC cC THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE cC NUMBER OF FACTORS.. cC c DIMENSION HEAD(6),LEVEL(6),ISTEP(6),KOUNT(6),LASTS(6) cC cC THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO 2 TO cC THE K-TH POWER MINUS 1, ((2**K)-1).. cC c DIMENSION SUMSQ(63),NDF(63),SMEAN(63) cC cC THE FOLLOWING DIMENSION IS USED TO PRINT FACTOR LABELS IN ANALYSIS cC OF VARIANCE TABLE AND IS FIXED.. cC c DIMENSION FMT(15) cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION X,GMEAN,SUMSQ,SMEAN,SUM cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC ............................................................... cC c1 FORMAT(A4,A2,I2,A4,3X,11(A1,I4)/(A1,I4,A1,I4,A1,I4,A1,I4,A1,I4)) c2 FORMAT(26H1ANALYSIS OF VARIANCE.....A4,A2//) c3 FORMAT(18H0LEVELS OF FACTORS/(3X,A1,7X,I4)) c4 FORMAT(1H0//11H GRAND MEANF20.5////) c5 FORMAT(10H0SOURCE OF18X,7HSUMS OF10X,10HDEGREES OF9X,4HMEAN/10H VA c 1RIATION18X,7HSQUARES11X,7HFREEDOM10X,7HSQUARES/) c6 FORMAT(1H 15A1,F20.5,10X,I6,F20.5) c7 FORMAT(6H TOTAL10X,F20.5,10X,I6) c8 FORMAT(12F6.0) cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR,PR1,K,BLANK,(HEAD(I),LEVEL(I),I=1,K) c IF (EOF) GOTO 999 cC PR.....PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1....PROBLEM NUMBER (CONTINUED) cC K......NUMBER OF FACTORS cC BLANK..BLANK FIELD cC HEAD...FACTOR LABELS cC LEVEL..LEVELS OF FACTORS cC cC PRINT PROBLEM NUMBER AND LEVELS OF FACTORS cC c WRITE (6,2) PR,PR1 c WRITE (6,3) (HEAD(I),LEVEL(I),I=1,K) cC cC CALCULATE TOTAL NUMBER OF DATA cC c N=LEVEL(1) c DO 102 I=2,K c102 N=N*LEVEL(I) cC cC READ ALL INPUT DATA cC c READ (5,8) (X(I),I=1,N) cC c CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT) c CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS) c CALL MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,ISTEP,KOUNT,LASTS) cC cC PRINT GRAND MEAN cC c WRITE (6,4) GMEAN cC cC PRINT ANALYSIS OF VARIANCE TABLE cC c WRITE (6,5) c LL=(2**K)-1 c ISTEP(1)=1 c DO 105 I=2,K c105 ISTEP(I)=0 c DO 110 I=1,15 c110 FMT(I)=BLANK c NN=0 c SUM=0.0 c120 NN=NN+1 c L=0 c DO 140 I=1,K c FMT(I)=BLANK c IF(ISTEP(I)) 130, 140, 130 c130 L=L+1 c FMT(L)=HEAD(I) c140 CONTINUE c WRITE (6,6) (FMT(I),I=1,15),SUMSQ(NN),NDF(NN),SMEAN(NN) c SUM=SUM+SUMSQ(NN) c IF(NN-LL) 145, 170, 170 c145 DO 160 I=1,K c IF(ISTEP(I)) 147, 150, 147 c147 ISTEP(I)=0 c GO TO 160 c150 ISTEP(I)=1 c GO TO 120 c160 CONTINUE c170 N=N-1 c WRITE (6,7) SUM,N c GO TO 100 c999 STOP c END C C .................................................................. C C SUBROUTINE APCH C C PURPOSE C SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF C CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION C C USAGE C CALL APCH(DATI,N,IP,XD,X0,WORK,IER) C C DESCRIPTION OF PARAMETERS C DATI - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1) C CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE C FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT C VALUES. THE CONTENT OF VECTOR DATI REMAINS C UNCHANGED. C N - NUMBER OF GIVEN POINTS C IP - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF C CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS C IP SHOULD NOT EXCEED N C XD - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR C TRANSFORMATION OF ARGUMENT RANGE C X0 - RESULTANT ADDITIVE CONSTANT FOR LINEAR C TRANSFORMATION OF ARGUMENT RANGE C WORK - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2 C ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT C MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM C FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE C AND SQUARE SUM OF FUNCTION VALUES C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS IN DIMENSION C IER = 0 MEANS NO ERRORS C IER = 1 MEANS COINCIDING ARGUMENTS C C REMARKS C NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS C NOT POSITIVE. C EXECUTION OF SUBROUTINE APCH IS A PREPARATORY STEP FOR C CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS C IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE APFS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV C POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM. C THE METHOD IS DISCUSSED IN THE ARTICLE C A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED C DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227. C C .................................................................. C SUBROUTINE APCH(DATI,N,IP,XD,X0,WORK,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION DATI(1),WORK(1) C C CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS IF(N-1)19,20,1 1 IF(IP)19,19,2 C C SEARCH SMALLEST AND LARGEST ARGUMENT 2 IF(IP-N)3,3,19 3 XA=DATI(1) X0=XA XE=0. DO 7 I=1,N XM=DATI(I) IF(XA-XM)5,5,4 4 XA=XM 5 IF(X0-XM)6,7,7 6 X0=XM 7 CONTINUE C C INITIALIZE CALCULATION OF NORMAL EQUATIONS XD=X0-XA M=(IP*(IP+1))/2 IEND=M+IP+1 MT2=IP+IP MT2M=MT2-1 C C SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO DO 8 I=1,IP J=MT2-I WORK(J)=0. WORK(I)=0. K=M+I 8 WORK(K)=0. C C CHECK FOR DEGENERATE ARGUMENT RANGE IF(XD)20,20,9 C C CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS 9 X0=-(X0+XA)/XD XD=2./XD SUM=0. C C START GREAT LOOP OVER ALL GIVEN POINTS DO 15 I=1,N T=DATI(I)*XD+X0 J=I+N DF=DATI(J) C C CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS C FOR ARGUMENT T XA=1. XM=T IF(DATI(2*N+1))11,11,10 10 J=J+N XA=DATI(J) XM=T*XA 11 T=T+T SUM=SUM+DF*DF*XA DF=DF+DF J=1 12 K=M+J WORK(K)=WORK(K)+DF*XA 13 WORK(J)=WORK(J)+XA IF(J-MT2M)14,15,15 14 J=J+1 XE=T*XM-XA XA=XM XM=XE IF(J-IP)12,12,13 15 CONTINUE WORK(IEND)=SUM+SUM C C CALCULATE MATRIX OF NORMAL EQUATIONS LL=M KK=MT2M JJ=1 K=KK DO 18 J=1,M WORK(LL)=WORK(K)+WORK(JJ) LL=LL-1 IF(K-JJ)16,16,17 16 KK=KK-2 K=KK JJ=1 GOTO 18 17 JJ=JJ+1 K=K-1 18 CONTINUE IER=0 RETURN C C ERROR RETURN IN CASE OF FORMAL ERRORS 19 IER=-1 RETURN C C ERROR RETURN IN CASE OF COINCIDING ARGUMENTS 20 IER=1 RETURN END C C .................................................................. C C SUBROUTINE APFS C C PURPOSE C PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL C EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT C OPTIONALLY C C USAGE C CALL APFS(WORK,IP,IRES,IOP,EPS,ETA,IER) C C DESCRIPTION OF PARAMETERS C WORK - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED C COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE. C THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP C LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK C CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0 C THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G. C BY SUBROUTINE APLL. C THE GIVEN MATRIX IS FACTORED IN THE FORM C TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS C DIVIDED BY TRANSPOSE(T). C THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF C IOP EQUALS ZERO. C IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE C STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF C CORRESPONDING DIMENSION AND E0 IS REPLACED BY THE C SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES. C THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2 C IP - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST C SQUARES FIT C IRES - DIMENSION OF CALCULATED LEAST SQUARES FIT. C LET N1, N2, DENOTE THE FOLLOWING NUMBERS C N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF C SIGNIFICANCE WAS INDICATED DURING FACTORIZATION C N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF C THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ) C THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE C AND IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE C IOP - INPUT PARAMETER FOR SELECTION OF OPERATION C IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF C THE RIGHT HAND SIDE BY TRANSPOSE(T) AND C CALCULATION OF THE SQUARE SUM OF ERRORS IS C PERFORMED ONLY C IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES C IS CALCULATED ADDITIONALLY C IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE C UP TO IRES ARE CALCULATED ADDITIONALLY C EPS - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C A SENSIBLE VALUE IS BETWEEN 1.E-3 AND 1.E-6 C ETA - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF C ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-6 C IER - RESULTANT ERROR PARAMETER C IER =-1 MEANS NONPOSITIVE IP C IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED C AND SPECIFIED TOLERANCE OF ERRORS REACHED C IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR C SPECIFIED TOLERANCE OF ERRORS NOT REACHED C C REMARKS C THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF C SIGNIFICANCE IS TOL=ABS(EPS*WORK(1)). C THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF C ERRORS IS ABS(ETA*FSQ). C IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2. C IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2. C IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN C ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C CALCULATION OF THE LEAST SQUARES FITS IS DONE USING C CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION. C THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH C RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE C TOLERANCE TOL=ABS(EPS*WORK(1)). C IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A C SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED. C IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS C TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE C ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION C FOR LOSS OF SIGNIFICANCE C C .................................................................. C SUBROUTINE APFS(WORK,IP,IRES,IOP,EPS,ETA,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION WORK(1) IRES=0 C C TEST OF SPECIFIED DIMENSION IF(IP)1,1,2 C C ERROR RETURN IN CASE OF ILLEGAL DIMENSION 1 IER=-1 RETURN C C INITIALIZE FACTORIZATION PROCESS 2 IPIV=0 IPP1=IP+1 IER=1 ITE=IP*IPP1/2 IEND=ITE+IPP1 TOL=ABS(EPS*WORK(1)) TEST=ABS(ETA*WORK(IEND)) C C START LOOP OVER ALL ROWS OF WORK DO 11 I=1,IP IPIV=IPIV+I JA=IPIV-IRES JE=IPIV-1 C C FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS JK=IPIV DO 9 K=I,IPP1 SUM=0. IF(IRES)5,5,3 3 JK=JK-IRES DO 4 J=JA,JE SUM=SUM+WORK(J)*WORK(JK) 4 JK=JK+1 5 IF(JK-IPIV)6,6,8 C C TEST FOR LOSS OF SIGNIFICANCE 6 SUM=WORK(IPIV)-SUM IF(SUM-TOL)12,12,7 7 SUM=SQRT(SUM) WORK(IPIV)=SUM PIV=1./SUM GOTO 9 C C UPDATE OFF-DIAGONAL TERMS 8 SUM=(WORK(JK)-SUM)*PIV WORK(JK)=SUM 9 JK=JK+K C C UPDATE SQUARE SUM OF ERRORS WORK(IEND)=WORK(IEND)-SUM*SUM C C RECORD ADDRESS OF LAST PIVOT ELEMENT IRES=IRES+1 IADR=IPIV C C TEST FOR TOLERABLE ERROR IF SPECIFIED IF(IOP)10,11,11 10 IF(WORK(IEND)-TEST)13,13,11 11 CONTINUE IF(IOP)12,22,12 C C PERFORM BACK SUBSTITUTION IF SPECIFIED 12 IF(IOP)14,23,14 13 IER=0 14 IPIV=IRES 15 IF(IPIV)23,23,16 16 SUM=0. JA=ITE+IPIV JJ=IADR JK=IADR K=IPIV DO 19 I=1,IPIV WORK(JK)=(WORK(JA)-SUM)/WORK(JJ) IF(K-1)20,20,17 17 JE=JJ-1 SUM=0. DO 18 J=K,IPIV SUM=SUM+WORK(JK)*WORK(JE) JK=JK+1 18 JE=JE+J JK=JE-IPIV JA=JA-1 JJ=JJ-K 19 K=K-1 20 IF(IOP/2)21,23,21 21 IADR=IADR-IPIV IPIV=IPIV-1 GOTO 15 C C NORMAL RETURN 22 IER=0 23 RETURN END C C .................................................................. C C SUBROUTINE APLL C C PURPOSE C SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT C TO A GIVEN DISCRETE FUNCTION C C USAGE C CALL APLL(FFCT,N,IP,P,WORK,DATI,IER) C SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FFCT - USER CODED SUBROUTINE WHICH MUST BE DECLARED C EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED C CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS C THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR C THE I-TH ARGUMENT IN P(1) UP TO P(IP) C FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1) C N IS THE NUMBER OF ALL POINTS C DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY C NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI C WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT C IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT C N - NUMBER OF GIVEN POINTS C IP - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST C SQUARES FIT C IP SHOULD NOT EXCEED N C P - WORKING STORAGE OF DIMENSION IP+1, WHICH C IS USED AS INTERFACE BETWEEN APLL AND THE USER C CODED SUBROUTINE FFCT C WORK - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2. C ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT C MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM, C I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE. C THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT C HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS C THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES C DATI - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN C MAIN LINE AND SUBROUTINE FFCT. C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS C IER = 0 MEANS NO ERRORS C IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT C C REMARKS C TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES C BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR C PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN C SUBROUTINE APLL. ADDITIONAL COMPONENTS OF IER MAY BE C INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH. C IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A C VECTOR IN HIS MAINLINE. C EXECUTION OF SUBROUTINE APLL IS A PREPARATORY STEP FOR C CALCULATION OF THE LINEAR LEAST SQUARES FIT. C NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE APFS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER C C METHOD C HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES C AND WEIGHTS) IS COMPLETELY LEFT TO THE USER C ESSENTIALLY HE HAS THREE CHOICES C (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I. C (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS C REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI C (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1 C LOCATIONS). C ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE C BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE C STORAGE FOR THE DATA SET IN COMMON. C (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY C ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM C ONE UP TO N WITHIN APLL C C .................................................................. C SUBROUTINE APLL(FFCT,N,IP,P,WORK,DATI,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION P(1),WORK(1),DATI(1),IER(1) C C CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS IF(N)10,10,1 1 IF(IP)10,10,2 2 IF(N-IP)10,3,3 C C SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO 3 IPP1=IP+1 M=IPP1*(IP+2)/2 IER(1)=0 DO 4 I=1,M 4 WORK(I)=0. C C START GREAT LOOP OVER ALL GIVEN POINTS DO 8 I=1,N CALL FFCT(I,N,IP,P,DATI,WGT,IER) IF(IER(1))9,5,9 5 J=0 DO 7 K=1,IPP1 AUX=P(K)*WGT DO 6 L=1,K J=J+1 6 WORK(J)=WORK(J)+P(L)*AUX 7 CONTINUE 8 CONTINUE C C NORMAL RETURN 9 RETURN C C ERROR RETURN IN CASE OF FORMAL ERRORS 10 IER(1)=-1 RETURN END C C .................................................................. C C SUBROUTINE APMM C C PURPOSE C APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR C COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE C OF CHEBYSHEV. C C USAGE C CALL APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE C CALLING PROGRAM. C C DESCRIPTION OF PARAMETERS C FCT - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER. C IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR C ARGUMENT VALUE X. C USAGE C CALL FCT(Y,X,K) C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION M CONTAINING C THE VALUES OF GIVEN CONTINUOUS FUNCTIONS C FOR GIVEN ARGUMENT X C X - ARGUMENT VALUE C K - AN INTEGER VALUE WHICH IS EQUAL TO M-1 C REMARKS C IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED C CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO- C MIALS IS DESIRED SUBROUTINES CNP, CSP, LEP, C LAP, HEP, RESPECTIVELY FROM SSP COULD BE USED. C N - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH C IS TO BE APPROXIMATED C M - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH C THE APPROXIMATING FUNCTION IS CONSTRUCTED. C TOP - VECTOR OF DIMENSION 3*N. C ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N) C THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP C TO TOP(2*N) THE CORRESPONDING NODES C ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N) C THE ERRORS AT THOSE N NODES. C OTHER VALUES OF TOP ARE SCRATCH. C IHE - INTEGER VECTOR OF DIMENSION 3*M+4*N+6 C PIV - VECTOR OF DIMENSION 3*M+6. C ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE C RESULTING COEFFICIENTS OF LINEAR APPROXIMATION. C T - AUXILIARY VECTOR OF DIMENSION (M+2)*(M+2) C ITER - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF C ITERATIONS NEEDED C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - THE NUMBER OF ITERATIONS HAS REACHED C THE INTERNAL MAXIMUM N+M C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA- C METER M OR N OR SINCE AT SOME ITERATION C NO SUITABLE PIVOT COULD BE FOUND C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR C N LESS THAN 2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER. C C METHOD C THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY C LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF C CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS- C FORMED INTO A LINEAR PROGRAMMING PROBLEM. APMM USES A C REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL C PROBLEM. FOR REFERENCE, SEE C I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND C L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET, C NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306. C C .................................................................. C SUBROUTINE APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) C C DIMENSION TOP(1),IHE(1),PIV(1),T(1) DOUBLE PRECISION DSUM C C TEST ON WRONG INPUT PARAMETERS N AND M IER=-1 IF (N-1) 81,81,1 1 IF(M) 81,81,2 C C INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU 2 IER=0 C C PREPARE TOP-ROW TOP DO 3 I=1,N K=I+N J=K+N TOP(J)=TOP(K) 3 TOP(K)=-TOP(I) C C PREPARE INVERSE TRANSFORMATION MATRIX T L=M+2 LL=L*L DO 4 I=1,LL 4 T(I)=0. K=1 J=L+1 DO 5 I=1,L T(K)=1. 5 K=K+J C C PREPARE INDEX-VECTOR IHE DO 6 I=1,L K=I+L J=K+L IHE(I)=0 IHE(K)=I 6 IHE(J)=1-I NAN=N+N K=L+L+L J=K+NAN DO 7 I=1,NAN K=K+1 IHE(K)=I J=J+1 7 IHE(J)=I C C SET COUNTER ITER FOR ITERATION-STEPS ITER=-1 8 ITER=ITER+1 C C TEST FOR MAXIMUM ITERATION-STEPS IF(N+M-ITER) 9,9,10 9 IER=1 GO TO 69 C C DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP 10 ISE=0 IPIV=0 K=L+L+L SAVE=0. C C START TOP-LOOP DO 14 I=1,NAN IDO=K+I HELP=TOP(I) IF(HELP-SAVE) 12,12,11 11 SAVE=HELP IPIV=I 12 IF(IHE(IDO)) 14,13,14 13 ISE=I 14 CONTINUE C END OF TOP-LOOP C C IS OPTIMAL TABLEAU REACHED IF(IPIV) 69,69,15 C C DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE 15 ILAB=1 IND=0 J=ISE IF(J) 21,21,34 C C TRANSFER K-TH COLUMN FROM T TO PIV 16 K=(K-1)*L DO 17 I=1,L J=L+I K=K+1 17 PIV(J)=T(K) C C IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT 18 IF(ISE) 22,22,19 19 ISE=-ISE C C TRANSFER COLUMNS IN PIV J=L+1 IDO=L+L DO 20 I=J,IDO K=I+L 20 PIV(K)=PIV(I) 21 J=IPIV GO TO 34 C C SEARCH PIVOT-ELEMENT PIV(IND) 22 SAVE=1.E38 IDO=0 K=L+1 LL=L+L IND=0 C C START PIVOT-LOOP DO 29 I=K,LL J=I+L HELP=PIV(I) IF(HELP) 29,29,23 23 HELP=-HELP IF(ISE) 26,24,26 24 IF(IHE(J)) 27,25,27 25 IDO=I GO TO 29 26 HELP=-PIV(J)/HELP 27 IF(HELP-SAVE) 28,29,29 28 SAVE=HELP IND=I 29 CONTINUE C END OF PIVOT-LOOP C C TEST FOR SUITABLE PIVOT-ELEMENT IF(IND) 30,30,32 30 IF(IDO) 68,68,31 31 IND=IDO C PIVOT-ELEMENT IS STORED IN PIV(IND) C C COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI 32 REPI=1./PIV(IND) IND=IND-L C C UPDATE THE TOP-ROW TOP OF THE TABLEAU ILAB=0 SAVE=-TOP(IPIV)*REPI TOP(IPIV)=SAVE C C INITIALIZE J AS COUNTER FOR TOP-LOOP J=NAN 33 IF(J-IPIV) 34,53,34 34 K=0 C C SEARCH COLUMN IN TRANSFORMATION-MATRIX T DO 36 I=1,L IF(IHE(I)-J) 36,35,36 35 K=I IF(ILAB) 50,50,16 36 CONTINUE C C GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX I=L+L+L+NAN+J I=IHE(I)-N IF(I) 37,37,38 37 I=I+N K=1 38 I=I+NAN C C CALL SUBROUTINE FCT CALL FCT(PIV,TOP(I),M-1) C C PREPARE THE CALLED VECTOR PIV DSUM=0.D0 IDO=M DO 41 I=1,M HELP=PIV(IDO) IF(K) 39,39,40 39 HELP=-HELP 40 DSUM=DSUM+DBLE(HELP) PIV(IDO+1)=HELP 41 IDO=IDO-1 PIV(L)=-DSUM PIV(1)=1. C C TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T IDO=IND IF(ILAB) 44,44,42 42 K=1 43 IDO=K 44 DSUM=0.D0 HELP=0. C C START MULTIPLICATION-LOOP DO 46 I=1,L DSUM=DSUM+DBLE(PIV(I)*T(IDO)) TOL=ABS(SNGL(DSUM)) IF(TOL-HELP) 46,46,45 45 HELP=TOL 46 IDO=IDO+L C END OF MULTIPLICATION-LOOP C TOL=1.E-5*HELP IF(ABS(SNGL(DSUM))-TOL) 47,47,48 47 DSUM=0.D0 48 IF(ILAB) 51,51,49 49 I=K+L PIV(I)=DSUM C C TEST FOR LAST COLUMN-TERM K=K+1 IF(K-L) 43,43,18 50 I=(K-1)*L+IND DSUM=T(I) C C COMPUTE NEW TOP-ELEMENT 51 DSUM=DSUM*DBLE(SAVE) TOL=1.E-5*ABS(SNGL(DSUM)) TOP(J)=TOP(J)+SNGL(DSUM) IF(ABS(TOP(J))-TOL) 52,52,53 52 TOP(J)=0. C C TEST FOR LAST TOP-TERM 53 J=J-1 IF(J) 54,54,33 C END OF TOP-LOOP C C TRANSFORM PIVOT-COLUMN 54 I=IND+L PIV(I)=-1. DO 55 I=1,L J=I+L 55 PIV(I)=-PIV(J)*REPI C C UPDATE TRANSFORMATION-MATRIX T J=0 DO 57 I=1,L IDO=J+IND SAVE=T(IDO) T(IDO)=0. DO 56 K=1,L ISE=K+J 56 T(ISE)=T(ISE)+SAVE*PIV(K) 57 J=J+L C C UPDATE INDEX-VECTOR IHE C INITIALIZE CHARACTERISTICS J=0 K=0 ISE=0 IDO=0 C C START QUESTION-LOOP DO 61 I=1,L LL=I+L ILAB=IHE(LL) IF(IHE(I)-IPIV) 59,58,59 58 ISE=I J=ILAB 59 IF(ILAB-IND) 61,60,61 60 IDO=I K=IHE(I) 61 CONTINUE C END OF QUESTION-LOOP C C START MODIFICATION IF(K) 62,62,63 62 IHE(IDO)=IPIV IF(ISE) 67,67,65 63 IF(IND-J) 64,66,64 64 LL=L+L+L+NAN K=K+LL I=IPIV+LL ILAB=IHE(K) IHE(K)=IHE(I) IHE(I)=ILAB IF(ISE) 67,67,65 65 IDO=IDO+L I=ISE+L IHE(IDO)=J IHE(I)=IND 66 IHE(ISE)=0 67 LL=L+L J=LL+IND I=LL+L+IPIV ILAB=IHE(I) IHE(I)=IHE(J) IHE(J)=ILAB C END OF MODIFICATION C GO TO 8 C C SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND 68 IER=-1 C C EVALUATE FINAL TABLEAU C COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND C HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS 69 SAVE=0. HELP=0. K=L+L+L DO 73 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 71,70,73 70 SAVE=-TOP(I) 71 IF(M+J+1) 73,72,73 72 HELP=TOP(I) 73 CONTINUE C C PREPARE T,TOP,PIV T(1)=SAVE IDO=NAN+1 J=NAN+N DO 74 I=IDO,J 74 TOP(I)=SAVE DO 75 I=1,M 75 PIV(I)=HELP C C COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI C AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N) DO 79 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 76,79,77 76 J=-J PIV(J)=HELP-TOP(I) GO TO 79 77 IF(J-N) 78,78,79 78 J=J+NAN TOP(J)=SAVE+TOP(I) 79 CONTINUE DO 80 I=1,N IDO=NAN+I 80 TOP(I)=TOP(IDO) 81 RETURN END C C .................................................................. C C SUBROUTINE ARAT C C PURPOSE C CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE C FUNCTION IN THE LEAST SQUARES SENSE C C USAGE C CALL ARAT(DATI,N,WORK,P,IP,IQ,IER) C C DESCRIPTION OF PARAMETERS C DATI - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS C THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS, C THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND C THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY. C IF NO WEIGHTS ARE TO BE USED THEN THE THIRD C COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT C WHICH MUST CONTAIN A NONPOSITIVE VALUE C N - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION C WORK - WORKING STORAGE WHICH IS OF DIMENSION C (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST. C ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED C IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF C THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO C WORK(3*N) C P - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND C NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ C LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP C LOCATIONS. C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH. C IP - DIMENSION OF THE NUMERATOR (INPUT VALUE) C IQ - DIMENSION OF THE DENOMINATOR (INPUT VALUE) C IER - RESULTANT ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS C IER = 0 MEANS NO ERRORS C IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION C IER IS ALSO USED AS INPUT VALUE C A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN C INITIAL APPROXIMATION STORED IN P C C REMARKS C THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR C OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P C STARTING WITH LOW POWERS (DENOMINATOR FIRST). C IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE. C SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL C FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL C (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR C TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS. C IF A FIT IN OTHER FUNCTIONS IS REQUIRED, CNP AND CNPS MUST C BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C APLL, APFS, FRAT, CNPS, CNP C CNP IS REQUIRED WITHIN FRAT C C METHOD C THE ITERATIVE SCHEME USED FOR CALCULATION OF THE C APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS C WHICH ARE OBTAINED BY LINEARIZATION. C A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH C IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF C ZEROES WITHIN THE APPROXIMATION INTERVAL. C FOR REFERENCE SEE C D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN, C COMPUTING(1966), VOL.1, ED.3, PP.264-272. C D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION C OF NONLINEAR PARAMETERS, C JSIAM(1963), VOL.11, ED.2, PP.431-441. C C .................................................................. C SUBROUTINE ARAT(DATI,N,WORK,P,IP,IQ,IER) C C EXTERNAL FRAT C C DIMENSIONED LOCAL VARIABLE DIMENSION IERV(3) C C DIMENSIONED DUMMY VARIABLES DIMENSION DATI(1),WORK(1),P(1) C C INITIALIZE TESTVALUES LIMIT=20 ETA =1.E-11 EPS=1.E-5 C C CHECK FOR FORMAL ERRORS IF(N)4,4,1 1 IF(IP)4,4,2 2 IF(IQ)4,4,3 3 IPQ=IP+IQ IF(N-IPQ)4,5,5 C C ERROR RETURN IN CASE OF FORMAL ERRORS 4 IER=-1 RETURN C C INITIALIZE ITERATION PROCESS 5 KOUNT=0 IERV(2)=IP IERV(3)=IQ NDP=N+N+1 NNE=NDP+NDP IX=IPQ-1 IQP1=IQ+1 IRHS=NNE+IPQ*IX/2 IEND=IRHS+IX C C TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION IF(IER)8,6,8 C C INITIALIZE NUMERATOR AND DENOMINATOR 6 DO 7 I=2,IPQ 7 P(I)=0. P(1)=1. C C CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL C APPROXIMATION 8 DO 9 J=1,N T=DATI(J) I=J+N CALL CNPS(WORK(I),T,P(IQP1),IP) K=I+N 9 CALL CNPS(WORK(K),T,P,IQ) C C SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION) 10 CALL APLL(FRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV) C C CHECK FOR ZERO DENOMINATOR IF(IERV(1))4,11,4 11 INCR=0 RELAX=2. C C RESTORE MATRIX IN WORKING STORAGE 12 J=IEND DO 13 I=NNE,IEND J=J+1 13 WORK(I)=WORK(J) IF(KOUNT)14,14,15 C C SAVE SQUARE SUM OF ERRORS 14 OSUM=WORK(IEND) DIAG=OSUM*EPS K=IQ C C ADD CONSTANT TO DIAGONAL IF(WORK(NNE))17,17,19 15 IF(INCR)19,19,16 16 K=IPQ 17 J=NNE-1 DO 18 I=1,K WORK(J)=WORK(J)+DIAG 18 J=J+I C C SOLVE NORMAL EQUATIONS 19 CALL APFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER) C C CHECK FOR FAILURE OF EQUATION SOLVER IF(IRES)4,4,20 C C TEST FOR DEFECTIVE NORMALEQUATIONS 20 IF(IRES-IX)21,24,24 21 IF(INCR)22,22,23 22 DIAG=DIAG*0.125 23 DIAG=DIAG+DIAG INCR=INCR+1 C C START WITH OVER RELAXATION RELAX=8. IF(INCR-LIMIT)12,45,45 C C CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR 24 L=NDP J=NNE+IRES*(IRES-1)/2-1 K=J+IQ WORK(J)=0. IRQ=IQ IRP=IRES-IQ+1 IF(IRP)25,26,26 25 IRQ=IRES+1 26 DO 29 I=1,N T=DATI(I) WORK(I)=0. CALL CNPS(WORK(I),T,WORK(K),IRP) M=L+N CALL CNPS(WORK(M),T,WORK(J),IRQ) IF(WORK(M)*WORK(L))27,29,29 27 SUM=WORK(L)/WORK(M) IF(RELAX+SUM)29,29,28 28 RELAX=-SUM 29 L=L+1 C C MODIFY RELAXATION FACTOR IF NECESSARY SSOE=OSUM ITER=LIMIT 30 SUM=0. RELAX=RELAX*0.5 DO 32 I=1,N M=I+N K=M+N L=K+N SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L)) SAVE=SAVE*SAVE IF(DATI(NDP))32,32,31 31 SAVE=SAVE*DATI(K) 32 SUM=SUM+SAVE IF(ITER)45,33,33 33 ITER=ITER-1 IF(SUM-OSUM)34,37,35 34 OSUM=SUM GOTO 30 C C TEST FOR IMPROVEMENT 35 IF(OSUM-SSOE)36,30,30 36 RELAX=RELAX+RELAX 37 T=0. SAVE=0. K=IRES+1 DO 38 I=2,K J=J+1 T=T+ABS(P(I)) P(I)=P(I)+RELAX*WORK(J) 38 SAVE=SAVE+ABS(P(I)) C C UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR DO 39 I=1,N J=I+N K=J+N L=K+N WORK(J)=WORK(J)+RELAX*WORK(I) 39 WORK(K)=WORK(K)+RELAX*WORK(L) C C TEST FOR CONVERGENCE IF(INCR)40,40,42 40 IF(SSOE-OSUM-RELAX*EPS*OSUM)46,46,41 41 IF(ABS(T-SAVE)-RELAX*EPS*SAVE)46,46,42 42 IF(OSUM-ETA*SAVE)46,46,43 43 KOUNT=KOUNT+1 IF(KOUNT-LIMIT)10,44,44 C C ERROR RETURN IN CASE OF POOR CONVERGENCE 44 IER=2 RETURN 45 IER=1 RETURN C C NORMAL RETURN 46 IER=0 RETURN END C C .................................................................. C C SUBROUTINE ARRAY C C PURPOSE C CONVERT DATA ARRAY FROM SINGLE TO DOUBLE DIMENSION OR VICE C VERSA. THIS SUBROUTINE IS USED TO LINK THE USER PROGRAM C WHICH HAS DOUBLE DIMENSION ARRAYS AND THE SSP SUBROUTINES C WHICH OPERATE ON ARRAYS OF DATA IN A VECTOR FASHION. C C USAGE C CALL ARRAY (MODE,I,J,N,M,S,D) C C DESCRIPTION OF PARAMETERS C MODE - CODE INDICATING TYPE OF CONVERSION C 1 - FROM SINGLE TO DOUBLE DIMENSION C 2 - FROM DOUBLE TO SINGLE DIMENSION C I - NUMBER OF ROWS IN ACTUAL DATA MATRIX C J - NUMBER OF COLUMNS IN ACTUAL DATA MATRIX C N - NUMBER OF ROWS SPECIFIED FOR THE MATRIX D IN C DIMENSION STATEMENT C M - NUMBER OF COLUMNS SPECIFIED FOR THE MATRIX D IN C DIMENSION STATEMENT C S - IF MODE=1, THIS VECTOR IS INPUT WHICH CONTAINS THE C ELEMENTS OF A DATA MATRIX OF SIZE I BY J. COLUMN I+1 C OF DATA MATRIX FOLLOWS COLUMN I, ETC. IF MODE=2, C THIS VECTOR IS OUTPUT REPRESENTING A DATA MATRIX OF C SIZE I BY J CONTAINING ITS COLUMNS CONSECUTIVELY. C THE LENGTH OF S IS IJ, WHERE IJ=I*J. C D - IF MODE=1, THIS MATRIX OF SIZE N BY M IS OUTPUT, C CONTAINING A DATA MATRIX OF SIZE I BY J IN THE FIRST C I ROWS AND J COLUMNS. IF MODE=2, THIS N BY M MATRIX C IS INPUT CONTAINING A DATA MATRIX OF SIZE I BY J IN C THE FIRST I ROWS AND J COLUMNS. C C REMARKS C VECTOR S CAN BE IN THE SAME LOCATION AS MATRIX D. VECTOR S C IS REFERRED AS A MATRIX IN OTHER SSP ROUTINES, SINCE IT C CONTAINS A DATA MATRIX. C THIS SUBROUTINE CONVERTS ONLY GENERAL DATA MATRICES (STORAGE C MODE OF 0). C C SUBROUTINES AND FUNCTION SUBROUTINES REQUIRED C NONE C C METHOD C REFER TO THE DISCUSSION ON VARIABLE DATA SIZE IN THE SECTION C DESCRIBING OVERALL RULES FOR USAGE IN THIS MANUAL. C C .................................................................. C SUBROUTINE ARRAY (MODE,I,J,N,M,S,D) DIMENSION S(1),D(1) C NI=N-I C C TEST TYPE OF CONVERSION C IF(MODE-1) 100, 100, 120 C C CONVERT FROM SINGLE TO DOUBLE DIMENSION C 100 IJ=I*J+1 NM=N*J+1 DO 110 K=1,J NM=NM-NI DO 110 L=1,I IJ=IJ-1 NM=NM-1 110 D(NM)=S(IJ) GO TO 140 C C CONVERT FROM DOUBLE TO SINGLE DIMENSION C 120 IJ=0 NM=0 DO 130 K=1,J DO 125 L=1,I IJ=IJ+1 NM=NM+1 125 S(IJ)=D(NM) 130 NM=NM+NI C 140 RETURN END C C .................................................................. C C SUBROUTINE ATEIG C C PURPOSE C COMPUTE THE EIGENVALUES OF A REAL ALMOST TRIANGULAR MATRIX C C USAGE C CALL ATEIG(M,A,RR,RI,IANA,IA) C C DESCRIPTION OF THE PARAMETERS C M ORDER OF THE MATRIX C A THE INPUT MATRIX, M BY M C RR VECTOR CONTAINING THE REAL PARTS OF THE EIGENVALUES C ON RETURN C RI VECTOR CONTAINING THE IMAGINARY PARTS OF THE EIGEN- C VALUES ON RETURN C IANA VECTOR WHOSE DIMENSION MUST BE GREATER THAN OR EQUAL C TO M, CONTAINING ON RETURN INDICATIONS ABOUT THE WAY C THE EIGENVALUES APPEARED (SEE MATH. DESCRIPTION) C IA SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A C IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE C SUBSCRIPTED DATA STORAGE MODE. C IA=M WHEN THE MATRIX IS IN SSP VECTOR STORAGE MODE. C C REMARKS C THE ORIGINAL MATRIX IS DESTROYED C THE DIMENSION OF RR AND RI MUST BE GREATER OR EQUAL TO M C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C QR DOUBLE ITERATION C C REFERENCES C J.G.F. FRANCIS - THE QR TRANSFORMATION---THE COMPUTER C JOURNAL, VOL. 4, NO. 3, OCTOBER 1961, VOL. 4, NO. 4, JANUARY C 1962. J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM - C CLARENDON PRESS, OXFORD, 1965. C C .................................................................. C SUBROUTINE ATEIG(M,A,RR,RI,IANA,IA) DIMENSION A(1),RR(1),RI(1),PRR(2),PRI(2),IANA(1) INTEGER P,P1,Q C E7=1.0E-8 E6=1.0E-6 E10=1.0E-10 DELTA=0.5 MAXIT=30 C C INITIALIZATION C N=M 20 N1=N-1 IN=N1*IA NN=IN+N IF(N1) 30,1300,30 30 NP=N+1 C C ITERATION COUNTER C IT=0 C C ROOTS OF THE 2ND ORDER MAIN SUBMATRIX AT THE PREVIOUS C ITERATION C DO 40 I=1,2 PRR(I)=0.0 40 PRI(I)=0.0 C C LAST TWO SUBDIAGONAL ELEMENTS AT THE PREVIOUS ITERATION C PAN=0.0 PAN1=0.0 C C ORIGIN SHIFT C R=0.0 S=0.0 C C ROOTS OF THE LOWER MAIN 2 BY 2 SUBMATRIX C N2=N1-1 IN1=IN-IA NN1=IN1+N N1N=IN+N1 N1N1=IN1+N1 60 T=A(N1N1)-A(NN) U=T*T V=4.0*A(N1N)*A(NN1) IF(ABS(V)-U*E7) 100,100,65 65 T=U+V IF(ABS(T)-AMAX1(U,ABS(V))*E6) 67,67,68 67 T=0.0 68 U=(A(N1N1)+A(NN))/2.0 V=SQRT(ABS(T))/2.0 IF(T)140,70,70 70 IF(U) 80,75,75 75 RR(N1)=U+V RR(N)=U-V GO TO 130 80 RR(N1)=U-V RR(N)=U+V GO TO 130 100 IF(T)120,110,110 110 RR(N1)=A(N1N1) RR(N)=A(NN) GO TO 130 120 RR(N1)=A(NN) RR(N)=A(N1N1) 130 RI(N)=0.0 RI(N1)=0.0 GO TO 160 140 RR(N1)=U RR(N)=U RI(N1)=V RI(N)=-V 160 IF(N2)1280,1280,180 C C TESTS OF CONVERGENCE C 180 N1N2=N1N1-IA RMOD=RR(N1)*RR(N1)+RI(N1)*RI(N1) EPS=E10*SQRT(RMOD) IF(ABS(A(N1N2))-EPS)1280,1280,240 240 IF(ABS(A(NN1))-E10*ABS(A(NN))) 1300,1300,250 250 IF(ABS(PAN1-A(N1N2))-ABS(A(N1N2))*E6) 1240,1240,260 260 IF(ABS(PAN-A(NN1))-ABS(A(NN1))*E6)1240,1240,300 300 IF(IT-MAXIT) 320,1240,1240 C C COMPUTE THE SHIFT C 320 J=1 DO 360 I=1,2 K=NP-I IF(ABS(RR(K)-PRR(I))+ABS(RI(K)-PRI(I))-DELTA*(ABS(RR(K)) 1 +ABS(RI(K)))) 340,360,360 340 J=J+I 360 CONTINUE GO TO (440,460,460,480),J 440 R=0.0 S=0.0 GO TO 500 460 J=N+2-J R=RR(J)*RR(J) S=RR(J)+RR(J) GO TO 500 480 R=RR(N)*RR(N1)-RI(N)*RI(N1) S=RR(N)+RR(N1) C C SAVE THE LAST TWO SUBDIAGONAL TERMS AND THE ROOTS OF THE C SUBMATRIX BEFORE ITERATION C 500 PAN=A(NN1) PAN1=A(N1N2) DO 520 I=1,2 K=NP-I PRR(I)=RR(K) 520 PRI(I)=RI(K) C C SEARCH FOR A PARTITION OF THE MATRIX, DEFINED BY P AND Q C P=N2 IF (N-3)600,600,525 525 IPI=N1N2 DO 580 J=2,N2 IPI=IPI-IA-1 IF(ABS(A(IPI))-EPS) 600,600,530 530 IPIP=IPI+IA IPIP2=IPIP+IA D=A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R IF(D)540,560,540 540 IF(ABS(A(IPI)*A(IPIP+1))*(ABS(A(IPIP)+A(IPIP2+1)-S)+ABS(A(IPIP2+2) 1 )) -ABS(D)*EPS) 620,620,560 560 P=N1-J 580 CONTINUE 600 Q=P GO TO 680 620 P1=P-1 Q=P1 IF (P1-1) 680,680,650 650 DO 660 I=2, P1 IPI=IPI-IA-1 IF(ABS(A(IPI))-EPS)680,680,660 660 Q=Q-1 C C QR DOUBLE ITERATION C 680 II=(P-1)*IA+P DO 1220 I=P,N1 II1=II-IA IIP=II+IA IF(I-P)720,700,720 700 IPI=II+1 IPIP=IIP+1 C C INITIALIZATION OF THE TRANSFORMATION C G1=A(II)*(A(II)-S)+A(IIP)*A(IPI)+R G2=A(IPI)*(A(IPIP)+A(II)-S) G3=A(IPI)*A(IPIP+1) A(IPI+1)=0.0 GO TO 780 720 G1=A(II1) G2=A(II1+1) IF(I-N2)740,740,760 740 G3=A(II1+2) GO TO 780 760 G3=0.0 780 CAP=SQRT(G1*G1+G2*G2+G3*G3) IF(CAP)800,860,800 800 IF(G1)820,840,840 820 CAP=-CAP 840 T=G1+CAP PSI1=G2/T PSI2=G3/T ALPHA=2.0/(1.0+PSI1*PSI1+PSI2*PSI2) GO TO 880 860 ALPHA=2.0 PSI1=0.0 PSI2=0.0 880 IF(I-Q)900,960,900 900 IF(I-P)920,940,920 920 A(II1)=-CAP GO TO 960 940 A(II1)=-A(II1) C C ROW OPERATION C 960 IJ=II DO 1040 J=I,N T=PSI1*A(IJ+1) IF(I-N1)980,1000,1000 980 IP2J=IJ+2 T=T+PSI2*A(IP2J) 1000 ETA=ALPHA*(T+A(IJ)) A(IJ)=A(IJ)-ETA A(IJ+1)=A(IJ+1)-PSI1*ETA IF(I-N1)1020,1040,1040 1020 A(IP2J)=A(IP2J)-PSI2*ETA 1040 IJ=IJ+IA C C COLUMN OPERATION C IF(I-N1)1080,1060,1060 1060 K=N GO TO 1100 1080 K=I+2 1100 IP=IIP-I DO 1180 J=Q,K JIP=IP+J JI=JIP-IA T=PSI1*A(JIP) IF(I-N1)1120,1140,1140 1120 JIP2=JIP+IA T=T+PSI2*A(JIP2) 1140 ETA=ALPHA*(T+A(JI)) A(JI)=A(JI)-ETA A(JIP)=A(JIP)-ETA*PSI1 IF(I-N1)1160,1180,1180 1160 A(JIP2)=A(JIP2)-ETA*PSI2 1180 CONTINUE IF(I-N2)1200,1220,1220 1200 JI=II+3 JIP=JI+IA JIP2=JIP+IA ETA=ALPHA*PSI2*A(JIP2) A(JI)=-ETA A(JIP)=-ETA*PSI1 A(JIP2)=A(JIP2)-ETA*PSI2 1220 II=IIP+1 IT=IT+1 GO TO 60 C C END OF ITERATION C 1240 IF(ABS(A(NN1))-ABS(A(N1N2))) 1300,1280,1280 C C TWO EIGENVALUES HAVE BEEN FOUND C 1280 IANA(N)=0 IANA(N1)=2 N=N2 IF(N2)1400,1400,20 C C ONE EIGENVALUE HAS BEEN FOUND C 1300 RR(N)=A(NN) RI(N)=0.0 IANA(N)=1 IF(N1)1400,1400,1320 1320 N=N1 GO TO 20 1400 RETURN END C C .................................................................. C C SUBROUTINE ATSE C C PURPOSE C NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE C SELECTED AND ORDERED SUCH THAT C ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL ATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - THE SEARCH ARGUMENT. C ZS - THE STARTING VALUE OF ARGUMENTS. C DZ - THE INCREMENT OF ARGUMENT VALUES. C F - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES C (DIMENSION IROW). C IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST C COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND C THE SECOND THE VECTOR OF DERIVATIVES. C IROW - THE DIMENSION OF EACH COLUMN IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - THE RESULTING VECTOR OF SELECTED AND ORDERED C ARGUMENT VALUES (DIMENSION NDIM). C VAL - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES C (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2, C VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES C (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. C EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE C VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE. C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE ATSE. C SUBROUTINE ATSE ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT C ARGUMENT, WHICH IS NEXT TO X. C AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND C SELECTED IN THE ABOVE SENSE. C C .................................................................. C SUBROUTINE ATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION F(1),ARG(1),VAL(1) IF(IROW-1)19,17,1 C C CASE DZ=0 IS CHECKED OUT 1 IF(DZ)2,17,2 2 N=NDIM C C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)4,4,3 3 N=IROW C C COMPUTATION OF STARTING SUBSCRIPT J. 4 J=(X-ZS)/DZ+1.5 IF(J)5,5,6 5 J=1 6 IF(J-IROW)8,8,7 7 J=IROW C C GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0. 8 II=J JL=0 JR=0 DO 16 I=1,N ARG(I)=ZS+FLOAT(II-1)*DZ IF(ICOL-2)9,10,10 9 VAL(I)=F(II) GOTO 11 10 VAL(2*I-1)=F(II) III=II+IROW VAL(2*I)=F(III) 11 IF(J+JR-IROW)12,15,12 12 IF(J-JL-1)13,14,13 13 IF((ARG(I)-X)*DZ)14,15,15 14 JR=JR+1 II=J+JR GOTO 16 15 JL=JL+1 II=J-JL 16 CONTINUE RETURN C C CASE DZ=0 17 ARG(1)=ZS VAL(1)=F(1) IF(ICOL-2)19,19,18 18 VAL(2)=F(2) 19 RETURN END C C .................................................................. C C SUBROUTINE ATSG C C PURPOSE C NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND C ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL ATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - THE SEARCH ARGUMENT. C Z - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW). C F - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES C (DIMENSION IROW). C IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST C COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND C THE SECOND THE VECTOR OF DERIVATIVES. C WORK - A WORKING STORAGE (DIMENSION IROW). C IROW - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH C COLUMN IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - THE RESULTING VECTOR OF SELECTED AND ORDERED C ARGUMENT VALUES (DIMENSION NDIM). C VAL - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES C (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2, C VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES C (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. C EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE C VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE (Z,F). C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE ATSG. C SUBROUTINE ATSG ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH C COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS C (OR IROW STEPS IF NDIM IS GREATER THAN IROW) C SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH C IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN C MAX(WORK(I)). C C .................................................................. C SUBROUTINE ATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1) IF(IROW)11,11,1 1 N=NDIM C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)3,3,2 2 N=IROW C C GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT. 3 B=0. DO 5 I=1,IROW DELTA=ABS(Z(I)-X) IF(DELTA-B)5,5,4 4 B=DELTA 5 WORK(I)=DELTA C C GENERATION OF TABLE (ARG,VAL) B=B+1. DO 10 J=1,N DELTA=B DO 7 I=1,IROW IF(WORK(I)-DELTA)6,7,7 6 II=I DELTA=WORK(I) 7 CONTINUE ARG(J)=Z(II) IF(ICOL-1)8,9,8 8 VAL(2*J-1)=F(II) III=II+IROW VAL(2*J)=F(III) GOTO 10 9 VAL(J)=F(II) 10 WORK(II)=B 11 RETURN END C C .................................................................. C C SUBROUTINE ATSM C C PURPOSE C NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE C SELECTED AND ORDERED SUCH THAT C ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL ATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - THE SEARCH ARGUMENT. C Z - THE VECTOR OF ARGUMENT VALUES (DIMENSION IROW). C THE ARGUMENT VALUES MUST BE STORED IN INCREASING C OR DECREASING SEQUENCE. C F - IN CASE ICOL=1, F IS THE VECTOR OF FUNCTION VALUES C (DIMENSION IROW). C IN CASE ICOL=2, F IS AN IROW BY 2 MATRIX. THE FIRST C COLUMN SPECIFIES THE VECTOR OF FUNCTION VALUES AND C THE SECOND THE VECTOR OF DERIVATIVES. C IROW - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN C IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - THE RESULTING VECTOR OF SELECTED AND ORDERED C ARGUMENT VALUES (DIMENSION NDIM). C VAL - THE RESULTING VECTOR OF SELECTED FUNCTION VALUES C (DIMENSION NDIM) IN CASE ICOL=1. IN CASE ICOL=2, C VAL IS THE VECTOR OF FUNCTION AND DERIVATIVE VALUES C (DIMENSION 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. C EACH FUNCTION VALUE IS FOLLOWED BY ITS DERIVATIVE C VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE (Z,F). C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE ATSM. C SUBROUTINE ATSM ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES ALI, AHI, AND ACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT C ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH). C AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND C SELECTED IN THE ABOVE SENSE. C C .................................................................. C SUBROUTINE ATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION Z(1),F(1),ARG(1),VAL(1) C C CASE IROW=1 IS CHECKED OUT IF(IROW-1)23,21,1 1 N=NDIM C C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)3,3,2 2 N=IROW C C CASE IROW.GE.2 C SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X. 3 IF(Z(IROW)-Z(1))5,4,4 4 J=IROW I=1 GOTO 6 5 I=IROW J=1 6 K=(J+I)/2 IF(X-Z(K))7,7,8 7 J=K GOTO 9 8 I=K 9 IF(IABS(J-I)-1)10,10,6 10 IF(ABS(Z(J)-X)-ABS(Z(I)-X))12,12,11 11 J=I C C TABLE SELECTION 12 K=J JL=0 JR=0 DO 20 I=1,N ARG(I)=Z(K) IF(ICOL-1)14,14,13 13 VAL(2*I-1)=F(K) KK=K+IROW VAL(2*I)=F(KK) GOTO 15 14 VAL(I)=F(K) 15 JJR=J+JR IF(JJR-IROW)16,18,18 16 JJL=J-JL IF(JJL-1)19,19,17 17 IF(ABS(Z(JJR+1)-X)-ABS(Z(JJL-1)-X))19,19,18 18 JL=JL+1 K=J-JL GOTO 20 19 JR=JR+1 K=J+JR 20 CONTINUE RETURN C C CASE IROW=1 21 ARG(1)=Z(1) VAL(1)=F(1) IF(ICOL-2)23,22,23 22 VAL(2)=F(2) 23 RETURN END C C .................................................................. C C SUBROUTINE AUTO C C PURPOSE C TO FIND AUTOCOVARIANCES OF SERIES A FOR LAGS 0 TO L-1. C C USAGE C CALL AUTO (A,N,L,R) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF LENGTH N CONTAINING THE TIME SERIES C WHOSE AUTOCOVARIANCE IS DESIRED. C N - LENGTH OF THE VECTOR A. C L - AUTOCOVARIANCE IS CALCULATED FOR LAGS OF 0, 1, 2,..., C L-1. C R - OUTPUT VECTOR OF LENGTH L CONTAINING AUTOCOVARIANCES C OF SERIES A. C C REMARKS C THE LENGTH OF R IS DIFFERENT FROM THE LENGTH OF A. N MUST C BE GREATER THAN L. IF NOT, R(1) IS SET TO ZERO AND RETURN C IS MADE TO THE CALLING PROGRAM. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT C OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959. C C .................................................................. C SUBROUTINE AUTO (A,N,L,R) DIMENSION A(1),R(1) C C CALCULATE AVERAGE OF TIME SERIES A C AVER=0.0 IF(N-L) 50,50,100 50 R(1)=0.0 RETURN 100 DO 110 I=1,N 110 AVER=AVER+A(I) FN=N AVER=AVER/FN C C CALCULATE AUTOCOVARIANCES C DO 130 J=1,L NJ=N-J+1 SUM=0.0 DO 120 I=1,NJ IJ=I+J-1 120 SUM=SUM+(A(I)-AVER)*(A(IJ)-AVER) FNJ=NJ 130 R(J)=SUM/FNJ RETURN END C C .................................................................. C C SUBROUTINE AVCAL C C PURPOSE C PERFORM THE CALCULUS OF A FACTORIAL EXPERIMENT USING C OPERATOR SIGMA AND OPERATOR DELTA. THIS SUBROUTINE IS C PRECEDED BY SUBROUTINE ADVAT AND FOLLOWED BY SUBROUTINE C MEANQ IN THE PERFORMANCE OF ANALYSIS OF VARIANCE FOR A C COMPLETE FACTORIAL DESIGN. C C USAGE C CALL AVCAL (K,LEVEL,X,L,ISTEP,LASTS) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE. C LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE- C GORIES) WITHIN EACH VARIABLE. C X - INPUT VECTOR CONTAINING DATA. DATA HAVE BEEN PLACED C IN VECTOR X BY SUBROUTINE AVDAT. THE LENGTH OF X C IS (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1). C L - THE POSITION IN VECTOR X WHERE THE LAST INPUT DATA C IS LOCATED. L HAS BEEN CALCULATED BY SUBROUTINE C AVDAT. C ISTEP - INPUT VECTOR OF LENGTH K CONTAINING STORAGE CONTROL C STEPS WHICH HAVE BEEN CALCULATED BY SUBROUTINE C AVDAT. C LASTS - WORKING VECTOR OF LENGTH K. C C REMARKS C THIS SUBROUTINE MUST FOLLOW SUBROUTINE AVDAT. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O. C HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', C EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS, C 1962, CHAPTER 20. C C .................................................................. C SUBROUTINE AVCAL (K,LEVEL,X,L,ISTEP,LASTS) DIMENSION LEVEL(1),X(1),ISTEP(1),LASTS(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION X,SUM C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C CALCULATE THE LAST DATA POSITION OF EACH FACTOR C LASTS(1)=L+1 DO 145 I=2,K 145 LASTS(I)=LASTS(I-1)+ISTEP(I) C C PERFORM CALCULUS OF OPERATION C 150 DO 175 I=1,K L=1 LL=1 SUM=0.0 NN=LEVEL(I) FN=NN INCRE=ISTEP(I) LAST=LASTS(I) C C SIGMA OPERATION C 155 DO 160 J=1,NN SUM=SUM+X(L) 160 L=L+INCRE X(L)=SUM C C DELTA OPERATION C DO 165 J=1,NN X(LL)=FN*X(LL)-SUM 165 LL=LL+INCRE SUM=0.0 IF(L-LAST) 167, 175, 175 167 IF(L-LAST+INCRE) 168, 168, 170 168 L=L+INCRE LL=LL+INCRE GO TO 155 170 L=L+INCRE+1-LAST LL=LL+INCRE+1-LAST GO TO 155 175 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE AVDAT C C PURPOSE C PLACE DATA FOR ANALYSIS OF VARIANCE IN PROPERLY DISTRIBUTED C POSITIONS OF STORAGE. THIS SUBROUTINE IS NORMALLY FOLLOWED C BY CALLS TO AVCAL AND MEANQ SUBROUTINES IN THE PERFORMANCE C OF ANALYSIS OF VARIANCE FOR A COMPLETE FACTORIAL DESIGN. C C USAGE C CALL AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE. C LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE- C GORIES) WITHIN EACH VARIABLE. C N - TOTAL NUMBER OF DATA POINTS READ IN. C X - WHEN THE SUBROUTINE IS CALLED, THIS VECTOR CONTAINS C DATA IN LOCATIONS X(1) THROUGH X(N). UPON RETURNING C TO THE CALLING ROUTINE, THE VECTOR CONTAINS THE DATA C IN PROPERLY REDISTRIBUTED LOCATIONS OF VECTOR X. C THE LENGTH OF VECTOR X IS CALCULATED BY (1) ADDING C ONE TO EACH LEVEL OF VARIABLE AND (2) OBTAINING THE C CUMULATIVE PRODUCT OF ALL LEVELS. (THE LENGTH OF C X = (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1).) C L - OUTPUT VARIABLE CONTAINING THE POSITION IN VECTOR X C WHERE THE LAST INPUT DATA IS STORED. C ISTEP - OUTPUT VECTOR OF LENGTH K CONTAINING CONTROL STEPS C WHICH ARE USED TO LOCATE DATA IN PROPER POSITIONS C OF VECTOR X. C KOUNT - WORKING VECTOR OF LENGTH K. C C REMARKS C INPUT DATA MUST BE ARRANGED IN THE FOLLOWING MANNER. C CONSIDER THE 3-VARIABLE ANALYSIS OF VARIANCE DESIGN, WHERE C ONE VARIABLE HAS 3 LEVELS AND THE OTHER TWO VARIABLES HAVE C 2 LEVELS. THE DATA MAY BE REPRESENTED IN THE FORM X(I,J,K), C I=1,2,3 J=1,2 K=1,2. IN ARRANGING DATA, THE INNER C SUBSCRIPT, NAMELY I, CHANGES FIRST. WHEN I=3, THE NEXT C INNER SUBSCRIPT, J, CHANGES AND SO ON UNTIL I=3, J=2, AND C K=2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O. C HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', C EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS, C 1962, CHAPTER 20. C C .................................................................. C SUBROUTINE AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT) DIMENSION LEVEL(1),X(1),ISTEP(1),KOUNT(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION X C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C CALCULATE TOTAL DATA AREA REQUIRED C M=LEVEL(1)+1 DO 105 I=2,K 105 M=M*(LEVEL(I)+1) C C MOVE DATA TO THE UPPER PART OF THE ARRAY X C FOR THE PURPOSE OF REARRANGEMENT C N1=M+1 N2=N+1 DO 107 I=1,N N1=N1-1 N2=N2-1 107 X(N1)=X(N2) C C CALCULATE MULTIPLIERS TO BE USED IN FINDING STORAGE LOCATIONS FOR C INPUT DATA C ISTEP(1)=1 DO 110 I=2,K 110 ISTEP(I)=ISTEP(I-1)*(LEVEL(I-1)+1) DO 115 I=1,K 115 KOUNT(I)=1 C C PLACE DATA IN PROPER LOCATIONS C N1=N1-1 DO 135 I=1,N L=KOUNT(1) DO 120 J=2,K 120 L=L+ISTEP(J)*(KOUNT(J)-1) N1=N1+1 X(L)=X(N1) DO 130 J=1,K IF(KOUNT(J)-LEVEL(J)) 124, 125, 124 124 KOUNT(J)=KOUNT(J)+1 GO TO 135 125 KOUNT(J)=1 130 CONTINUE 135 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE BDTR C C PURPOSE C COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U, C DISTRIBUTED ACCORDING TO THE BETA DISTRIBUTION WITH C PARAMETERS A AND B, IS LESS THAN OR EQUAL TO X. F(A,B,X), C THE ORDINATE OF THE BETA DENSITY AT X, IS ALSO COMPUTED. C C USAGE C CALL BDTR(X,A,B,P,D,IER) C C DESCRIPTION OF PARAMETERS C X - INPUT SCALAR FOR WHICH P(X) IS COMPUTED. C A - BETA DISTRIBUTION PARAMETER (CONTINUOUS). C B - BETA DISTRIBUTION PARAMETER (CONTINUOUS). C P - OUTPUT PROBABILITY. C D - OUTPUT DENSITY. C IER - RESULTANT ERROR CODE WHERE C IER= 0 --- NO ERROR C IER=-1,+1 CDTR HAS BEEN CALLED AND AN ERROR HAS C OCCURRED. SEE CDTR. C IER=-2 --- AN INPUT PARAMETER IS INVALID. X IS LESS C THAN 0.0 OR GREATER THAN 1.0, OR EITHER A OR C B IS LESS THAN 0.5 OR GREATER THAN 10**(+5). C P AND D ARE SET TO -1.7E38. 0 C IER=+2 --- INVALID OUTPUT. P IS LESS THAN ZERO OR C GREATER THAN ONE. P IS SET TO 1.7E38. 0 C C REMARKS C SEE MATHEMATICAL DESCRIPTION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DLGAM C NDTR C CDTR C C METHOD C REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL C DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE, C IBM RESEARCH REPORT RC-1094, 1963. C C .................................................................. C SUBROUTINE BDTR(X,A,B,P,D,IER) DOUBLE PRECISION XX,DLXX,DL1X,AA,BB,G1,G2,G3,G4,DD,PP,XO,FF,FN, 1XI,SS,CC,RR,DLBETA C C TEST FOR VALID INPUT DATA C IF(A-(.5-1.E-5)) 640,10,10 10 IF(B-(.5-1.E-5)) 640,20,20 20 IF(A-1.E+5) 30,30,640 30 IF(B-1.E+5) 40,40,640 40 IF(X) 640,50,50 50 IF(1.-X) 640,60,60 C C COMPUTE LOG(BETA(A,B)) C 60 AA=DBLE(A) BB=DBLE(B) CALL DLGAM(AA,G1,IOK) CALL DLGAM(BB,G2,IOK) CALL DLGAM(AA+BB,G3,IOK) DLBETA=G1+G2-G3 C C TEST FOR X NEAR 0.0 OR 1.0 C IF(X-1.E-8) 80,80,70 70 IF((1.-X)-1.E-8) 130,130,140 80 P=0.0 IF(A-1.) 90,100,120 90 D=1.7E38 GO TO 660 100 DD=-DLBETA IF(DD+1.68D02) 120,120,110 110 DD=DEXP(DD) D=SNGL(DD) GO TO 660 120 D=0.0 GO TO 660 130 P=1.0 IF(B-1.) 90,100,120 C C SET PROGRAM PARAMETERS C 140 XX=DBLE(X) DLXX=DLOG(XX) DL1X=DLOG(1.D0-XX) XO=XX/(1.D0-XX) ID=0 C C COMPUTE ORDINATE C DD=(AA-1.D0)*DLXX+(BB-1.D0)*DL1X-DLBETA IF(DD-1.68D02) 150,150,160 150 IF(DD+1.68D02) 170,170,180 160 D=1.7E38 0 GO TO 190 170 D=0.0 GO TO 190 180 DD=DEXP(DD) D=SNGL(DD) C C A OR B OR BOTH WITHIN 1.E-8 OF 1.0 C 190 IF(ABS(A-1.)-1.E-8) 200,200,210 200 IF(ABS(B-1.)-1.E-8) 220,220,230 210 IF(ABS(B-1.)-1.E-8) 260,260,290 220 P=X GO TO 660 230 PP=BB*DL1X IF(PP+1.68D02) 240,240,250 240 P=1.0 GO TO 660 250 PP=DEXP(PP) PP=1.D0-PP P=SNGL(PP) GO TO 600 260 PP=AA*DLXX IF(PP+1.68D02) 270,270,280 270 P=0.0 GO TO 660 280 PP=DEXP(PP) P=SNGL(PP) GO TO 600 C C TEST FOR A OR B GREATER THAN 1000.0 C 290 IF(A-1000.) 300,300,310 300 IF(B-1000.) 330,330,320 310 XX=2.D0*AA/XO XS=SNGL(XX) AA=2.D0*BB DF=SNGL(AA) CALL CDTR(XS,DF,P,DUMMY,IER) P=1.0-P GO TO 670 320 XX=2.D0*BB*XO XS=SNGL(XX) AA=2.D0*AA DF=SNGL(AA) CALL CDTR(XS,DF,P,DUMMY,IER) GO TO 670 C C SELECT PARAMETERS FOR CONTINUED FRACTION COMPUTATION C 330 IF(X-.5) 340,340,380 340 IF(AA-1.D0) 350,350,360 350 RR=AA+1.D0 GO TO 370 360 RR=AA 370 DD=DLXX/5.D0 DD=DEXP(DD) DD=(RR-1.D0)-(RR+BB-1.D0)*XX*DD +2.D0 IF(DD) 420,420,430 380 IF(BB-1.D0) 390,390,400 390 RR=BB+1.D0 GO TO 410 400 RR=BB 410 DD=DL1X/5.D0 DD=DEXP(DD) DD=(RR-1.D0)-(AA+RR-1.D0)*(1.D0-XX)*DD +2.D0 IF(DD) 430,430,420 420 ID=1 FF=DL1X DL1X=DLXX DLXX=FF XO=1.D0/XO FF=AA AA=BB BB=FF G2=G1 C C TEST FOR A LESS THAN 1.0 C 430 FF=0.D0 IF(AA-1.D0) 440,440,470 440 CALL DLGAM(AA+1.D0,G4,IOK) DD=AA*DLXX+BB*DL1X+G3-G2-G4 IF(DD+1.68D02) 460,460,450 450 FF=FF+DEXP(DD) 460 AA=AA+1.D0 C C COMPUTE P USING CONTINUED FRACTION EXPANSION C 470 FN=AA+BB-1.D0 RR=AA-1.D0 II=80 XI=DFLOAT(II) SS=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI)) SS=SS*XO DO 480 I=1,79 II=80-I XI=DFLOAT(II) DD=(XI*(FN+XI))/((RR+2.D0*XI+1.D0)*(RR+2.D0*XI)) DD=DD*XO CC=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI)) CC=CC*XO SS=CC/(1.D0+DD/(1.D0-SS)) 480 CONTINUE SS=1.D0/(1.D0-SS) IF(SS) 650,650,490 490 CALL DLGAM(AA+BB,G1,IOK) CALL DLGAM(AA+1.D0,G4,IOK) CC=G1-G2-G4+AA*DLXX+(BB-1.D0)*DL1X PP=CC+DLOG(SS) IF(PP+1.68D02) 500,500,510 500 PP=FF GO TO 520 510 PP=DEXP(PP)+FF 520 IF(ID) 540,540,530 530 PP=1.D0-PP 540 P=SNGL(PP) C C SET ERROR INDICATOR C IF(P) 550,570,570 550 IF(ABS(P)-1.E-7) 560,560,650 560 P=0.0 GO TO 660 570 IF(1.-P) 580,600,600 580 IF(ABS(1.-P)-1.E-7) 590,590,650 590 P=1.0 GO TO 660 600 IF(P-1.E-8) 610,610,620 610 P=0.0 GO TO 660 620 IF((1.0-P)-1.E-8) 630,630,660 630 P=1.0 GO TO 660 640 IER=-2 D=-1.7E38 0 P=-1.7E38 0 GO TO 670 650 IER=+2 P= 1.7E38 0 GO TO 670 660 IER=0 670 RETURN END C C .................................................................. C C SUBROUTINE BESJ C C PURPOSE C COMPUTE THE J BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER C C USAGE C CALL BESJ(X,N,BJ,D,IER) C C DESCRIPTION OF PARAMETERS C X -THE ARGUMENT OF THE J BESSEL FUNCTION DESIRED C N -THE ORDER OF THE J BESSEL FUNCTION DESIRED C BJ -THE RESULTANT J BESSEL FUNCTION C D -REQUIRED ACCURACY C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 N IS NEGATIVE C IER=2 X IS NEGATIVE OR ZERO C IER=3 REQUIRED ACCURACY NOT OBTAINED C IER=4 RANGE OF N COMPARED TO X NOT CORRECT (SEE REMARKS) C C REMARKS C N MUST BE GREATER THAN OR EQUAL TO ZERO, BUT IT MUST BE C LESS THAN C 20+10*X-X** 2/3 FOR X LESS THAN OR EQUAL TO 15 C 90+X/2 FOR X GREATER THAN 15 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C RECURRENCE RELATION TECHNIQUE DESCRIBED BY H. GOLDSTEIN AND C R.M. THALER,'RECURRENCE TECHNIQUES FOR THE CALCULATION OF C BESSEL FUNCTIONS',M.T.A.C.,V.13,PP.102-108 AND I.A. STEGUN C AND M. ABRAMOWITZ,'GENERATION OF BESSEL FUNCTIONS ON HIGH C SPEED COMPUTERS',M.T.A.C.,V.11,1957,PP.255-257 C C .................................................................. C SUBROUTINE BESJ(X,N,BJ,D,IER) C BJ=.0 IF(N)10,20,20 10 IER=1 RETURN 20 IF(X)30,30,31 30 IER=2 RETURN 31 IF(X-15.)32,32,34 32 NTEST=20.+10.*X-X** 2/3 GO TO 36 34 NTEST=90.+X/2. 36 IF(N-NTEST)40,38,38 38 IER=4 RETURN 40 IER=0 N1=N+1 BPREV=.0 C C COMPUTE STARTING VALUE OF M C IF(X-5.)50,60,60 50 MA=X+6. GO TO 70 60 MA=1.4*X+60./X 70 MB=N+IFIX(X)/4+2 MZERO=MAX0(MA,MB) C C SET UPPER LIMIT OF M C MMAX=NTEST 100 DO 190 M=MZERO,MMAX,3 C C SET F(M),F(M-1) C FM1=1.0E-28 FM=.0 ALPHA=.0 IF(M-(M/2)*2)120,110,120 110 JT=-1 GO TO 130 120 JT=1 130 M2=M-2 DO 160 K=1,M2 MK=M-K BMK=2.*FLOAT(MK)*FM1/X-FM FM=FM1 FM1=BMK IF(MK-N-1)150,140,150 140 BJ=BMK 150 JT=-JT S=1+JT 160 ALPHA=ALPHA+BMK*S BMK=2.*FM1/X-FM IF(N)180,170,180 170 BJ=BMK 180 ALPHA=ALPHA+BMK BJ=BJ/ALPHA IF(ABS(BJ-BPREV)-ABS(D*BJ))200,200,190 190 BPREV=BJ IER=3 200 RETURN END C C .................................................................. C C SUBROUTINE BESK C C COMPUTE THE K BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER C C USAGE C CALL BESK(X,N,BK,IER) C C DESCRIPTION OF PARAMETERS C X -THE ARGUMENT OF THE K BESSEL FUNCTION DESIRED C N -THE ORDER OF THE K BESSEL FUNCTION DESIRED C BK -THE RESULTANT K BESSEL FUNCTION C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 N IS NEGATIVE C IER=2 X IS ZERO OR NEGATIVE C IER=3 X .GT. 170, MACHINE RANGE EXCEEDED C IER=4 BK .GT. 10**70 C C REMARKS C N MUST BE GREATER THAN OR EQUAL TO ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C COMPUTES ZERO ORDER AND FIRST ORDER BESSEL FUNCTIONS USING C SERIES APPROXIMATIONS AND THEN COMPUTES N TH ORDER FUNCTION C USING RECURRENCE RELATION. C RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE C AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS C TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED C FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON, C 'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE C UNIVERSITY PRESS, 1958, P. 62 C C .................................................................. C SUBROUTINE BESK(X,N,BK,IER) DIMENSION T(12) BK=.0 IF(N)10,11,11 10 IER=1 RETURN 11 IF(X)12,12,20 12 IER=2 RETURN 20 IF(X-170.0)22,22,21 21 IER=3 RETURN 22 IER=0 IF(X-1.)36,36,25 25 A=EXP(-X) B=1./X C=SQRT(B) T(1)=B DO 26 L=2,12 26 T(L)=T(L-1)*B IF(N-1)27,29,27 C C COMPUTE KO USING POLYNOMIAL APPROXIMATION C 27 G0=A*(1.2533141-.1566642*T(1)+.08811128*T(2)-.09139095*T(3) 2+.1344596*T(4)-.2299850*T(5)+.3792410*T(6)-.5247277*T(7) 3+.5575368*T(8)-.4262633*T(9)+.2184518*T(10)-.06680977*T(11) 4+.009189383*T(12))*C IF(N)20,28,29 28 BK=G0 RETURN C C COMPUTE K1 USING POLYNOMIAL APPROXIMATION C 29 G1=A*(1.2533141+.4699927*T(1)-.1468583*T(2)+.1280427*T(3) 2-.1736432*T(4)+.2847618*T(5)-.4594342*T(6)+.6283381*T(7) 3-.6632295*T(8)+.5050239*T(9)-.2581304*T(10)+.07880001*T(11) 4-.01082418*T(12))*C IF(N-1)20,30,31 30 BK=G1 RETURN C C FROM KO,K1 COMPUTE KN USING RECURRENCE RELATION C 31 DO 35 J=2,N GJ=2.*(FLOAT(J)-1.)*G1/X+G0 IF(GJ-1.7E33)33,33,32 32 IER=4 GO TO 34 33 G0=G1 35 G1=GJ 34 BK=GJ RETURN 36 B=X/2. A=.5772157+ALOG(B) C=B*B IF(N-1)37,43,37 C C COMPUTE KO USING SERIES EXPANSION C 37 G0=-A X2J=1. FACT=1. HJ=.0 DO 40 J=1,6 RJ=1./FLOAT(J) X2J=X2J*C FACT=FACT*RJ*RJ HJ=HJ+RJ 40 G0=G0+X2J*FACT*(HJ-A) IF(N)43,42,43 42 BK=G0 RETURN C C COMPUTE K1 USING SERIES EXPANSION C 43 X2J=B FACT=1. HJ=1. G1=1./X+X2J*(.5+A-HJ) DO 50 J=2,8 X2J=X2J*C RJ=1./FLOAT(J) FACT=FACT*RJ*RJ HJ=HJ+RJ 50 G1=G1+X2J*FACT*(.5+(A-HJ)*FLOAT(J)) IF(N-1)31,52,31 52 BK=G1 RETURN END C C .................................................................. C C SUBROUTINE BESY C C PURPOSE C COMPUTE THE Y BESSEL FUNCTION FOR A GIVEN ARGUMENT AND ORDER C C USAGE C CALL BESY(X,N,BY,IER) C C DESCRIPTION OF PARAMETERS C X -THE ARGUMENT OF THE Y BESSEL FUNCTION DESIRED C N -THE ORDER OF THE Y BESSEL FUNCTION DESIRED C BY -THE RESULTANT Y BESSEL FUNCTION C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 N IS NEGATIVE C IER=2 X IS NEGATIVE OR ZERO C IER=3 BY HAS EXCEEDED MAGNITUDE OF 10**70 C C REMARKS C VERY SMALL VALUES OF X MAY CAUSE THE RANGE OF THE LIBRARY C FUNCTION ALOG TO BE EXCEEDED C X MUST BE GREATER THAN ZERO C N MUST BE GREATER THAN OR EQUAL TO ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C RECURRENCE RELATION AND POLYNOMIAL APPROXIMATION TECHNIQUE C AS DESCRIBED BY A.J.M.HITCHCOCK,'POLYNOMIAL APPROXIMATIONS C TO BESSEL FUNCTIONS OF ORDER ZERO AND ONE AND TO RELATED C FUNCTIONS', M.T.A.C., V.11,1957,PP.86-88, AND G.N. WATSON, C 'A TREATISE ON THE THEORY OF BESSEL FUNCTIONS', CAMBRIDGE C UNIVERSITY PRESS, 1958, P. 62 C C .................................................................. C SUBROUTINE BESY(X,N,BY,IER) C C CHECK FOR ERRORS IN N AND X C IF(N)180,10,10 10 IER=0 IF(X)190,190,20 C C BRANCH IF X LESS THAN OR EQUAL 4 C 20 IF(X-4.0)40,40,30 C C COMPUTE Y0 AND Y1 FOR X GREATER THAN 4 C 30 T1=4.0/X T2=T1*T1 P0=((((-.0000037043*T2+.0000173565)*T2-.0000487613)*T2 1 +.00017343)*T2-.001753062)*T2+.3989423 Q0=((((.0000032312*T2-.0000142078)*T2+.0000342468)*T2 1 -.0000869791)*T2+.0004564324)*T2-.01246694 P1=((((.0000042414*T2-.0000200920)*T2+.0000580759)*T2 1 -.000223203)*T2+.002921826)*T2+.3989423 Q1=((((-.0000036594*T2+.00001622)*T2-.0000398708)*T2 1 +.0001064741)*T2-.0006390400)*T2+.03740084 A=2.0/SQRT(X) B=A*T1 C=X-.7853982 Y0=A*P0*SIN(C)+B*Q0*COS(C) Y1=-A*P1*COS(C)+B*Q1*SIN(C) GO TO 90 C C COMPUTE Y0 AND Y1 FOR X LESS THAN OR EQUAL TO 4 C 40 XX=X/2. X2=XX*XX T=ALOG(XX)+.5772157 SUM=0. TERM=T Y0=T DO 70 L=1,15 IF(L-1)50,60,50 50 SUM=SUM+1./FLOAT(L-1) 60 FL=L TS=T-SUM TERM=(TERM*(-X2)/FL**2)*(1.-1./(FL*TS)) 70 Y0=Y0+TERM TERM = XX*(T-.5) SUM=0. Y1=TERM DO 80 L=2,16 SUM=SUM+1./FLOAT(L-1) FL=L FL1=FL-1. TS=T-SUM TERM=(TERM*(-X2)/(FL1*FL))*((TS-.5/FL)/(TS+.5/FL1)) 80 Y1=Y1+TERM PI2=.6366198 Y0=PI2*Y0 Y1=-PI2/X+PI2*Y1 C C CHECK IF ONLY Y0 OR Y1 IS DESIRED C 90 IF(N-1)100,100,130 C C RETURN EITHER Y0 OR Y1 AS REQUIRED C 100 IF(N)110,120,110 110 BY=Y1 GO TO 170 120 BY=Y0 GO TO 170 C CP ERFORM RECURRENCE OPERATIONS TO FIND YN(X) C 130 YA=Y0 YB=Y1 K=1 140 T=FLOAT(2*K)/X YC=T*YB-YA IF(ABS(YC)-1.7E33)145,145,141 141 IER=3 RETURN 145 K=K+1 IF(K-N)150,160,150 150 YA=YB YB=YC GO TO 140 160 BY=YC 170 RETURN 180 IER=1 RETURN 190 IER=2 RETURN END C C .................................................................. C C SUBROUTINE BISER C C PURPOSE C TO COMPUTE THE BISERIAL CORRELATION COEFFICIENT BETWEEN TWO C CONTINUOUS VARIABLES WHEN ONE OF THEM HAS BEEN ARTIFICIALLY C DICHOTOMIZED. C C USAGE C CALL BISER (N,A,B,HI,ANS,IER) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS C A - INPUT VECTOR OF LENGTH N CONTAINING THE CONTINUOUS C VARIABLE C B - INPUT VECTOR OF LENGTH N CONTAINING THE DICHOTOMIZED C VARIABLE C HI - INPUT - NUMERICAL CODE TO INDICATE THE HIGHER CATEGORY C OF THE DICHOTOMIZED VARIABLE. ANY VALUE IN VECTOR B C EQUAL TO OR GREATER THAN HI WILL BE CLASSIFIED INTO C THE HIGHER CATEGORY. C ANS - OUTPUT VECTOR OF LENGTH 8 CONTAINING THE FOLLOWING C ANS(1) - MEAN OF VARIABLE A C ANS(2) - STANDARD DEVIATION OF VARIABLE A C ANS(3) - PROPORTION OF THE CASES IN THE HIGHER C CATEGORY OF VARIABLE B C ANS(4) - PROPORTION OF THE CASES IN THE LOWER C CATEGORY OF VARIABLE B C ANS(5) - MEAN OF VARIABLE A FOR THOSE CASES FALLING C INTO THE HIGHER CATEGORY OF VARIABLE B C ANS(6) - MEAN OF VARIABLE A FOR THOSE CASES FALLING C INTO THE LOWER CATEGORY OF VARIABLE B C ANS(7) - BISERIAL CORRELATION COEFFICIENT C ANS(8) - STANDARD ERROR OF BISERIAL CORRELATION C COEFFICIENT C IER - 1, IF NO CASES ARE IN THE LOWER CATEGORY OF VARIABLE C B. C -1, IF ALL CASES ARE IN THE LOWER CATEGORY OF C VARIABLE B. C 0, OTHERWISE. C IF IER IS NON-ZERO, ANS(I)=10**75,I=5,...,8. C C REMARKS C THE VALUES OF THE DICHOTOMIZED VARIABLE, B, MUST BE IN C NUMERIC FORM. THEY CANNOR BE SPECIFIED BY MEANS OF C ALPHABETIC OR SPECIAL CHARACTERS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NDTRI C C METHOD C REFER TO P. HORST, 'PSYCHOLOGICAL MEASUREMENT AND C PREDICTION', P.95-96 (WADSWORTH, 1966). C C .................................................................. C SUBROUTINE BISER (N,A,B,HI,ANS,IER) C DIMENSION A(1),B(1),ANS(1) C C COMPUTE MEAN AND STANDARD DEVIATION OF VARIABLE A C IER=0 SUM=0.0 SUM2=0.0 DO 10 I=1,N SUM=SUM+A(I) 10 SUM2=SUM2+A(I)*A(I) FN=N ANS(1)=SUM/FN ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0) ANS(2)= SQRT(ANS(2)) C C FIND PROPORTIONS OF CASES IN THE HIGHER AND LOWER CATEGORIES C P=0.0 SUM=0.0 SUM2=0.0 DO 30 I=1,N IF(B(I)-HI) 20, 25, 25 20 SUM2=SUM2+A(I) GO TO 30 25 P=P+1.0 SUM=SUM+A(I) 30 CONTINUE ANS(4)=1.0 ANS(3)=0.0 Q=FN-P IF (P) 35,35,40 35 IER=-1 GO TO 50 40 ANS(5)=SUM/P IF (Q) 45,45,60 45 IER=1 ANS(4)=0.0 ANS(3)=1.0 50 DO 55 I=5,8 55 ANS(I)=1.7E38 0 GO TO 65 60 ANS(6)=SUM2/Q P=P/FN Q=1.0-P C C FIND ORDINATE OF THE NORMAL DISTRIBUTION CURVE AT THE POINT OF C DIVISION BETWEEN SEGMENTS CONTAINING P AND Q PROPORTIONS C CALL NDTRI (Q,X,Y,ER) C C COMPUTE THE BISERIAL COEFFICIENT OF CORRELATION C R=((ANS(5)-ANS(1))/ANS(2))*(P/Y) C C COMPUTE THE STANDARD ERROR OF R C ANS(8)=( SQRT(P*Q)/Y-R*R)/SQRT(FN) C C STORE RESULTS C ANS(3)=P ANS(4)=Q ANS(7)=R C 65 RETURN END C C .................................................................. C C USER-SUPPLIED SPECIAL SUBROUTINE - BOOL C C THIS SPECIAL SUBROUTINE ILLUSTRATES AN EXTERNAL SUBROUTINE C CALLED BY SUBROUTINE SUBST. C C IF DIFFERENT PROPOSITIONS ARE USED FOR DIFFERENT PROBLEMS IN C THE SAME RUN, DIFFERENT SUBROUTINES WITH APPROPRIATE PROPOSI- C TIONS MUST BE COMPILED UNDER DIFFERENT NAMES. IF SO, THESE C SUBROUTINE NAMES MUST BE DEFINED BY AN EXTERNAL STATEMENT C APPEARING IN THE MAIN PROGRAM WHICH CALLS SUBST. THEN, FOR C EACH PROBLEM, SUBST IS CALLED WITH A PROPER SUBROUTINE NAME C IN ITS ARGUMENT LIST. C C .................................................................. C SUBROUTINE BOOL(R,T) DIMENSION R(1) C T=R(1)*R(2) C RETURN END C C .................................................................. C C SUBROUTINE BOUND C C PURPOSE C SELECT FROM A SET (OR A SUBSET) OF OBSERVATIONS THE NUMBER C OF OBSERVATIONS UNDER, BETWEEN AND OVER TWO GIVEN BOUNDS C FOR EACH VARIABLE C C USAGE C CALL BOUND (A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV,IER) C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C S - VECTOR INDICATING SUBSET OF A. ONLY THOSE C OBSERVATIONS WITH A NON-ZERO S(J) ARE CONSIDERED. C VECTOR LENGTH IS NO. C BLO - INPUT VECTOR OF LOWER BOUNDS ON ALL VARIABLES. C VECTOR LENGTH IS NV. C BHI - INPUT VECTOR OF UPPER BOUNDS ON ALL VARIABLES. C VECTOR LENGTH IS NV. C UNDER - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER C OF OBSERVATIONS UNDER LOWER BOUNDS. VECTOR LENGTH C IS NV. C BETW - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER C OF OBSERVATIONS EQUAL TO OR BETWEEN LOWER AND UPPER C BOUNDS. VECTOR LENGTH IS NV. C OVER - OUTPUT VECTOR INDICATING, FOR EACH VARIABLE, NUMBER C OF OBSERVATIONS OVER UPPER BOUNDS. VECTOR LENGTH C IS NV. C NO - NUMBER OF OBSERVATIONS C NV - NUMBER OF VARIABLES FOR EACH OBSERVATION C IER - ZERO, IF NO ERROR. C - 1, IF LOWER BOUND IS GREATER THAN THE UPPER BOUND C FOR SOME VARIABLE C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH ROW (OBSERVATION) OF MATRIX A WITH CORRESPONDING C NON-ZERO ELEMENT IN S VECTOR IS TESTED. OBSERVATIONS ARE C COMPARED WITH SPECIFIED LOWER AND UPPER VARIABLE BOUNDS AND C A COUNT IS KEPT IN VECTORS UNDER, BETWEEN, AND OVER. C C .................................................................. C SUBROUTINE BOUND(A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV) DIMENSION A(1),S(1),BLO(1),BHI(1),UNDER(1),BETW(1),OVER(1) C C CLEAR OUTPUT VECTORS. C IER=0 DO 10 I=1,NV IF (BLO(I)-BHI(I)) 10,10,11 11 IER=1 GO TO 12 10 CONTINUE DO 1 K=1,NV UNDER(K)=0.0 BETW(K)=0.0 1 OVER(K)=0.0 C C TEST SUBSET VECTOR C DO 8 J=1,NO IJ=J-NO IF(S(J)) 2,8,2 C C COMPARE OBSERVATIONS WITH BOUNDS C 2 DO 7 I=1,NV IJ=IJ+NO IF(A(IJ)-BLO(I)) 5,3,3 3 IF(A(IJ)-BHI(I)) 4,4,6 C C COUNT C 4 BETW(I)=BETW(I)+1.0 GO TO 7 5 UNDER(I)=UNDER(I)+1.0 GO TO 7 6 OVER(I)=OVER(I)+1.0 7 CONTINUE 8 CONTINUE 12 RETURN END C C .................................................................. C C SUBROUTINE CADD C C PURPOSE C ADD COLUMN OF ONE MATRIX TO COLUMN OF ANOTHER MATRIX C C USAGE C CALL CADD(A,ICA,R,ICR,N,M,MS,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C ICA - COLUMN IN MATRIX A TO BE ADDED TO COLUMN ICR OF R C R - NAME OF OUTPUT MATRIX C ICR - COLUMN IN MATRIX R WHERE SUMMATION IS DEVELOPED C N - NUMBER OF ROWS IN A AND R C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C L - NUMBER OF COLUMNS IN R C C REMARKS C MATRIX R MUST BE A GENERAL MATRIX C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A UNLESS C A IS GENERAL C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT OF COLUMN ICA OF MATRIX A IS ADDED TO C CORRESPONDING ELEMENT OF COLUMN ICR OF MATRIX R C C .................................................................. C SUBROUTINE CADD(A,ICA,R,ICR,N,M,MS,L) DIMENSION A(1),R(1) C IR=N*(ICR-1) DO 2 I=1,N IR=IR+1 C C LOCATE INPUT ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,ICA,IA,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IA) 1,2,1 C C ADD ELEMENTS C 1 R(IR)=R(IR)+A(IA) 2 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CANOR C C PURPOSE C COMPUTE THE CANONICAL CORRELATIONS BETWEEN TWO SETS OF C VARIABLES. CANOR IS NORMALLY PRECEDED BY A CALL TO SUBROU- C TINE CORRE. C C USAGE C CALL CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR, C COEFL,R) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS C MP - NUMBER OF LEFT HAND VARIABLES C MQ - NUMBER OF RIGHT HAND VARIABLES C RR - INPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE C SYMMETRIC MATRIX OF M X M, WHERE M = MP + MQ) C CONTAINING CORRELATION COEFFICIENTS. (STORAGE MODE C OF 1) C ROOTS - OUTPUT VECTOR OF LENGTH MQ CONTAINING EIGENVALUES C COMPUTED IN THE NROOT SUBROUTINE. C WLAM - OUTPUT VECTOR OF LENGTH MQ CONTAINING LAMBDA. C CANR - OUTPUT VECTOR OF LENGTH MQ CONTAINING CANONICAL C CORRELATIONS. C CHISQ - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE C VALUES OF CHI-SQUARES. C NDF - OUTPUT VECTOR OF LENGTH MQ CONTAINING THE DEGREES C OF FREEDOM ASSOCIATED WITH CHI-SQUARES. C COEFR - OUTPUT MATRIX (MQ X MQ) CONTAINING MQ SETS OF C RIGHT HAND COEFFICIENTS COLUMNWISE. C COEFL - OUTPUT MATRIX (MP X MQ) CONTAINING MQ SETS OF C LEFT HAND COEFFICIENTS COLUMNWISE. C R - WORK MATRIX (M X M) C C REMARKS C THE NUMBER OF LEFT HAND VARIABLES (MP) SHOULD BE GREATER C THAN OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES (MQ). C THE VALUES OF CANONICAL CORRELATION, LAMBDA, CHI-SQUARE, C DEGREES OF FREEDOM, AND CANONICAL COEFFICIENTS ARE COMPUTED C ONLY FOR THOSE EIGENVALUES IN ROOTS WHICH ARE GREATER THAN C ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C MINV C NROOT (WHICH, IN TURN, CALLS THE SUBROUTINE EIGEN.) C C METHOD C REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO- C CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS, C 1962, CHAPTER 3. C C .................................................................. C SUBROUTINE CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR, 1 COEFL,R) DIMENSION RR(1),ROOTS(1),WLAM(1),CANR(1),CHISQ(1),NDF(1),COEFR(1), 1 COEFL(1),R(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION RR,ROOTS,WLAM,CANR,CHISQ,COEFR,COEFL,R,DET,SUM C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENT C 165 MUST BE CHANGED TO DSQRT. ALOG IN STATEMENT 175 MUST BE C CHANGED TO DLOG. C C ............................................................... C C PARTITION INTERCORRELATIONS AMONG LEFT HAND VARIABLES, BETWEEN C LEFT AND RIGHT HAND VARIABLES, AND AMONG RIGHT HAND VARIABLES. C M=MP+MQ N1=0 DO 105 I=1,M DO 105 J=1,M IF(I-J) 102, 103, 103 102 L=I+(J*J-J)/2 GO TO 104 103 L=J+(I*I-I)/2 104 N1=N1+1 105 R(N1)=RR(L) L=MP DO 108 J=2,MP N1=M*(J-1) DO 108 I=1,MP L=L+1 N1=N1+1 108 R(L)=R(N1) N2=MP+1 L=0 DO 110 J=N2,M N1=M*(J-1) DO 110 I=1,MP L=L+1 N1=N1+1 110 COEFL(L)=R(N1) L=0 DO 120 J=N2,M N1=M*(J-1)+MP DO 120 I=N2,M L=L+1 N1=N1+1 120 COEFR(L)=R(N1) C C SOLVE THE CANONICAL EQUATION C L=MP*MP+1 K=L+MP CALL MINV (R,MP,DET,R(L),R(K)) C C CALCULATE T = INVERSE OF R11 * R12 C DO 140 I=1,MP N2=0 DO 130 J=1,MQ N1=I-MP ROOTS(J)=0.0 DO 130 K=1,MP N1=N1+MP N2=N2+1 130 ROOTS(J)=ROOTS(J)+R(N1)*COEFL(N2) L=I-MP DO 140 J=1,MQ L=L+MP 140 R(L)=ROOTS(J) C C CALCULATE A = R21 * T C L=MP*MQ N3=L+1 DO 160 J=1,MQ N1=0 DO 160 I=1,MQ N2=MP*(J-1) SUM=0.0 DO 150 K=1,MP N1=N1+1 N2=N2+1 150 SUM=SUM+COEFL(N1)*R(N2) L=L+1 160 R(L)=SUM C C CALCULATE EIGENVALUES WITH ASSOCIATED EIGENVECTORS OF THE C INVERSE OF R22 * A C L=L+1 CALL NROOT (MQ,R(N3),COEFR,ROOTS,R(L)) C C FOR EACH VALUE OF I = 1, 2, ..., MQ, CALCULATE THE FOLLOWING C STATISTICS C DO 210 I=1,MQ C C TEST WHETHER EIGENVALUE IS GREATER THAN ZERO C IF(ROOTS(I)) 220, 220, 165 C C CANONICAL CORRELATION C 165 CANR(I)= SQRT(ROOTS(I)) C C CHI-SQUARE C WLAM(I)=1.0 DO 170 J=I,MQ 170 WLAM(I)=WLAM(I)*(1.0-ROOTS(J)) FN=N FMP=MP FMQ=MQ 175 CHISQ(I)=-(FN-0.5*(FMP+FMQ+1.0))*ALOG(WLAM(I)) C C DEGREES OF FREEDOM FOR CHI-SQUARE C N1=I-1 NDF(I)=(MP-N1)*(MQ-N1) C C I-TH SET OF RIGHT HAND COEFFICIENTS C N1=MQ*(I-1) N2=MQ*(I-1)+L-1 DO 180 J=1,MQ N1=N1+1 N2=N2+1 180 COEFR(N1)=R(N2) C C I-TH SET OF LEFT HAND COEFFICIENTS C DO 200 J=1,MP N1=J-MP N2=MQ*(I-1) K=MP*(I-1)+J COEFL(K)=0.0 DO 190 JJ=1,MQ N1=N1+MP N2=N2+1 190 COEFL(K)=COEFL(K)+R(N1)*COEFR(N2) 200 COEFL(K)=COEFL(K)/CANR(I) 210 CONTINUE 220 RETURN END C C .................................................................. C C SUBROUTINE CCPY C C PURPOSE C COPY SPECIFIED COLUMN OF A MATRIX INTO A VECTOR C C USAGE C CALL CCPY(A,L,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C L - COLUMN OF A TO BE MOVED TO R C R - NAME OF OUTPUT VECTOR OF LENGTH N C N - NUMBER OR ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS OF COLUMN L ARE MOVED TO CORRESPONDING POSITIONS C OF VECTOR R C C .................................................................. C SUBROUTINE CCPY(A,L,R,N,M,MS) DIMENSION A(1),R(1) C DO 3 I=1,N C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,L,IL,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IL) 1,2,1 C C MOVE ELEMENT TO R C 1 R(I)=A(IL) GO TO 3 2 R(I)=0.0 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CCUT C C PURPOSE C PARTITION A MATRIX BETWEEN SPECIFIED COLUMNS TO FORM TWO C RESULTANT MATRICES C C USAGE C CALL CCUT (A,L,R,S,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C L - COLUMN OF A TO THE LEFT OF WHICH PARTITIONING TAKES C PLACE C R - NAME OF MATRIX TO BE FORMED FROM LEFT PORTION OF A C S - NAME OF MATRIX TO BE FORMED FROM RIGHT PORTION OF A C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX A C MATRIX S CANNOT BE IN SAME LOCATION AS MATRIX A C MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX S C MATRIX R AND MATRIX S ARE ALWAYS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS OF MATRIX A TO THE LEFT OF COLUMN L ARE MOVED TO C FORM MATRIX R OF N ROWS AND L-1 COLUMNS. ELEMENTS OF C MATRIX A IN COLUMN L AND TO THE RIGHT OF L ARE MOVED TO FORM C MATRIX S OF N ROWS AND M-L+1 COLUMNS. C C .................................................................. C SUBROUTINE CCUT(A,L,R,S,N,M,MS) DIMENSION A(1),R(1),S(1) C IR=0 IS=0 DO 70 J=1,M DO 70 I=1,N C C FIND LOCATION IN OUTPUT MATRIX AND SET TO ZERO C IF(J-L) 20,10,10 10 IS=IS+1 S(IS)=0.0 GO TO 30 20 IR=IR+1 R(IR)=0.0 C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C 30 CALL LOC(I,J,IJ,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 40,70,40 C C DETERMINE WHETHER RIGHT OR LEFT OF L C 40 IF(J-L) 60,50,50 50 S(IS)=A(IJ) GO TO 70 60 R(IR)=A(IJ) 70 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CDTR C C PURPOSE C COMPUTES P(X) = PROBABILITY THAT THE RANDOM VARIABLE U, C DISTRIBUTED ACCORDING TO THE CHI-SQUARE DISTRIBUTION WITH G C DEGREES OF FREEDOM, IS LESS THAN OR EQUAL TO X. F(G,X), THE C ORDINATE OF THE CHI-SQUARE DENSITY AT X, IS ALSO COMPUTED. C C USAGE C CALL CDTR(X,G,P,D,IER) C C DESCRIPTION OF PARAMETERS C X - INPUT SCALAR FOR WHICH P(X) IS COMPUTED. C G - NUMBER OF DEGREES OF FREEDOM OF THE CHI-SQUARE C DISTRIBUTION. G IS A CONTINUOUS PARAMETER. C P - OUTPUT PROBABILITY. C D - OUTPUT DENSITY. C IER - RESULTANT ERROR CODE WHERE C IER= 0 --- NO ERROR C IER=-1 --- AN INPUT PARAMETER IS INVALID. X IS LESS C THAN 0.0, OR G IS LESS THAN 0.5 OR GREATER C THAN 2*10**(+5). P AND D ARE SET TO -1.7E38. 0 C IER=+1 --- INVALID OUTPUT. P IS LESS THAN ZERO OR C GREATER THAN ONE, OR SERIES FOR T1 (SEE C MATHEMATICAL DESCRIPTION) HAS FAILED TO C CONVERGE. P IS SET TO 1.7E38. 0 C C REMARKS C SEE MATHEMATICAL DESCRIPTION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DLGAM C NDTR C C METHOD C REFER TO R.E. BARGMANN AND S.P. GHOSH, STATISTICAL C DISTRIBUTION PROGRAMS FOR A COMPUTER LANGUAGE, C IBM RESEARCH REPORT RC-1094, 1963. C C .................................................................. C SUBROUTINE CDTR(X,G,P,D,IER) DOUBLE PRECISION XX,DLXX,X2,DLX2,GG,G2,DLT3,THETA,THP1, 1GLG2,DD,T11,SER,CC,XI,FAC,TLOG,TERM,GTH,A2,A,B,C,DT2,DT3,THPI C C TEST FOR VALID INPUT DATA C IF(G-(.5-1.E-5)) 590,10,10 10 IF(G-2.E+5) 20,20,590 20 IF(X) 590,30,30 C C TEST FOR X NEAR 0.0 C 30 IF(X-1.E-8) 40,40,80 40 P=0.0 IF(G-2.) 50,60,70 50 D=1.7E38 0 GO TO 610 60 D=0.5 GO TO 610 70 D=0.0 GO TO 610 C C TEST FOR X GREATER THAN 1.E+6 C 80 IF(X-1.E+6) 100,100,90 90 D=0.0 P=1.0 GO TO 610 C C SET PROGRAM PARAMETERS C 100 XX=DBLE(X) DLXX=DLOG(XX) X2=XX/2.D0 DLX2=DLOG(X2) GG=DBLE(G) G2=GG/2.D0 C C COMPUTE ORDINATE C CALL DLGAM(G2,GLG2,IOK) DD=(G2-1.D0)*DLXX-X2-G2*.6931471805599453 -GLG2 IF(DD-1.68D02) 110,110,120 110 IF(DD+1.68D02) 130,130,140 120 D=1.7E38 0 GO TO 150 130 D=0.0 GO TO 150 140 DD=DEXP(DD) D=SNGL(DD) C C TEST FOR G GREATER THAN 1000.0 C TEST FOR X GREATER THAN 2000.0 C 150 IF(G-1000.) 160,160,180 160 IF(X-2000.) 190,190,170 170 P=1.0 GO TO 610 180 A=DLOG(XX/GG)/3.D0 A=DEXP(A) B=2.D0/(9.D0*GG) C=(A-1.D0+B)/DSQRT(B) SC=SNGL(C) CALL NDTR(SC,P,DUMMY) GO TO 490 C C COMPUTE THETA C 190 K= IDINT(G2) THETA=G2-DFLOAT(K) IF(THETA-1.D-8) 200,200,210 200 THETA=0.D0 210 THP1=THETA+1.D0 C C SELECT METHOD OF COMPUTING T1 C IF(THETA) 230,230,220 220 IF(XX-10.D0) 260,260,320 C C COMPUTE T1 FOR THETA EQUALS 0.0 C 230 IF(X2-1.68D02) 250,240,240 240 T1=1.0 GO TO 400 250 T11=1.D0-DEXP(-X2) T1=SNGL(T11) GO TO 400 C C COMPUTE T1 FOR THETA GREATER THAN 0.0 AND C X LESS THAN OR EQUAL TO 10.0 C 260 SER=X2*(1.D0/THP1 -X2/(THP1+1.D0)) J=+1 CC=DFLOAT(J) DO 270 IT1=3,30 XI=DFLOAT(IT1) CALL DLGAM(XI,FAC,IOK) TLOG= XI*DLX2-FAC-DLOG(XI+THETA) TERM=DEXP(TLOG) TERM=DSIGN(TERM,CC) SER=SER+TERM CC=-CC IF(DABS(TERM)-1.D-9) 280,270,270 270 CONTINUE GO TO 600 280 IF(SER) 600,600,290 290 CALL DLGAM(THP1,GTH,IOK) TLOG=THETA*DLX2+DLOG(SER)-GTH IF(TLOG+1.68D02) 300,300,310 300 T1=0.0 GO TO 400 310 T11=DEXP(TLOG) T1=SNGL(T11) GO TO 400 C C COMPUTE T1 FOR THETA GREATER THAN 0.0 AND C X GREATER THAN 10.0 AND LESS THAN 2000.0 C 320 A2=0.D0 DO 340 I=1,25 XI=DFLOAT(I) CALL DLGAM(THP1,GTH,IOK) T11=-(13.D0*XX)/XI +THP1*DLOG(13.D0*XX/XI) -GTH-DLOG(XI) IF(T11+1.68D02) 340,340,330 330 T11=DEXP(T11) A2=A2+T11 340 CONTINUE A=1.01282051+THETA/156.D0-XX/312.D0 B=DABS(A) C= -X2+THP1*DLX2+DLOG(B)-GTH-3.951243718581427 IF(C+1.68D02) 370,370,350 350 IF (A) 360,370,380 360 C=-DEXP(C) GO TO 390 370 C=0.D0 GO TO 390 380 C=DEXP(C) 390 C=A2+C T11=1.D0-C T1=SNGL(T11) C C SELECT PROPER EXPRESSION FOR P C 400 IF(G-2.) 420,410,410 410 IF(G-4.) 450,460,460 C C COMPUTE P FOR G GREATER THAN ZERO AND LESS THAN 2.0 C 420 CALL DLGAM(THP1,GTH,IOK) DT2=THETA*DLXX-X2-THP1*.6931471805599453 -GTH IF(DT2+1.68D02) 430,430,440 430 P=T1 GO TO 490 440 DT2=DEXP(DT2) T2=SNGL(DT2) P=T1+T2+T2 GO TO 490 C C COMPUTE P FOR G GREATER THAN OR EQUAL TO 2.0 C AND LESS THAN 4.0 C 450 P=T1 GO TO 490 C C COMPUTE P FOR G GREATER THAN OR EQUAL TO 4.0 C AND LESS THAN OR EQUAL TO 1000.0 C 460 DT3=0.D0 DO 480 I3=2,K THPI=DFLOAT(I3)+THETA CALL DLGAM(THPI,GTH,IOK) DLT3=THPI*DLX2-DLXX-X2-GTH IF(DLT3+1.68D02) 480,480,470 470 DT3=DT3+DEXP(DLT3) 480 CONTINUE T3=SNGL(DT3) P=T1-T3-T3 C C SET ERROR INDICATOR C 490 IF(P) 500,520,520 500 IF(ABS(P)-1.E-7) 510,510,600 510 P=0.0 GO TO 610 520 IF(1.-P) 530,550,550 530 IF(ABS(1.-P)-1.E-7) 540,540,600 540 P=1.0 GO TO 610 550 IF(P-1.E-8) 560,560,570 560 P=0.0 GO TO 610 570 IF((1.0-P)-1.E-8) 580,580,610 580 P=1.0 GO TO 610 590 IER=-1 D=-1.7E38 0 P=-1.7E38 0 GO TO 620 600 IER=+1 P= 1.7E38 0 GO TO 620 610 IER=0 620 RETURN END C C .................................................................. C C SUBROUTINE CEL1 C C PURPOSE C CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND C C USAGE C CALL CEL1(RES,AK,IER) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE C AK - MODULUS (INPUT) C IER - RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 AK NOT IN RANGE -1 TO +1 C C REMARKS C THE RESULT IS SET TO 1.7E38 IF ABS(AK) GE 1 0 C FOR MODULUS AK AND COMPLEMENTARY MODULUS CK, C EQUATION AK*AK+CK*CK=1.0 IS USED. C AK MUST BE IN THE RANGE -1 TO +1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED C OVER T FROM 0 TO INFINITY). C EQUIVALENT ARE THE DEFINITIONS C CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED C OVER T FROM 0 TO PI/2), C CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T C FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS C AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS, C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE CEL1(RES,AK,IER) IER=0 ARI=2. GEO=(0.5-AK)+0.5 GEO=GEO+GEO*AK RES=0.5 IF(GEO)1,2,4 1 IER=1 2 RES=1.7E38 0 RETURN 3 GEO=GEO*AARI 4 GEO=SQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO RES=RES+RES IF(GEO/AARI-0.9999)3,5,5 5 RES=RES/ARI*6.283185E0 RETURN END C C .................................................................. C C SUBROUTINE CEL2 C C PURPOSE C COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF C SECOND KIND. C C USAGE C CALL CEL2(RES,AK,A,B,IER) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE C AK - MODULUS (INPUT) C A - CONSTANT TERM IN NUMERATOR C B - FACTOR OF QUADRATIC TERM IN NUMERATOR C IER - RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 AK NOT IN RANGE -1 TO +1 C C REMARKS C FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.7E38 IF B IS 0 C POSITIVE, TO -1.7E38 IF B IS NEGATIVE. 0 C SPECIAL CASES ARE C K(K) OBTAINED WITH A = 1, B = 1 C E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS C COMPLEMENTARY MODULUS. C B(K) OBTAINED WITH A = 1, B = 0 C D(K) OBTAINED WITH A = 0, B = 1 C WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED C COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL C NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS C THE MODULUS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)) C SUMMED OVER T FROM 0 TO INFINITY). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS C AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS, C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE CEL2(RES,AK,A,B,IER) IER=0 ARI=2. GEO=(0.5-AK)+0.5 GEO=GEO+GEO*AK RES=A A1=A+B B0=B+B IF(GEO)1,2,6 1 IER=1 2 IF(B)3,8,4 3 RES=-1.7E38 0 RETURN 4 RES=1.7E38 0 RETURN 5 GEO=GEO*AARI 6 GEO=SQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO B0=B0+RES*GEO RES=A1 B0=B0+B0 A1=B0/ARI+A1 IF(GEO/AARI-0.9999)5,7,7 7 RES=A1/ARI RES=RES+0.5707963E0*RES 8 RETURN END C C .................................................................. C C SUBROUTINE CHISQ C C PURPOSE C COMPUTE CHI-SQUARE FROM A CONTINGENCY TABLE C C USAGE C CALL CHISQ(A,N,M,CS,NDF,IERR,TR,TC) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX, N BY M, CONTAINING CONTINGENCY TABLE C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C CS - CHI-SQUARE (OUTPUT) C NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT) C IERR - ERROR CODE (OUTPUT) C 0 - NORMAL CASE C 1 - EXPECTED VALUE IS LESS THAN 1.0 IN ONE OR C MORE CELLS C 3 - NUMBER OF DEGREES OF FREEDOM IS ZERO C TR - WORK VECTOR OF LENGTH N C TC - WORK VECTOR OF LENGTH M C C REMARKS C IF ONE OR MORE CELLS CONTAIN AN EXPECTED VALUE (I.E., C THEORETICAL VALUE) LESS THAN 1.0, CHI-SQUARE WILL BE C COMPUTED, BUT ERROR CODE WILL BE SET TO 1. C SEE REFERENCE GIVEN BELOW. C CHI-SQUARE IS SET TO ZERO IF EITHER N OR M IS ONE (ERROR C CODE 3). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 6 AND CHAPTER 8. C C .................................................................. C SUBROUTINE CHISQ(A,N,M,CS,NDF,IERR,TR,TC) DIMENSION A(1),TR(1),TC(1) C NM=N*M IERR=0 CS=0.0 C C FIND DEGREES OF FREEDOM C NDF=(N-1)*(M-1) IF(NDF) 5,5,10 5 IERR=3 RETURN C C COMPUTE TOTALS OF ROWS C 10 DO 90 I=1,N TR(I)=0.0 IJ=I-N DO 90 J=1,M IJ=IJ+N 90 TR(I)=TR(I)+A(IJ) C C COMPUTE TOTALS OF COLUMNS C IJ=0 DO 100 J=1,M TC(J)=0.0 DO 100 I=1,N IJ=IJ+1 100 TC(J)=TC(J)+A(IJ) C C COMPUTE GRAND TOTAL C GT=0.0 DO 110 I=1,N 110 GT=GT+TR(I) C C COMPUTE CHI SQUARE FOR 2 BY 2 TABLE (SPECIAL CASE) C IF(NM-4) 130,120,130 120 CS=GT*(ABS(A(1)*A(4)-A(2)*A(3))-GT/2.0)**2 /(TC(1)*TC(2)*TR(1) 1*TR(2)) RETURN C C COMPUTE CHI SQUARE FOR OTHER CONTINGENCY TABLES C 130 IJ=0 DO 140 J=1,M DO 140 I=1,N IJ=IJ+1 E=TR(I)*TC(J)/GT IF(E-1.0) 135, 140, 140 135 IERR=1 140 CS=CS+(A(IJ)-E)*(A(IJ)-E)/E RETURN END C C .................................................................. C C SUBROUTINE CINT C C PURPOSE C INTERCHANGE TWO COLUMNS OF A MATRIX C C USAGE C CALL CINT(A,N,LA,LB) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX C N - NUMBER OF ROWS IN A C LA - COLUMN TO BE INTERCHANGED WITH COLUMN LB C LB - COLUMN TO BE INTERCHANGED WITH COLUMN LA C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH ELEMENT OF COLUMN LA IS INTERCHANGED WITH CORRESPONDING C ELEMENT OF COLUMN LB C C .................................................................. C SUBROUTINE CINT(A,N,LA,LB) DIMENSION A(1) C C LOCATE STARTING POINT OF BOTH COLUMNS C ILA=N*(LA-1) ILB=N*(LB-1) C DO 3 I=1,N ILA=ILA+1 ILB=ILB+1 C C INTERCHANGE ELEMENTS C SAVE=A(ILA) A(ILA)=A(ILB) 3 A(ILB)=SAVE RETURN END C C .................................................................. C C SUBROUTINE CNP C C PURPOSE C COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL CNP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C Y - RESULT VALUE C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF CHEBYSHEV POLYNOMIAL C N - ORDER OF CHEBYSHEV POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C CHEBYSHEV POLYNOMIALS T(N,X) C T(N+1,X)=2*X*T(N,X)-T(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE T(0,X)=1, T(1,X)=X. C C .................................................................. C SUBROUTINE CNP(Y,X,N) C DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN C 2 Y(2)=X IF(N-1)1,1,3 C C INITIALIZATION 3 F=X+X C DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END C C .................................................................. C C SUBROUTINE CNPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL CNPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C X - ARGUMENT VALUE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION C USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS C T(N+1,X)=2*X*T(N,X)-T(N-1,X). C C .................................................................. C SUBROUTINE CNPS(Y,X,C,N) C DIMENSION C(1) C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 IF(N-2)3,4,4 3 Y=C(1) RETURN C C INITIALIZATION 4 ARG=X+X H1=0. H0=0. C DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5*(C(1)-H2+H0) RETURN END C C .................................................................. C C SUBROUTINE CONVT C C PURPOSE C CONVERT NUMBERS FROM SINGLE PRECISION TO DOUBLE PRECISION C OR FROM DOUBLE PRECISION TO SINGLE PRECISION. C C USAGE C CALL CONVT (N,M,MODE,S,D,MS) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF ROWS IN MATRICES S AND D. C M - NUMBER OF COLUMNS IN MATRICES S AND D. C MODE - CODE INDICATING TYPE OF CONVERSION C 1 - FROM SINGLE PRECISION TO DOUBLE PRECISION C 2 - FROM DOUBLE PRECISION TO SINGLE PRECISION C S - IF MODE=1, THIS MATRIX CONTAINS SINGLE PRECISION C NUMBERS AS INPUT. IF MODE=2, IT CONTAINS SINGLE C PRECISION NUMBERS AS OUTPUT. THE SIZE OF MATRIX S C IS N BY M. C D - IF MODE=1, THIS MATRIX CONTAINS DOUBLE PRECISION C NUMBERS AS OUTPUT. IF MODE=2, IT CONTAINS DOUBLE C PRECISION NUMBERS AS INPUT. THE SIZE OF MATRIX D IS C N BY M. C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX D CANNOT BE IN THE SAME LOCATION AS MATRIX S. C MATRIX D MUST BE DEFINED BY A DOUBLE PRECISION STATEMENT IN C THE CALLING PROGRAM. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C ACCORDING TO THE TYPE OF CONVERSION INDICATED IN MODE, THIS C SUBROUTINE COPIES NUMBERS FROM MATRIX S TO MATRIX D OR FROM C MATRIX D TO MATRIX S. C C .................................................................. C SUBROUTINE CONVT (N,M,MODE,S,D,MS) DIMENSION S(1),D(1) DOUBLE PRECISION D C C FIND STORAGE MODE OF MATRIX AND NUMBER OF DATA POINTS C IF(MS-1) 2, 4, 6 2 NM=N*M GO TO 8 4 NM=((N+1)*N)/2 GO TO 8 6 NM=N C C TEST TYPE OF CONVERSION C 8 IF(MODE-1) 10, 10, 20 C C SINGLE PRECISION TO DOUBLE PRECISION C 10 DO 15 L=1,NM 15 D(L)=S(L) GO TO 30 C C DOUBLE PRECISION TO SINGLE PRECISION C 20 DO 25 L=1,NM 25 S(L)=D(L) C 30 RETURN END C C .................................................................. C C SUBROUTINE CORRE C C PURPOSE C COMPUTE MEANS, STANDARD DEVIATIONS, SUMS OF CROSS-PRODUCTS C OF DEVIATIONS, AND CORRELATION COEFFICIENTS. C C USAGE C CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS. N MUST BE > OR = TO 2. C M - NUMBER OF VARIABLES. M MUST BE > OR = TO 1. C IO - OPTION CODE FOR INPUT DATA C 0 IF DATA ARE TO BE READ IN FROM INPUT DEVICE IN THE C SPECIAL SUBROUTINE NAMED DATA. (SEE SUBROUTINES C USED BY THIS SUBROUTINE BELOW.) C 1 IF ALL DATA ARE ALREADY IN CORE. C X - IF IO=0, THE VALUE OF X IS 0.0. C IF IO=1, X IS THE INPUT MATRIX (N BY M) CONTAINING C DATA. C XBAR - OUTPUT VECTOR OF LENGTH M CONTAINING MEANS. C STD - OUTPUT VECTOR OF LENGTH M CONTAINING STANDARD C DEVIATIONS. C RX - OUTPUT MATRIX (M X M) CONTAINING SUMS OF CROSS- C PRODUCTS OF DEVIATIONS FROM MEANS. C R - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE C SYMMETRIC MATRIX OF M BY M) CONTAINING CORRELATION C COEFFICIENTS. (STORAGE MODE OF 1) C B - OUTPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL C OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF C DEVIATIONS FROM MEANS. C D - WORKING VECTOR OF LENGTH M. C T - WORKING VECTOR OF LENGTH M. C C REMARKS C CORRE WILL NOT ACCEPT A CONSTANT VECTOR. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DATA(M,D) - THIS SUBROUTINE MUST BE PROVIDED BY THE USER. C (1) IF IO=0, THIS SUBROUTINE IS EXPECTED TO C FURNISH AN OBSERVATION IN VECTOR D FROM AN C EXTERNAL INPUT DEVICE. C (2) IF IO=1, THIS SUBROUTINE IS NOT USED BY C CORRE BUT MUST EXIST IN JOB DECK. IF USER C HAS NOT SUPPLIED A SUBROUTINE NAMED DATA, C THE FOLLOWING IS SUGGESTED. C SUBROUTINE DATA C RETURN C END C C METHOD C PRODUCT-MOMENT CORRELATION COEFFICIENTS ARE COMPUTED. C C .................................................................. C SUBROUTINE CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T) DIMENSION X(1),XBAR(1),STD(1),RX(1),R(1),B(1),D(1),T(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION XBAR,STD,RX,R,B,T C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT AND ABS IN C STATEMENT 220 MUST BE CHANGED TO DSQRT AND DABS. C C ............................................................... C C INITIALIZATION C DO 100 J=1,M B(J)=0.0 100 T(J)=0.0 K=(M*M+M)/2 DO 102 I=1,K 102 R(I)=0.0 FN=N L=0 C IF(IO) 105, 127, 105 C C DATA ARE ALREADY IN CORE C 105 DO 108 J=1,M DO 107 I=1,N L=L+1 107 T(J)=T(J)+X(L) XBAR(J)=T(J) 108 T(J)=T(J)/FN C DO 115 I=1,N JK=0 L=I-N DO 110 J=1,M L=L+N D(J)=X(L)-T(J) 110 B(J)=B(J)+D(J) DO 115 J=1,M DO 115 K=1,J JK=JK+1 115 R(JK)=R(JK)+D(J)*D(K) GO TO 205 C C READ OBSERVATIONS AND CALCULATE TEMPORARY C MEANS FROM THESE DATA IN T(J) C 127 IF(N-M) 130, 130, 135 130 KK=N GO TO 137 135 KK=M 137 DO 140 I=1,KK CALL DATA (M,D) DO 140 J=1,M T(J)=T(J)+D(J) L=L+1 140 RX(L)=D(J) FKK=KK DO 150 J=1,M XBAR(J)=T(J) 150 T(J)=T(J)/FKK C C CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS C FROM TEMPORARY MEANS FOR M OBSERVATIONS C L=0 DO 180 I=1,KK JK=0 DO 170 J=1,M L=L+1 170 D(J)=RX(L)-T(J) DO 180 J=1,M B(J)=B(J)+D(J) DO 180 K=1,J JK=JK+1 180 R(JK)=R(JK)+D(J)*D(K) C IF(N-KK) 205, 205, 185 C C READ THE REST OF OBSERVATIONS ONE AT A TIME, SUM C THE OBSERVATION, AND CALCULATE SUMS OF CROSS- C PRODUCTS OF DEVIATIONS FROM TEMPORARY MEANS C 185 KK=N-KK DO 200 I=1,KK JK=0 CALL DATA (M,D) DO 190 J=1,M XBAR(J)=XBAR(J)+D(J) D(J)=D(J)-T(J) 190 B(J)=B(J)+D(J) DO 200 J=1,M DO 200 K=1,J JK=JK+1 200 R(JK)=R(JK)+D(J)*D(K) C C CALCULATE MEANS C 205 JK=0 DO 210 J=1,M XBAR(J)=XBAR(J)/FN C C ADJUST SUMS OF CROSS-PRODUCTS OF DEVIATIONS C FROM TEMPORARY MEANS C DO 210 K=1,J JK=JK+1 210 R(JK)=R(JK)-B(J)*B(K)/FN C C CALCULATE CORRELATION COEFFICIENTS C JK=0 DO 220 J=1,M JK=JK+J 220 STD(J)= SQRT( ABS(R(JK))) DO 230 J=1,M DO 230 K=J,M JK=J+(K*K-K)/2 L=M*(J-1)+K RX(L)=R(JK) L=M*(K-1)+J RX(L)=R(JK) IF(STD(J)*STD(K)) 225, 222, 225 222 R(JK)=0.0 GO TO 230 225 R(JK)=R(JK)/(STD(J)*STD(K)) 230 CONTINUE C C CALCULATE STANDARD DEVIATIONS C FN=SQRT(FN-1.0) DO 240 J=1,M 240 STD(J)=STD(J)/FN C C COPY THE DIAGONAL OF THE MATRIX OF SUMS OF CROSS-PRODUCTS OF C DEVIATIONS FROM MEANS. C L=-M DO 250 I=1,M L=L+M+1 250 B(I)=RX(L) RETURN END C C .................................................................. C C SUBROUTINE CROSS C C PURPOSE C TO FIND THE CROSSCOVARIANCES OF SERIES A WITH SERIES B C (WHICH LEADS AND LAGS A). C C USAGE C CALL CROSS (A,B,N,L,R,S) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF LENGTH N CONTAINING FIRST TIME C SERIES. C B - INPUT VECTOR OF LENGTH N CONTAINING SECOND TIME C SERIES. C N - LENGTH OF SERIES A AND B. C L - CROSSCOVARIANCE IS CALCULATED FOR LAGS AND LEADS OF C 0, 1, 2,..., L-1. C R - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI- C ANCES OF A WITH B, WHERE B LAGS A. C S - OUTPUT VECTOR OF LENGTH L CONTAINING CROSSCOVARI- C ANCES OF A WITH B, WHERE B LEADS A. C C REMARKS C N MUST BE GREATER THAN L. IF NOT, R(1) AND S(1) ARE SET TO C ZERO AND RETURN IS MADE TO THE CALLING PROGRAM. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DESCRIBED IN R.B. BLACKMAN AND J.W. TUKEY, 'THE MEASURMENT C OF POWER SPECTRA', DOVER PUBLICATIONS INC., NEW YORK, 1959. C C .................................................................. C SUBROUTINE CROSS (A,B,N,L,R,S) DIMENSION A(1),B(1),R(1),S(1) C C CALCULATE AVERAGES OF SERIES A AND B C FN=N AVERA=0.0 AVERB=0.0 IF(N-L)50,50,100 50 R(1)=0.0 S(1)=0.0 RETURN 100 DO 110 I=1,N AVERA=AVERA+A(I) 110 AVERB=AVERB+B(I) AVERA=AVERA/FN AVERB=AVERB/FN C C CALCULATE CROSSCOVARIANCES OF SERIES A AND B C DO 130 J=1,L NJ=N-J+1 SUMR=0.0 SUMS=0.0 DO 120 I=1,NJ IJ=I+J-1 SUMR=SUMR+(A(I)-AVERA)*(B(IJ)-AVERB) 120 SUMS=SUMS+(A(IJ)-AVERA)*(B(I)-AVERB) FNJ=NJ R(J)=SUMR/FNJ 130 S(J)=SUMS/FNJ RETURN END C C .................................................................. C C SUBROUTINE CS C C PURPOSE C COMPUTES THE FRESNEL INTEGRALS. C C USAGE C CALL CS (C,S,X) C C DESCRIPTION OF PARAMETERS C C - THE RESULTANT VALUE C(X). C S - THE RESULTANT VALUE S(X). C X - THE ARGUMENT OF FRESNEL INTEGRALS C IF X IS NEGATIVE, THE ABSOLUTE VALUE IS USED. C C REMARKS C THE ARGUMENT VALUE X REMAINS UNCHANGED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C C(X)=INTEGRAL(COS(T)/SQRT(2*LI*T) SUMMED OVER T FROM 0 TO X) C S(X)=INTEGRAL(SIN(T)/SQRT(I*LI*T) SUMMED OVER T FROM 0 TO X) C EVALUATION C USING DIFFERENT APPROXIMATIONS FOR X LESS THAN 4 AND X C GREATER THAN 4. C REFERENCE C 'COMPUTATION OF FRESNEL INTEGRALS' BY BOERSMA, C MATHEMATICAL TABLES AND OTHER AIDS TO COMPUTATION, VOL. 14, C 1960, NO. 72, P. 380. C C .................................................................. C SUBROUTINE CS(C,S,X) Z=ABS(X) IF(Z-4.)1,1,2 1 C=SQRT(Z) S=Z*C Z=(4.-Z)*(4.+Z) C=C*((((((5.100785E-11*Z+5.244297E-9)*Z+5.451182E-7)*Z 1+3.273308E-5)*Z+1.020418E-3)*Z+1.102544E-2)*Z+1.840965E-1) S=S*(((((6.677681E-10*Z+5.883158E-8)*Z+5.051141E-6)*Z 1+2.441816E-4)*Z+6.121320E-3)*Z+8.026490E-2) RETURN 2 D=COS(Z) S=SIN(Z) Z=4./Z A=(((((((8.768258E-4*Z-4.169289E-3)*Z+7.970943E-3)*Z-6.792801E-3) 1*Z-3.095341E-4)*Z+5.972151E-3)*Z-1.606428E-5)*Z-2.493322E-2)*Z 2-4.444091E-9 B=((((((-6.633926E-4*Z+3.401409E-3)*Z-7.271690E-3)*Z+7.428246E-3) 1*Z-4.027145E-4)*Z-9.314910E-3)*Z-1.207998E-6)*Z+1.994711E-1 Z=SQRT(Z) C=0.5+Z*(D*A+S*B) S=0.5+Z*(S*A-D*B) RETURN END C C .................................................................. C C SUBROUTINE CSP C C PURPOSE C COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS C TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N. C C USAGE C CALL CSP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL C N - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X) C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1. C C .................................................................. C SUBROUTINE CSP(Y,X,N) C DIMENSION Y(1) C C TEST OF ORDER Y(1)=1. IF(N)1,1,2 1 RETURN C 2 Y(2)=X+X-1. IF(N-1)1,1,3 C C INITIALIZATION 3 F=Y(2)+Y(2) C DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END C C .................................................................. C C SUBROUTINE CSPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED C CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C C FOR ARGUMENT VALUE X. C C USAGE C CALL CSPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C X - ARGUMENT VALUE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION C USING THE RECURRENCE EQUATION FOR SHIFTED C CHEBYSHEV POLYNOMIALS C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X). C C .................................................................. C SUBROUTINE CSPS(Y,X,C,N) C DIMENSION C(1) C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 IF(N-2)3,4,4 3 Y=C(1) RETURN C C INITIALIZATION 4 ARG=X+X-1. ARG=ARG+ARG H1=0. H0=0. C DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5*(C(1)-H2+H0) RETURN END C C .................................................................. C C SUBROUTINE CSRT C C PURPOSE C SORT COLUMNS OF A MATRIX C C USAGE C CALL CSRT(A,B,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX TO BE SORTED C B - NAME OF INPUT VECTOR WHICH CONTAINS SORTING KEY C R - NAME OF SORTED OUTPUT MATRIX C N - NUMBER OF ROWS IN A AND R C M - NUMBER OF COLUMNS IN A AND R AND LENGTH OF B C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R IS ALWAYS A GENERAL MATRIX C M MUST BE GREATER THAN ONE. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C CCPY C C METHOD C COLUMNS OF INPUT MATRIX A ARE SORTED TO FORM OUTPUT MATRIX C R. THE SORTED COLUMN SEQUENCE IS DETERMINED BY THE VALUES OF C ELEMENTS IN ROW VECTOR B. THE LOWEST VALUED ELEMENT IN C B WILL CAUSE THE CORRESPONDING COLUMN OF A TO BE PLACED IN C THE FIRST COLUMN OF R. THE HIGHEST VALUED ELEMENT OF B WILL C CAUSE THE CORRESPONDING ROW OF A TO BE PLACED IN THE LAST C COLUMN OF R. IF DUPLICATE VALUES EXIST IN B, THE C CORRESPONDING COLUMNS OF A ARE MOVED TO R IN THE SAME ORDER C AS IN A. C C .................................................................. C SUBROUTINE CSRT(A,B,R,N,M,MS) DIMENSION A(1),B(1),R(1) C C MOVE SORTING KEY VECTOR TO FIRST ROW OF OUTPUT MATRIX C AND BUILD ORIGINAL SEQUENCE LIST IN SECOND ROW C IK=1 DO 10 J=1,M R(IK)=B(J) R(IK+1)=J 10 IK=IK+N C C SORT ELEMENTS IN SORTING KEY VECTOR (ORIGINAL SEQUENCE LIST C IS RESEQUENCED ACCORDINGLY) C L=M+1 20 ISORT=0 L=L-1 IP=1 IQ=N+1 DO 50 J=2,L IF(R(IQ)-R(IP)) 30,40,40 30 ISORT=1 RSAVE=R(IQ) R(IQ)=R(IP) R(IP)=RSAVE SAVER=R(IQ+1) R(IQ+1)=R(IP+1) R(IP+1)=SAVER 40 IP=IP+N IQ=IQ+N 50 CONTINUE IF(ISORT) 20,60,20 C C MOVE COLUMNS FROM MATRIX A TO MATRIX R (NUMBER IN SECOND ROW C OF R REPRESENTS COLUMN NUMBER OF MATRIX A TO BE MOVED) C 60 IQ=-N DO 70 J=1,M IQ=IQ+N C C GET COLUMN NUMBER IN MATRIX A C I2=IQ+2 IN=R(I2) C C MOVE COLUMN C IR=IQ+1 CALL CCPY(A,IN,R(IR),N,M,MS) 70 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CSUM C C PURPOSE C SUM ELEMENTS OF EACH COLUMN TO FORM ROW VECTOR C C USAGE C CALL CSUM(A,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF VECTOR OF LENGTH M C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C VECTOR R CANNOT BE IN THE SAME LOCATION AS MATRIX A C UNLESS A IS GENERAL C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS ARE SUMMED DOWN EACH COLUMN INTO A CORRESPONDING C ELEMENT OF OUTPUT ROW VECTOR R C C .................................................................. C SUBROUTINE CSUM(A,R,N,M,MS) DIMENSION A(1),R(1) C DO 3 J=1,M C C CLEAR OUTPUT LOCATION C R(J)=0.0 C DO 3 I=1,N C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,J,IJ,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 2,3,2 C C ACCUMULATE IN OUTPUT VECTOR C 2 R(J)=R(J)+A(IJ) 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CTAB C C PURPOSE C TABULATE COLUMNS OF A MATRIX TO FORM A SUMMARY MATRIX C C USAGE C CALL CTAB(A,B,R,S,N,M,MS,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C B - NAME OF INPUT VECTOR OF LENGTH M CONTAINING KEY C R - NAME OF OUTPUT MATRIX CONTAINING SUMMARY OF COLUMN DATA. C IT IS INITIALLY SET TO ZERO BY THIS SUBROUTINE. C S - NAME OF OUTPUT VECTOR OF LENGTH L+1 CONTAINING COUNTS C N - NUMBER OF ROWS IN A AND R C M - NUMBER OF COLUMNS IN A C L - NUMBER OF COLUMNS IN R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R IS ALWAYS A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C CADD C C METHOD C COLUMNS OF DATA IN MATRIX A ARE TABULATED BASED ON THE KEY C CONTAINED IN VECTOR B. THE FLOATING POINT NUMBER IN B(I) IS C TRUNCATED TO FORM J. THE ITH COLUMN OF A IS ADDED TO THE JTH C COLUMN OF MATRIX R AND ONE IS ADDED TO S(J). IF THE VALUE OF C J IS NOT BETWEEN 1 AND L, ONE IS ADDED TO S(L+1) C UPON COMPLETION, THE OUTPUT MATRIX R CONTAINS A SUMMARY OF C COLUMN DATA AS SPECIFIED BY VECTOR B. EACH ELEMENT IN VECTOR C S CONTAINS A COUNT OF THE NUMBER OF COLUMNS OF A USED TO C FORM R. ELEMENT S(L+1) CONTAINS THE NUMBER OF COLUMNS OF A C NOT INCLUDED IN R AS A RESULT OF J BEING LESS THAN ONE OR C GREATER THAN L. C C .................................................................. C SUBROUTINE CTAB(A,B,R,S,N,M,MS,L) DIMENSION A(1),B(1),R(1),S(1) C C CLEAR OUTPUT AREAS C CALL LOC(N,L,IT,N,L,0) DO 10 IR=1,IT 10 R(IR)=0.0 DO 20 IS=1,L 20 S(IS)=0.0 S(L+1)=0.0 C DO 60 I=1,M C C TEST FOR THE KEY OUTSIDE THE RANGE C JR=B(I) IF (JR-1) 50,40,30 30 IF (JR-L) 40,40,50 C C C ADD COLUMN OF A TO COLUMN OF R AND 1 TO COUNT C 40 CALL CADD (A,I,R,JR,N,M,MS,L) S(JR)=S(JR)+1.0 GO TO 60 C 50 S(L+1)=S(L+1)+1.0 60 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE CTIE C C PURPOSE C ADJOIN TWO MATRICES WITH SAME ROW DIMENSION TO FORM ONE C RESULTANT MATRIX (SEE METHOD) C C USAGE C CALL CTIE(A,B,R,N,M,MSA,MSB,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A,B,R C M - NUMBER OF COLUMNS IN A C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C L - NUMBER OF COLUMNS IN B C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B C MATRIX R IS ALWAYS A GENERAL MATRIX C MATRIX A MUST HAVE THE SAME NUMBER OF ROWS AS MATRIX B C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C MATRIX B IS ATTACHED TO THE RIGHT OF MATRIX A . C THE RESULTANT MATRIX R CONTAINS N ROWS AND M+L COLUMNS C C .................................................................. C SUBROUTINE CTIE(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) C MM=M IR=0 MSX=MSA DO 6 JJ=1,2 DO 5 J=1,MM DO 5 I=1,N IR=IR+1 R(IR)=0.0 C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,J,IJ,N,MM,MSX) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 2,5,2 C C MOVE ELEMENT TO MATRIX R C 2 GO TO(3,4),JJ 3 R(IR)=A(IJ) GO TO 5 4 R(IR)=B(IJ) 5 CONTINUE C C REPEAT ABOVE FOR MATRIX B C MSX=MSB MM=L 6 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE DACFI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION C VALUES. C C USAGE C CALL DACFI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF C ARGUMENT VALUES OF THE TABLE (POSSIBLY DESTROYED). C VAL - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF C FUNCTION VALUES OF THE TABLE (DESTROYED). C Y - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION C VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C UPPER BOUND FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (NDIM-1) STEPS (THE NUMBER OF POSSIBLE STEPS IS C DIMINISHED IF AT ANY STAGE INFINITY ELEMENT APPEARS IN C THE DOWNWARD DIAGONAL OF INVERTED-DIFFERENCES-SCHEME C AND IF IT IS IMPOSSIBLE TO ELIMINATE THIS INFINITY C ELEMENT BY INTERCHANGING OF TABLE POINTS). C FURTHER IT IS TERMINATED IF THE PROCEDURE DISCOVERS TWO C ARGUMENT VALUES IN VECTOR ARG WHICH ARE IDENTICAL. C DEPENDENT ON THESE FOUR CASES, ERROR PARAMETER IER IS C CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY CONTINUED FRACTIONS AND INVERTED- C DIFFERENCES-SCHEME. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.395-406. C C .................................................................. C SUBROUTINE DACFI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,Z,P1,P2,P3,Q1,Q2,Q3,AUX,H IER=2 IF(NDIM)20,20,1 1 Y=VAL(1) DELT2=0. IF(NDIM-1)20,20,2 C C PREPARATIONS FOR INTERPOLATION LOOP 2 P2=1.D0 P3=Y Q2=0.D0 Q3=1.D0 C C C START INTERPOLATION LOOP DO 16 I=2,NDIM II=0 P1=P2 P2=P3 Q1=Q2 Q2=Q3 Z=Y DELT1=DELT2 JEND=I-1 C C COMPUTATION OF INVERTED DIFFERENCES 3 AUX=VAL(I) DO 10 J=1,JEND H=VAL(I)-VAL(J) IF(DABS(H)-1.D-13*DABS(VAL(I)))4,4,9 4 IF(ARG(I)-ARG(J))5,17,5 5 IF(J-JEND)8,6,6 C C INTERCHANGE ROW I WITH ROW I+II 6 II=II+1 III=I+II IF(III-NDIM)7,7,19 7 VAL(I)=VAL(III) VAL(III)=AUX AUX=ARG(I) ARG(I)=ARG(III) ARG(III)=AUX GOTO 3 C C COMPUTATION OF VAL(I) IN CASE VAL(I)=VAL(J) AND J LESS THAN I-1 8 VAL(I)=1.7D38 0 GOTO 10 C C COMPUTATION OF VAL(I) IN CASE VAL(I) NOT EQUAL TO VAL(J) 9 VAL(I)=(ARG(I)-ARG(J))/H 10 CONTINUE C INVERTED DIFFERENCES ARE COMPUTED C C COMPUTATION OF NEW Y P3=VAL(I)*P2+(X-ARG(I-1))*P1 Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1 IF(Q3)11,12,11 11 Y=P3/Q3 GOTO 13 12 Y=1.7D38 0 13 DELT2=DABS(Z-Y) IF(DELT2-EPS)19,19,14 14 IF(I-10)16,15,15 15 IF(DELT2-DELT1)16,18,18 16 CONTINUE C END OF INTERPOLATION LOOP C C RETURN C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 17 IER=3 RETURN C C TEST VALUE DELT2 STARTS OSCILLATING 18 Y=Z IER=1 RETURN C C THERE IS SATISFACTORY ACCURACY WITHIN NDIM-1 STEPS 19 IER=0 20 RETURN END C C .................................................................. C C SUBROUTINE DAHI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT, FUNCTION, AND C DERIVATIVE VALUES. C C USAGE C CALL DAHI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF C ARGUMENT VALUES OF THE TABLE (NOT DESTROYED). C VAL - DOUBLE PRECISION INPUT VECTOR (DIMENSION 2*NDIM) OF C FUNCTION AND DERIVATIVE VALUES OF THE TABLE (DES- C TROYED). FUNCTION AND DERIVATIVE VALUES MUST BE C STORED IN PAIRS, THAT MEANS BEGINNING WITH FUNCTION C VALUE AT POINT ARG(1) EVERY FUNCTION VALUE MUST BE C FOLLOWED BY THE DERIVATIVE VALUE AT THE SAME POINT. C Y - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION C VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C UPPER BOUND FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (2*NDIM-2) STEPS. FURTHER IT IS TERMINATED IF THE C PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG C WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES, C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 2, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF C HERMITE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-317, AND C GERSHINSKY/LEVINE, AITKEN-HERMITE INTERPOLATION, C JACM, VOL.11, ISS.3 (1964), PP.352-356. C C .................................................................. C SUBROUTINE DAHI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,H,H1,H2 IER=2 H2=X-ARG(1) IF(NDIM-1)2,1,3 1 Y=VAL(1)+VAL(2)*H2 2 RETURN C C VECTOR ARG HAS MORE THAN 1 ELEMENT. C THE FIRST STEP PREPARES VECTOR VAL SUCH THAT AITKEN SCHEME CAN BE C USED. 3 I=1 DO 5 J=2,NDIM H1=H2 H2=X-ARG(J) Y=VAL(I) VAL(I)=Y+VAL(I+1)*H1 H=H1-H2 IF(H)4,13,4 4 VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H 5 I=I+2 VAL(I)=VAL(I)+VAL(I+1)*H2 C END OF FIRST STEP C C PREPARE AITKEN SCHEME DELT2=0. IEND=I-1 C C START AITKEN-LOOP DO 9 I=1,IEND DELT1=DELT2 Y=VAL(1) M=(I+3)/2 H1=ARG(M) DO 6 J=1,I K=I+1-J L=(K+1)/2 H=ARG(L)-H1 IF(H)6,14,6 6 VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H DELT2=DABS(Y-VAL(1)) IF(DELT2-EPS)11,11,7 7 IF(I-8)9,8,8 8 IF(DELT2-DELT1)9,12,12 9 CONTINUE C END OF AITKEN-LOOP C 10 Y=VAL(1) RETURN C C THERE IS SUFFICIENT ACCURACY WITHIN 2*NDIM-2 ITERATION STEPS 11 IER=0 GOTO 10 C C TEST VALUE DELT2 STARTS OSCILLATING 12 IER=1 RETURN C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 13 Y=VAL(1) 14 IER=3 RETURN END C C .................................................................. C C SUBROUTINE DALI C C PURPOSE C TO INTERPOLATE FUNCTION VALUE Y FOR A GIVEN ARGUMENT VALUE C X USING A GIVEN TABLE (ARG,VAL) OF ARGUMENT AND FUNCTION C VALUES. C C USAGE C CALL DALI (X,ARG,VAL,Y,NDIM,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION ARGUMENT VALUE SPECIFIED BY INPUT. C ARG - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF C ARGUMENT VALUES OF THE TABLE (NOT DESTROYED). C VAL - DOUBLE PRECISION INPUT VECTOR (DIMENSION NDIM) OF C FUNCTION VALUES OF THE TABLE (DESTROYED). C Y - RESULTING INTERPOLATED DOUBLE PRECISION FUNCTION C VALUE. C NDIM - AN INPUT VALUE WHICH SPECIFIES THE NUMBER OF C POINTS IN TABLE (ARG,VAL). C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C UPPER BOUND FOR THE ABSOLUTE ERROR. C FOR THE ABSOLUTE ERROR. C IER - A RESULTING ERROR PARAMETER. C C REMARKS C (1) TABLE (ARG,VAL) SHOULD REPRESENT A SINGLE-VALUED C FUNCTION AND SHOULD BE STORED IN SUCH A WAY, THAT THE C DISTANCES ABS(ARG(I)-X) INCREASE WITH INCREASING C SUBSCRIPT I. TO GENERATE THIS ORDER IN TABLE (ARG,VAL), C SUBROUTINES DATSG, DATSM OR DATSE COULD BE USED IN A C PREVIOUS STAGE. C (2) NO ACTION BESIDES ERROR MESSAGE IN CASE NDIM LESS C THAN 1. C (3) INTERPOLATION IS TERMINATED EITHER IF THE DIFFERENCE C BETWEEN TWO SUCCESSIVE INTERPOLATED VALUES IS C ABSOLUTELY LESS THAN TOLERANCE EPS, OR IF THE ABSOLUTE C VALUE OF THIS DIFFERENCE STOPS DIMINISHING, OR AFTER C (NDIM-1) STEPS. FURTHER IT IS TERMINATED IF THE C PROCEDURE DISCOVERS TWO ARGUMENT VALUES IN VECTOR ARG C WHICH ARE IDENTICAL. DEPENDENT ON THESE FOUR CASES, C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED C ACCURACY (NO ERROR). C IER=1 - IT WAS IMPOSSIBLE TO REACH THE REQUIRED C ACCURACY BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE C NDIM IS LESS THAN 3, OR THE REQUIRED ACCURACY C COULD NOT BE REACHED BY MEANS OF THE GIVEN C TABLE. NDIM SHOULD BE INCREASED. C IER=3 - THE PROCEDURE DISCOVERED TWO ARGUMENT VALUES C IN VECTOR ARG WHICH ARE IDENTICAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERPOLATION IS DONE BY MEANS OF AITKENS SCHEME OF C LAGRANGE INTERPOLATION. ON RETURN Y CONTAINS AN INTERPOLATED C FUNCTION VALUE AT POINT X, WHICH IS IN THE SENSE OF REMARK C (3) OPTIMAL WITH RESPECT TO GIVEN TABLE. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.49-50. C C .................................................................. C SUBROUTINE DALI(X,ARG,VAL,Y,NDIM,EPS,IER) C C DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,H IER=2 DELT2=0. IF(NDIM-1)9,7,1 C C START OF AITKEN-LOOP 1 DO 6 J=2,NDIM DELT1=DELT2 IEND=J-1 DO 2 I=1,IEND H=ARG(I)-ARG(J) IF(H)2,13,2 2 VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H DELT2=DABS(VAL(J)-VAL(IEND)) IF(J-2)6,6,3 3 IF(DELT2-EPS)10,10,4 4 IF(J-8)6,5,5 5 IF(DELT2-DELT1)6,11,11 6 CONTINUE C END OF AITKEN-LOOP C 7 J=NDIM 8 Y=VAL(J) 9 RETURN C C THERE IS SUFFICIENT ACCURACY WITHIN NDIM-1 ITERATION STEPS 10 IER=0 GOTO 8 C C TEST VALUE DELT2 STARTS OSCILLATING 11 IER=1 12 J=IEND GOTO 8 C C THERE ARE TWO IDENTICAL ARGUMENT VALUES IN VECTOR ARG 13 IER=3 GOTO 12 END C C .................................................................. C C SUBROUTINE DAPCH C C PURPOSE C SET UP NORMAL EQUATIONS OF LEAST SQUARES FIT IN TERMS OF C CHEBYSHEV POLYNOMIALS FOR A GIVEN DISCRETE FUNCTION C C USAGE C CALL DAPCH(DATI,N,IP,XD,X0,WORK,IER) C C DESCRIPTION OF PARAMETERS C DATI - VECTOR OF DIMENSION 3*N (OR DIMENSION 2*N+1) C CONTAINING THE GIVEN ARGUMENTS, FOLLOWED BY THE C FUNCTION VALUES AND N (RESPECTIVELY 1) WEIGHT C VALUES. THE CONTENT OF VECTOR DATI REMAINS C UNCHANGED. C DATI MUST BE OF DOUBLE PRECISION C N - NUMBER OF GIVEN POINTS C IP - DIMENSION OF LEAST SQUARES FIT, I.E. NUMBER OF C CHEBYSHEV POLYNOMIALS USED AS FUNDAMENTAL FUNCTIONS C IP SHOULD NOT EXCEED N C XD - RESULTANT MULTIPLICATIVE CONSTANT FOR LINEAR C TRANSFORMATION OF ARGUMENT RANGE C XD MUST BE DOUBLE PRECISION C X0 - RESULTANT ADDITIVE CONSTANT FOR LINEAR C TRANSFORMATION OF ARGUMENT RANGE C X0 MUST BE DOUBLE PRECISION C WORK - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2 C ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT C MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM C FOLLOWED IMMEDIATELY BY RIGHT HAND SIDE C AND SQUARE SUM OF FUNCTION VALUES C WORK MUST BE OF DOUBLE PRECISION C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS IN DIMENSION C IER = 0 MEANS NO ERRORS C IER = 1 MEANS COINCIDING ARGUMENTS C C REMARKS C NO WEIGHTS ARE USED IF THE VALUE OF DATI(2*N+1) IS C NOT POSITIVE. C EXECUTION OF SUBROUTINE DAPCH IS A PREPARATORY STEP FOR C CALCULATION OF LEAST SQUARES FITS IN CHEBYSHEV POLYNOMIALS C IT SHOULD BE FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE LEAST SQUARE FIT IS DETERMINED USING CHEBYSHEV C POLYNOMIALS AS FUNDAMENTAL FUNCTION SYSTEM. C THE METHOD IS DISCUSSED IN THE ARTICLE C A.T.BERZTISS, LEAST SQUARES FITTING TO IRREGULARLY SPACED C DATA, SIAM REVIEW, VOL.6, ISS.3, 1964, PP. 203-227. C C .................................................................. C SUBROUTINE DAPCH(DATI,N,IP,XD,X0,WORK,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION DATI(1),WORK(1) DOUBLE PRECISION DATI,WORK,XD,X0,XA,XE,XM,DF,T,SUM C C CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS IF(N-1)19,20,1 1 IF(IP)19,19,2 C C SEARCH SMALLEST AND LARGEST ARGUMENT 2 IF(IP-N)3,3,19 3 XA=DATI(1) X0=XA XE=0.D0 DO 7 I=1,N XM=DATI(I) IF(XA-XM)5,5,4 4 XA=XM 5 IF(X0-XM)6,7,7 6 X0=XM 7 CONTINUE C C INITIALIZE CALCULATION OF NORMAL EQUATIONS XD=X0-XA M=(IP*(IP+1))/2 IEND=M+IP+1 MT2=IP+IP MT2M=MT2-1 C C SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO DO 8 I=1,IP J=MT2-I WORK(J)=0.D0 WORK(I)=0.D0 K=M+I 8 WORK(K)=0.D0 C C CHECK FOR DEGENERATE ARGUMENT RANGE IF(XD)20,20,9 C C CALCULATE CONSTANTS FOR REDUCTION OF ARGUMENTS 9 X0=-(X0+XA)/XD XD=2.D0/XD SUM=0.D0 C C START GREAT LOOP OVER ALL GIVEN POINTS DO 15 I=1,N T=DATI(I)*XD+X0 J=I+N DF=DATI(J) C C CALCULATE AND STORE VALUES OF CHEBYSHEV POLYNOMIALS C FOR ARGUMENT T XA=1.D0 XM=T IF(DATI(2*N+1))11,11,10 10 J=J+N XA=DATI(J) XM=T*XA 11 T=T+T SUM=SUM+DF*DF*XA DF=DF+DF J=1 12 K=M+J WORK(K)=WORK(K)+DF*XA 13 WORK(J)=WORK(J)+XA IF(J-MT2M)14,15,15 14 J=J+1 XE=T*XM-XA XA=XM XM=XE IF(J-IP)12,12,13 15 CONTINUE WORK(IEND)=SUM+SUM C C CALCULATE MATRIX OF NORMAL EQUATIONS LL=M KK=MT2M JJ=1 K=KK DO 18 J=1,M WORK(LL)=WORK(K)+WORK(JJ) LL=LL-1 IF(K-JJ)16,16,17 16 KK=KK-2 K=KK JJ=1 GOTO 18 17 JJ=JJ+1 K=K-1 18 CONTINUE IER=0 RETURN C C ERROR RETURN IN CASE OF FORMAL ERRORS 19 IER=-1 RETURN C C ERROR RETURN IN CASE OF COINCIDING ARGUMENTS 20 IER=1 RETURN END C C .................................................................. C C SUBROUTINE DAPFS C C PURPOSE C PERFORM SYMMETRIC FACTORIZATION OF THE MATRIX OF THE NORMAL C EQUATIONS FOLLOWED BY CALCULATION OF THE LEAST SQUARES FIT C OPTIONALLY C C USAGE C CALL DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER) C C DESCRIPTION OF PARAMETERS C WORK - GIVEN SYMMETRIC COEFFICIENT MATRIX, STORED C COMPRESSED, I.E UPPER TRIANGULAR PART COLUMNWISE. C THE GIVEN RIGHT HAND SIDE OCCUPIES THE NEXT IP C LOCATIONS IN WORK. THE VERY LAST COMPONENT OF WORK C CONTAINS THE SQUARE SUM OF FUNCTION VALUES E0 C THIS SCHEME OF STORAGE ALLOCATION IS PRODUCED E.G. C BY SUBROUTINE APLL. C THE GIVEN MATRIX IS FACTORED IN THE FORM C TRANSPOSE(T)*T AND THE GIVEN RIGHT HAND SIDE IS C DIVIDED BY TRANSPOSE(T). C THE UPPER TRIANGULAR FACTOR T IS RETURNED IN WORK IF C IOP EQUALS ZERO. C IN CASE OF NONZERO IOP THE CALCULATED SOLUTIONS ARE C STORED IN THE COLUMNS OF TRIANGULAR ARRAY WORK OF C CORRESPONDING DIMENSION AND E0 IS REPLACED BY THE C SQUARE SUM OF THE ERRORS FOR FIT OF DIMENSION IRES. C THE TOTAL DIMENSION OF WORK IS (IP+1)*(IP+2)/2 C WORK MUST BE OF DOUBLE PRECISION C IP - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST C SQUARES FIT C IRES - DIMENSION OF CALCULATED LEAST SQUARES FIT. C LET N1, N2, DENOTE THE FOLLOWING NUMBERS C N1 = MAXIMAL DIMENSION FOR WHICH NO LOSS OF C SIGNIFICANCE WAS INDICATED DURING FACTORIZATION C N2 = SMALLEST DIMENSION FOR WHICH THE SQUARE SUM OF C THE ERRORS DOES NOT EXCEED TEST=ABS(ETA*FSQ) C THEN IRES=MINO(IP,N1) IF IOP IS NONNEGATIVE C AND IRES=MINO(IP,N1,N2) IF IOP IS NEGATIVE C IOP - INPUT PARAMETER FOR SELECTION OF OPERATION C IOP = 0 MEANS TRIANGULAR FACTORIZATION, DIVISION OF C THE RIGHT HAND SIDE BY TRANSPOSE(T) AND C CALCULATION OF THE SQUARE SUM OF ERRORS IS C PERFORMED ONLY C IOP = +1 OR -1 MEANS THE SOLUTION OF DIMENSION IRES C IS CALCULATED ADDITIONALLY C IOP = +2 OR -2 MEANS ALL SOLUTIONS FOR DIMENSION ONE C UP TO IRES ARE CALCULATED ADDITIONALLY C EPS - RELATIVE TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C A SENSIBLE VALUE IS BETWEEN 1.E-10 AND 1.E-15 C ETA - RELATIVE TOLERANCE FOR TOLERATED SQUARE SUM OF C ERRORS. A REALISTIC VALUE IS BETWEEN 1.E0 AND 1.E-15 C IER - RESULTANT ERROR PARAMETER C IER =-1 MEANS NONPOSITIVE IP C IER = 0 MEANS NO LOSS OF SIGNIFICANCE DETECTED C AND SPECIFIED TOLERANCE OF ERRORS REACHED C IER = 1 MEANS LOSS OF SIGNIFICANCE DETECTED OR C SPECIFIED TOLERANCE OF ERRORS NOT REACHED C C REMARKS C THE ABSOLUTE TOLERANCE USED INTERNALLY FOR TEST ON LOSS OF C SIGNIFICANCE IS TOL=ABS(EPS*SNGL(WORK(1))). C THE ABSOLUTE TOLERANCE USED INTERNALLY FOR THE SQUARE SUM OF C ERRORS IS ABS(ETA*SNGL(FSQ)). C IOP GREATER THAN 2 HAS THE SAME EFFECT AS IOP = 2. C IOP LESS THAN -2 HAS THE SAME EFFECT AS IOP =-2. C IRES = 0 MEANS THE ABSOLUTE VALUE OF EPS IS NOT LESS THAN C ONE AND/OR WORK(1) IS NOT POSITIVE AND/OR IP IS NOT POSITIVE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C CALCULATION OF THE LEAST SQUARES FITS IS DONE USING C CHOLESKYS SQUARE ROOT METHOD FOR SYMMETRIC FACTORIZATION. C THE INCORPORATED TEST ON LOSS OF SIGNIFICANCE MEANS EACH C RADICAND MUST BE GREATER THAN THE INTERNAL ABSOLUTE C TOLERANCE TOL. C IN CASE OF LOSS OF SIGNIFICANCE IN THE ABOVE SENSE ONLY A C SUBSYSTEM OF THE NORMAL EQUATIONS IS SOLVED. C IN CASE OF NEGATIVE IOP THE TRIANGULAR FACTORIZATION IS C TERMINATED PREMATURELY EITHER IF THE SQUARE SUM OF THE C ERRORS DOES NOT EXCEED ETA*FSQ OR IF THERE IS INDICATION C FOR LOSS OF SIGNIFICANCE C C .................................................................. C SUBROUTINE DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION WORK(1) DOUBLE PRECISION WORK,SUM,PIV IRES=0 C C TEST OF SPECIFIED DIMENSION IF(IP)1,1,2 C C ERROR RETURN IN CASE OF ILLEGAL DIMENSION 1 IER=-1 RETURN C C INITIALIZE FACTORIZATION PROCESS 2 IPIV=0 IPP1=IP+1 IER=1 ITE=IP*IPP1/2 IEND=ITE+IPP1 TOL=ABS(EPS*SNGL(WORK(1))) TEST=ABS(ETA*SNGL(WORK(IEND))) C C START LOOP OVER ALL ROWS OF WORK DO 11 I=1,IP IPIV=IPIV+I JA=IPIV-IRES JE=IPIV-1 C C FORM SCALAR PRODUCT NEEDED TO MODIFY CURRENT ROW ELEMENTS JK=IPIV DO 9 K=I,IPP1 SUM=0.D0 IF(IRES)5,5,3 3 JK=JK-IRES DO 4 J=JA,JE SUM=SUM+WORK(J)*WORK(JK) 4 JK=JK+1 5 IF(JK-IPIV)6,6,8 C C TEST FOR LOSS OF SIGNIFICANCE 6 SUM=WORK(IPIV)-SUM IF(SNGL(SUM)-TOL)12,12,7 7 SUM=DSQRT(SUM) WORK(IPIV)=SUM PIV=1.D0/SUM GOTO 9 C C UPDATE OFF-DIAGONAL TERMS 8 SUM=(WORK(JK)-SUM)*PIV WORK(JK)=SUM 9 JK=JK+K C C UPDATE SQUARE SUM OF ERRORS WORK(IEND)=WORK(IEND)-SUM*SUM C C RECORD ADDRESS OF LAST PIVOT ELEMENT IRES=IRES+1 IADR=IPIV C C TEST FOR TOLERABLE ERROR IF SPECIFIED IF(IOP)10,11,11 10 IF(SNGL(WORK(IEND))-TEST)13,13,11 11 CONTINUE IF(IOP)12,22,12 C C PERFORM BACK SUBSTITUTION IF SPECIFIED 12 IF(IOP)14,23,14 13 IER=0 14 IPIV=IRES 15 IF(IPIV)23,23,16 16 SUM=0.D0 JA=ITE+IPIV JJ=IADR JK=IADR K=IPIV DO 19 I=1,IPIV WORK(JK)=(WORK(JA)-SUM)/WORK(JJ) IF(K-1)20,20,17 17 JE=JJ-1 SUM=0.D0 DO 18 J=K,IPIV SUM=SUM+WORK(JK)*WORK(JE) JK=JK+1 18 JE=JE+J JK=JE-IPIV JA=JA-1 JJ=JJ-K 19 K=K-1 20 IF(IOP/2)21,23,21 21 IADR=IADR-IPIV IPIV=IPIV-1 GOTO 15 C C NORMAL RETURN 22 IER=0 23 RETURN END C C .................................................................. C C SUBROUTINE DAPLL C PURPOSE C SET UP NORMAL EQUATIONS FOR A LINEAR LEAST SQUARES FIT C TO A GIVEN DISCRETE FUNCTION C C USAGE C CALL DAPLL(FFCT,N,IP,P,WORK,DATI,IER) C SUBROUTINE FFCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FFCT - USER CODED SUBROUTINE WHICH MUST BE DECLARED C EXTERNAL IN THE MAIN PROGRAM. IT IS CALLED C CALL FFCT(I,N,IP,P,DATI,WGT,IER) AND RETURNS C THE VALUES OF THE FUNDAMENTAL FUNCTIONS FOR C THE I-TH ARGUMENT IN P(1) UP TO P(IP) C FOLLOWED BY THE I-TH FUNCTION VALUE IN P(IP+1) C N IS THE NUMBER OF ALL POINTS C P,DATI,WGT MUST BE OF DOUBLE PRECISION. C DATI IS A DUMMY PARAMETER WHICH IS USED AS ARRAY C NAME. THE GIVEN DATA SET MAY BE ALLOCATED IN DATI C WGT IS THE WEIGHT FACTOR FOR THE I-TH POINT C IER IS USED AS RESULTANT ERROR PARAMETER IN FFCT C N - NUMBER OF GIVEN POINTS C IP - NUMBER OF FUNDAMENTAL FUNCTIONS USED FOR LEAST C SQUARES FIT C IP SHOULD NOT EXCEED N C P - WORKING STORAGE OF DIMENSION IP+1, WHICH C IS USED AS INTERFACE BETWEEN APLL AND THE USER C CODED SUBROUTINE FFCT C P MUST BE OF DOUBLE PRECISION. C WORK - WORKING STORAGE OF DIMENSION (IP+1)*(IP+2)/2. C ON RETURN WORK CONTAINS THE SYMMETRIC COEFFICIENT C MATRIX OF THE NORMAL EQUATIONS IN COMPRESSED FORM, C I.E. UPPER TRINGULAR PART ONLY STORED COLUMNWISE. C THE FOLLOWING IP POSITIONS CONTAIN THE RIGHT C HAND SIDE AND WORK((IP+1)*(IP+2)/2) CONTAINS C THE WEIGHTED SQUARE SUM OF THE FUNCTION VALUES C WORK MUST BE OF DOUBLE PRECISION. C DATI - DUMMY ENTRY TO COMMUNICATE AN ARRAY NAME BETWEEN C MAIN LINE AND SUBROUTINE FFCT. C DATI MUST BE OF DOUBLE PRECISION. C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS IN SPECIFIED DIMENSIONS C IER = 0 MEANS NO ERRORS C IER = 1 MEANS ERROR IN EXTERNAL SUBROUTINE FFCT C C REMARKS C TO ALLOW FOR EASY COMMUNICATION OF INTEGER VALUES C BETWEEN MAINLINE AND EXTERNAL SUBROUTINE FFCT, THE ERROR C PARAMETER IER IS TREATED AS A VECTOR OF DIMENSION 1 WITHIN C SUBROUTINE DAPLL. ADDITIONAL COMPONENTS OF IER MAY BE C INTRODUCED BY THE USER FOR COMMUNICATION BACK AND FORTH. C IN THIS CASE, HOWEVER, THE USER MUST SPECIFY IER AS A C VECTOR IN HIS MAINLINE. C EXECUTION OF SUBROUTINE DAPLL IS A PREPARATORY STEP FOR C CALCULATION OF THE LINEAR LEAST SQUARES FIT. C NORMALLY IT IS FOLLOWED BY EXECUTION OF SUBROUTINE DAPFS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FFCT MUST BE FURNISHED BY THE USER C C METHOD C HANDLING OF THE GIVEN DATA SET (ARGUMENTS,FUNCTION VALUES C AND WEIGHTS) IS COMPLETELY LEFT TO THE USER C ESSENTIALLY HE HAS THREE CHOICES C (1) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE CALCULATED WITHIN SUBROUTINE FFCT FOR GIVEN I. C (2) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE DETERMINED BY TABLE LOOK UP. THE STORAGE LOCATIONS C REQUIRED ARE ALLOCATED WITHIN THE DUMMY ARRAY DATI C (POSSIBLY IN P TOO, IN EXCESS OF THE SPECIFIED IP + 1 C LOCATIONS). C ANOTHER POSSIBILITY WOULD BE TO USE COMMON AS INTERFACE C BETWEEN MAIN LINE AND SUBROUTINE FFCT AND TO ALLOCATE C STORAGE FOR THE DATA SET IN COMMON. C (3) THE I-TH VALUES OF ARGUMENT, FUNCTION VALUE AND WEIGHT C ARE READ IN FROM AN EXTERNAL DEVICE. THIS MAY BE EASILY C ACCOMPLISHED SINCE I IS USED STRICTLY INCREASING FROM C ONE UP TO N WITHIN APLL C C .................................................................. C SUBROUTINE DAPLL(FFCT,N,IP,P,WORK,DATI,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION P(1),WORK(1),DATI(1),IER(1) DOUBLE PRECISION P,WORK,DATI,WGT,AUX C C CHECK FOR FORMAL ERRORS IN SPECIFIED DIMENSIONS IF(N)10,10,1 1 IF(IP)10,10,2 2 IF(N-IP)10,3,3 C C SET WORKING STORAGE AND RIGHT HAND SIDE TO ZERO 3 IPP1=IP+1 M=IPP1*(IP+2)/2 IER(1)=0 DO 4 I=1,M 4 WORK(I)=0.D0 C C START GREAT LOOP OVER ALL GIVEN POINTS DO 8 I=1,N CALL FFCT(I,N,IP,P,DATI,WGT,IER) IF(IER(1))9,5,9 5 J=0 DO 7 K=1,IPP1 AUX=P(K)*WGT DO 6 L=1,K J=J+1 6 WORK(J)=WORK(J)+P(L)*AUX 7 CONTINUE 8 CONTINUE C C NORMAL RETURN 9 RETURN C C ERROR RETURN IN CASE OF FORMAL ERRORS 10 IER(1)=-1 RETURN END C C .................................................................. C C SUBROUTINE DAPMM C C PURPOSE C APPROXIMATE A FUNCTION TABULATED IN N POINTS BY ANY LINEAR C COMBINATION OF M GIVEN CONTINUOUS FUNCTIONS IN THE SENSE C OF CHEBYSHEV. C C USAGE C CALL DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT IN THE C CALLING PROGRAM. C C DESCRIPTION OF PARAMETERS C FCT - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER. C IT COMPUTES VALUES OF M GIVEN FUNCTIONS FOR C ARGUMENT VALUE X. C USAGE C CALL FCT(Y,X,K) C DESCRIPTION OF PARAMETERS C Y - DOUBLE PRECISION RESULT VECTOR OF DIMEN- C SION M CONTAINING THE VALUES OF GIVEN C CONTINUOUS FUNCTIONS FOR GIVEN ARGUMENT X C X - DOUBLE PRECISON ARGUMENT VALUE C K - AN INTEGER VALUE WHICH IS EQUAL TO M-1 C REMARKS C IF APPROXIMATION BY NORMAL CHEBYSHEV, SHIFTED C CHEBYSHEV, LEGENDRE, LAGUERRE, HERMITE POLYNO- C MIALS IS DESIRED SUBROUTINES DCNP,DCSP,DLEP, C DLAP,DHEP, RESPECTIVELY FROM SSP COULD BE USED. C N - NUMBER OF DATA POINTS DEFINING THE FUNCTION WHICH C IS TO BE APPROXIMATED C M - NUMBER OF GIVEN CONTINUOUS FUNCTIONS FROM WHICH C THE APPROXIMATING FUNCTION IS CONSTRUCTED. C TOP - DOUBLE PRECISION VECTOR OF DIMENSION 3*N. C ON ENTRY IT MUST CONTAIN FROM TOP(1) UP TO TOP(N) C THE GIVEN N FUNCTION VALUES AND FROM TOP(N+1) UP C TO TOP(2*N) THE CORRESPONDING NODES C ON RETURN TOP CONTAINS FROM TOP(1) UP TO TOP(N) C THE ERRORS AT THOSE N NODES. C OTHER VALUES OF TOP ARE SCRATCH. C IHE - INTEGER VECTOR OF DIMENSION 3*M+4*N+6 C PIV - DOUBLE PRECISION VECTOR OF DIMENSION 3*M+6. C ON RETURN PIV CONTAINS AT PIV(1) UP TO PIV(M) THE C RESULTING COEFFICIENTS OF LINEAR APPROXIMATION. C T - DOUBLE PRECISION AUXILIARY VECTOR OF DIMENSION C (M+2)*(M+2) C ITER - RESULTANT INTEGER WHICH SPECIFIES THE NUMBER OF C ITERATIONS NEEDED C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - THE NUMBER OF ITERATIONS HAS REACHED C THE INTERNAL MAXIMUM N+M C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARA- C METER M OR N OR SINCE AT SOME ITERATION C NO SUITABLE PIVOT COULD BE FOUND C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE M LESS THAN 1 OR C N LESS THAN 2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FCT MUST BE FURNISHED BY THE USER. C C METHOD C THE PROBLEM OF APPROXIMATION A TABULATED FUNCTION BY ANY C LINEAR COMBINATION OF GIVEN FUNCTIONS IN THE SENSE OF C CHEBYSHEV (I.E. TO MINIMIZE THE MAXIMUM ERROR) IS TRANS- C FORMED INTO A LINEAR PROGRAMMING PROBLEM. DAPMM USES A C REVISED SIMPLEX METHOD TO SOLVE A CORRESPONDING DUAL C PROBLEM. FOR REFERENCE, SEE C I.BARRODALE/A.YOUNG, ALGORITHMS FOR BEST L-SUB-ONE AND C L-SUB-INFINITY, LINEAR APPROXIMATIONS ON A DISCRETE SET, C NUMERISCHE MATHEMATIK, VOL.8, ISS.3 (1966), PP.295-306. C C .................................................................. C SUBROUTINE DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) C C DIMENSION TOP(1),IHE(1),PIV(1),T(1) DOUBLE PRECISION DSUM,TOP,PIV,T,SAVE,HELP,REPI,TOL C C TEST ON WRONG INPUT PARAMETERS N AND M IER=-1 IF (N-1) 81,81,1 1 IF(M) 81,81,2 C C INITIALIZE CHARACTERISTIC VECTORS FOR THE TABLEAU 2 IER=0 C C PREPARE TOP-ROW TOP DO 3 I=1,N K=I+N J=K+N TOP(J)=TOP(K) 3 TOP(K)=-TOP(I) C C PREPARE INVERSE TRANSFORMATION MATRIX T L=M+2 LL=L*L DO 4 I=1,LL 4 T(I)=0.D0 K=1 J=L+1 DO 5 I=1,L T(K)=1.D0 5 K=K+J C C PREPARE INDEX-VECTOR IHE DO 6 I=1,L K=I+L J=K+L IHE(I)=0 IHE(K)=I 6 IHE(J)=1-I NAN=N+N K=L+L+L J=K+NAN DO 7 I=1,NAN K=K+1 IHE(K)=I J=J+1 7 IHE(J)=I C C SET COUNTER ITER FOR ITERATION-STEPS ITER=-1 8 ITER=ITER+1 C C TEST FOR MAXIMUM ITERATION-STEPS IF(N+M-ITER) 9,9,10 9 IER=1 GO TO 69 C C DETERMINE THE COLUMN WITH THE MOST POSITIVE ELEMENT IN TOP 10 ISE=0 IPIV=0 K=L+L+L SAVE=0.D0 C C START TOP-LOOP DO 14 I=1,NAN IDO=K+I HELP=TOP(I) IF(HELP-SAVE) 12,12,11 11 SAVE=HELP IPIV=I 12 IF(IHE(IDO)) 14,13,14 13 ISE=I 14 CONTINUE C END OF TOP-LOOP C C IS OPTIMAL TABLEAU REACHED IF(IPIV) 69,69,15 C C DETERMINE THE PIVOT-ELEMENT FOR THE COLUMN CHOSEN UPOVE 15 ILAB=1 IND=0 J=ISE IF(J) 21,21,34 C C TRANSFER K-TH COLUMN FROM T TO PIV 16 K=(K-1)*L DO 17 I=1,L J=L+I K=K+1 17 PIV(J)=T(K) C C IS ANOTHER COLUMN NEEDED FOR SEARCH FOR PIVOT-ELEMENT 18 IF(ISE) 22,22,19 19 ISE=-ISE C C TRANSFER COLUMNS IN PIV J=L+1 IDO=L+L DO 20 I=J,IDO K=I+L 20 PIV(K)=PIV(I) 21 J=IPIV GO TO 34 C C SEARCH PIVOT-ELEMENT PIV(IND) 22 SAVE=1.D38 IDO=0 K=L+1 LL=L+L IND=0 C C START PIVOT-LOOP DO 29 I=K,LL J=I+L HELP=PIV(I) IF(HELP) 29,29,23 23 HELP=-HELP IF(ISE) 26,24,26 24 IF(IHE(J)) 27,25,27 25 IDO=I GO TO 29 26 HELP=-PIV(J)/HELP 27 IF(HELP-SAVE) 28,29,29 28 SAVE=HELP IND=I 29 CONTINUE C END OF PIVOT-LOOP C C TEST FOR SUITABLE PIVOT-ELEMENT IF(IND) 30,30,32 30 IF(IDO) 68,68,31 31 IND=IDO C PIVOT-ELEMENT IS STORED IN PIV(IND) C C COMPUTE THE RECIPROCAL OF THE PIVOT-ELEMENT REPI 32 REPI=1.D0/PIV(IND) IND=IND-L C C UPDATE THE TOP-ROW TOP OF THE TABLEAU ILAB=0 SAVE=-TOP(IPIV)*REPI TOP(IPIV)=SAVE C C INITIALIZE J AS COUNTER FOR TOP-LOOP J=NAN 33 IF(J-IPIV) 34,53,34 34 K=0 C C SEARCH COLUMN IN TRANSFORMATION-MATRIX T DO 36 I=1,L IF(IHE(I)-J) 36,35,36 35 K=I IF(ILAB) 50,50,16 36 CONTINUE C C GENERATE COLUMN USING SUBROUTINE FCT AND TRANSFORMATION-MATRIX I=L+L+L+NAN+J I=IHE(I)-N IF(I) 37,37,38 37 I=I+N K=1 38 I=I+NAN C C CALL SUBROUTINE FCT CALL FCT(PIV,TOP(I),M-1) C C PREPARE THE CALLED VECTOR PIV DSUM=0.D0 IDO=M DO 41 I=1,M HELP=PIV(IDO) IF(K) 39,39,40 39 HELP=-HELP 40 DSUM=DSUM+HELP PIV(IDO+1)=HELP 41 IDO=IDO-1 PIV(L)=-DSUM PIV(1)=1.D0 C C TRANSFORM VECTOR PIV WITH ROWS OF MATRIX T IDO=IND IF(ILAB) 44,44,42 42 K=1 43 IDO=K 44 DSUM=0.D0 HELP=0.D0 C C START MULTIPLICATION-LOOP DO 46 I=1,L DSUM=DSUM+PIV(I)*T(IDO) TOL=DABS(DSUM) IF(TOL-HELP) 46,46,45 45 HELP=TOL 46 IDO=IDO+L C END OF MULTIPLICATION-LOOP C TOL=1.D-14*HELP IF(DABS(DSUM)-TOL) 47,47,48 47 DSUM=0.D0 48 IF(ILAB) 51,51,49 49 I=K+L PIV(I)=DSUM C C TEST FOR LAST COLUMN-TERM K=K+1 IF(K-L) 43,43,18 50 I=(K-1)*L+IND DSUM=T(I) C C COMPUTE NEW TOP-ELEMENT 51 DSUM=DSUM*SAVE TOL=1.D-14*DABS(DSUM) TOP(J)=TOP(J)+DSUM IF(DABS(TOP(J))-TOL) 52,52,53 52 TOP(J)=0.D0 C C TEST FOR LAST TOP-TERM 53 J=J-1 IF(J) 54,54,33 C END OF TOP-LOOP C C TRANSFORM PIVOT-COLUMN 54 I=IND+L PIV(I)=-1.D0 DO 55 I=1,L J=I+L 55 PIV(I)=-PIV(J)*REPI C C UPDATE TRANSFORMATION-MATRIX T J=0 DO 57 I=1,L IDO=J+IND SAVE=T(IDO) T(IDO)=0.D0 DO 56 K=1,L ISE=K+J 56 T(ISE)=T(ISE)+SAVE*PIV(K) 57 J=J+L C C UPDATE INDEX-VECTOR IHE C INITIALIZE CHARACTERISTICS J=0 K=0 ISE=0 IDO=0 C C START QUESTION-LOOP DO 61 I=1,L LL=I+L ILAB=IHE(LL) IF(IHE(I)-IPIV) 59,58,59 58 ISE=I J=ILAB 59 IF(ILAB-IND) 61,60,61 60 IDO=I K=IHE(I) 61 CONTINUE C END OF QUESTION-LOOP C C START MODIFICATION IF(K) 62,62,63 62 IHE(IDO)=IPIV IF(ISE) 67,67,65 63 IF(IND-J) 64,66,64 64 LL=L+L+L+NAN K=K+LL I=IPIV+LL ILAB=IHE(K) IHE(K)=IHE(I) IHE(I)=ILAB IF(ISE) 67,67,65 65 IDO=IDO+L I=ISE+L IHE(IDO)=J IHE(I)=IND 66 IHE(ISE)=0 67 LL=L+L J=LL+IND I=LL+L+IPIV ILAB=IHE(I) IHE(I)=IHE(J) IHE(J)=ILAB C END OF MODIFICATION C GO TO 8 C C SET ERROR PARAMETER IER=-1 SINCE NO SUITABLE PIVOT IS FOUND 68 IER=-1 C C EVALUATE FINAL TABLEAU C COMPUTE SAVE AS MAXIMUM ERROR OF APPROXIMATION AND C HELP AS ADDITIVE CONSTANCE FOR RESULTING COEFFICIENTS 69 SAVE=0.D0 HELP=0.D0 K=L+L+L DO 73 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 71,70,73 70 SAVE=-TOP(I) 71 IF(M+J+1) 73,72,73 72 HELP=TOP(I) 73 CONTINUE C C PREPARE T,TOP,PIV T(1)=SAVE IDO=NAN+1 J=NAN+N DO 74 I=IDO,J 74 TOP(I)=SAVE DO 75 I=1,M 75 PIV(I)=HELP C C COMPUTE COEFFICIENTS OF RESULTING POLYNOMIAL IN PIV(1) UP TO PI C AND CALCULATE ERRORS AT GIVEN NODES IN TOP(1) UP TO TOP(N) DO 79 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 76,79,77 76 J=-J PIV(J)=HELP-TOP(I) GO TO 79 77 IF(J-N) 78,78,79 78 J=J+NAN TOP(J)=SAVE+TOP(I) 79 CONTINUE DO 80 I=1,N IDO=NAN+I 80 TOP(I)=TOP(IDO) 81 RETURN END C C .................................................................. C C SUBROUTINE DARAT C C PURPOSE C CALCULATE BEST RATIONAL APPROXIMATION OF A DISCRETE C FUNCTION IN THE LEAST SQUARES SENSE C C USAGE C CALL DARAT(DATI,N,WORK,P,IP,IQ,IER) C C DESCRIPTION OF PARAMETERS C DATI - TWODIMENSIONAL ARRAY WITH 3 COLUMNS AND N ROWS C THE FIRST COLUMN MUST CONTAIN THE GIVEN ARGUMENTS, C THE SECOND COLUMN THE GIVEN FUNCTION VALUES AND C THE THIRD COLUMN THE GIVEN WEIGHTS IF ANY. C IF NO WEIGHTS ARE TO BE USED THEN THE THIRD C COLUMN MAY BE DROPPED , EXCEPT THE FIRST ELEMENT C WHICH MUST CONTAIN A NONPOSITIVE VALUE C DATI MUST BE OF DOUBLE PRECISION C N - NUMBER OF NODES OF THE GIVEN DISCRETE FUNCTION C WORK - WORKING STORAGE WHICH IS OF DIMENSION C (IP+IQ)*(IP+IQ+1)+4*N+1 AT LEAST. C ON RETURN THE VALUES OF THE NUMERATOR ARE CONTAINED C IN WORK(N+1) UP TO WORK(2*N), WHILE THE VALUES OF C THE DENOMINATOR ARE STORED IN WORK(2*N+1) UP TO C WORK(3*N) C WORK MUST BE OF DOUBLE PRECISION C P - RESULTANT COEFFICIENT VECTOR OF DENOMINATOR AND C NUMERATOR. THE DENOMINATOR IS STORED IN FIRST IQ C LOCATIONS, THE NUMERATOR IN THE FOLLOWING IP C LOCATIONS. C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH. C P MUST BE OF DOUBLE PRECISION C IP - DIMENSION OF THE NUMERATOR (INPUT VALUE) C IQ - DIMENSION OF THE DENOMINATOR (INPUT VALUE) C IER - RESULTANT ERROR PARAMETER C IER =-1 MEANS FORMAL ERRORS C IER = 0 MEANS NO ERRORS C IER = 1,2 MEANS POOR CONVERGENCE OF ITERATION C IER IS ALSO USED AS INPUT VALUE C A NONZERO INPUT VALUE INDICATES AVAILABILITY OF AN C INITIAL APPROXIMATION STORED IN P C C REMARKS C THE COEFFICIENT VECTORS OF THE DENOMINATOR AND NUMERATOR C OF THE RATIONAL APPROXIMATION ARE BOTH STORED IN P C STARTING WITH LOW POWERS (DENOMINATOR FIRST). C IP+IQ MUST NOT EXCEED N, ALL THREE VALUES MUST BE POSITIVE. C SINCE CHEBYSHEV POLYNOMIALS ARE USED AS FUNDAMENTAL C FUNCTIONS, THE ARGUMENTS SHOULD BE REDUCED TO THE INTERVAL C (-1,1). THIS CAN ALWAYS BE ACCOMPLISHED BY MEANS OF A LINEAR C TRANSFORMATION OF THE ORIGINALLY GIVEN ARGUMENTS. C IF A FIT IN OTHER FUNCTIONS IS REQUIRED, DCNP AND DCNPS MUST C BE REPLACED BY SUBROUTINES WHICH ARE OF ANALOGOUS DESIGN. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DAPLL, DAPFS, DFRAT, DCNPS, DCNP C DCNP IS REQUIRED WITHIN DFRAT C C METHOD C THE ITERATIVE SCHEME USED FOR CALCULATION OF THE C APPROXIMATION IS REPEATED SOLUTION OF THE NORMAL EQUATIONS C WHICH ARE OBTAINED BY LINEARIZATION. C A REFINED TECHNIQUE OF THIS LINEAR LEAST SQUARES APPROACH C IS USED WHICH GUARANTEES THAT THE DENOMINATOR IS FREE OF C ZEROES WITHIN THE APPROXIMATION INTERVAL. C FOR REFERENCE SEE C D.BRAESS, UEBER DAEMPFUNG BEI MINIMALISIERUNGSVERFAHREN, C COMPUTING(1966), VOL.1, ED.3, PP.264-272. C D.W.MARQUARDT, AN ALGORITHM FOR LEAST-SQUARES ESTIMATION C OF NONLINEAR PARAMETERS, C JSIAM(1963), VOL.11, ED.2, PP.431-441. C C .................................................................. C SUBROUTINE DARAT(DATI,N,WORK,P,IP,IQ,IER) C C EXTERNAL DFRAT C C DIMENSIONED LOCAL VARIABLE DIMENSION IERV(3) C C DIMENSIONED DUMMY VARIABLES DIMENSION DATI(1),WORK(1),P(1) DOUBLE PRECISION DATI,WORK,P,T,OSUM,DIAG,RELAX,SUM,SSOE,SAVE C C INITIALIZE TESTVALUES LIMIT=20 ETA=1.E-29 EPS=1.E-14 C C CHECK FOR FORMAL ERRORS IF(N)4,4,1 1 IF(IP)4,4,2 2 IF(IQ)4,4,3 3 IPQ=IP+IQ IF(N-IPQ)4,5,5 C C ERROR RETURN IN CASE OF FORMAL ERRORS 4 IER=-1 RETURN C C INITIALIZE ITERATION PROCESS 5 KOUNT=0 IERV(2)=IP IERV(3)=IQ NDP=N+N+1 NNE=NDP+NDP IX=IPQ-1 IQP1=IQ+1 IRHS=NNE+IPQ*IX/2 IEND=IRHS+IX C C TEST FOR AVAILABILITY OF AN INITIAL APPROXIMATION IF(IER)8,6,8 C C INITIALIZE NUMERATOR AND DENOMINATOR 6 DO 7 I=2,IPQ 7 P(I)=0.D0 P(1)=1.D0 C C CALCULATE VALUES OF NUMERATOR AND DENOMINATOR FOR INITIAL C APPROXIMATION 8 DO 9 J=1,N T=DATI(J) I=J+N CALL DCNPS(WORK(I),T,P(IQP1),IP) K=I+N 9 CALL DCNPS(WORK(K),T,P,IQ) C C SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION) 10 CALL DAPLL(DFRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV) C C CHECK FOR ZERO DENOMINATOR IF(IERV(1))4,11,4 11 INCR=0 RELAX=2.D0 C C RESTORE MATRIX IN WORKING STORAGE 12 J=IEND DO 13 I=NNE,IEND J=J+1 13 WORK(I)=WORK(J) IF(KOUNT)14,14,15 C C SAVE SQUARE SUM OF ERRORS 14 OSUM=WORK(IEND) DIAG=OSUM*EPS K=IQ C C ADD CONSTANT TO DIAGONAL IF(WORK(NNE))17,17,19 15 IF(INCR)19,19,16 16 K=IPQ 17 J=NNE-1 DO 18 I=1,K WORK(J)=WORK(J)+DIAG 18 J=J+I C C SOLVE NORMAL EQUATIONS 19 CALL DAPFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER) C C CHECK FOR FAILURE OF EQUATION SOLVER IF(IRES)4,4,20 C C TEST FOR DEFECTIVE NORMALEQUATIONS 20 IF(IRES-IX)21,24,24 21 IF(INCR)22,22,23 22 DIAG=DIAG*0.125D0 23 DIAG=DIAG+DIAG INCR=INCR+1 C C START WITH OVER RELAXATION RELAX=8.D0 IF(INCR-LIMIT)12,45,45 C C CALCULATE VALUES OF CHANGE OF NUMERATOR AND DENOMINATOR 24 L=NDP J=NNE+IRES*(IRES-1)/2-1 K=J+IQ WORK(J)=0.D0 IRQ=IQ IRP=IRES-IQ+1 IF(IRP)25,26,26 25 IRQ=IRES+1 26 DO 29 I=1,N T=DATI(I) WORK(I)=0.D0 CALL DCNPS(WORK(I),T,WORK(K),IRP) M=L+N CALL DCNPS(WORK(M),T,WORK(J),IRQ) IF(WORK(M)*WORK(L))27,29,29 27 SUM=WORK(L)/WORK(M) IF(RELAX+SUM)29,29,28 28 RELAX=-SUM 29 L=L+1 C C MODIFY RELAXATION FACTOR IF NECESSARY SSOE=OSUM ITER=LIMIT 30 SUM=0.D0 RELAX=RELAX*0.5D0 DO 32 I=1,N M=I+N K=M+N L=K+N SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L)) SAVE=SAVE*SAVE IF(DATI(NDP))32,32,31 31 SAVE=SAVE*DATI(K) 32 SUM=SUM+SAVE IF(ITER)45,33,33 33 ITER=ITER-1 IF(SUM-OSUM)34,37,35 34 OSUM=SUM GOTO 30 C C TEST FOR IMPROVEMENT 35 IF(OSUM-SSOE)36,30,30 36 RELAX=RELAX+RELAX 37 T=0. SAVE=0.D0 K=IRES+1 DO 38 I=2,K J=J+1 T=T+DABS(P(I)) P(I)=P(I)+RELAX*WORK(J) 38 SAVE=SAVE+DABS(P(I)) C C UPDATE CURRENT VALUES OF NUMERATOR AND DENOMINATOR DO 39 I=1,N J=I+N K=J+N L=K+N WORK(J)=WORK(J)+RELAX*WORK(I) 39 WORK(K)=WORK(K)+RELAX*WORK(L) C C TEST FOR CONVERGENCE IF(INCR)40,40,42 40 IF(SSOE-OSUM-RELAX*OSUM*DBLE(EPS))46,46,41 41 IF(DABS(T-SAVE)-RELAX*SAVE*DBLE(EPS))46,46,42 42 IF(OSUM-SAVE*DBLE(ETA))46,46,43 43 KOUNT=KOUNT+1 IF(KOUNT-LIMIT)10,44,44 C C ERROR RETURN IN CASE OF POOR CONVERGENCE 44 IER=2 RETURN 45 IER=1 RETURN C C NORMAL RETURN 46 IER=0 RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR DATA SCREENING - DASCR C C PURPOSE C PERFORM DATA SCREENING CALCULATIONS ON A SET OF OBSERVATIONS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SUBST C TAB1 C LOC C BOOL C HIST C MATIN C C METHOD C DERIVE A SUBSET OF OBSERVATIONS SATISFYING CERTAIN C CONDITIONS ON THE VARIABLES. FOR THIS SUBSET, THE FREQUENCY C OF A SELECTED VARIABLE OVER GIVEN CLASS INTERVALS IS C OBTAINED. THIS IS PLOTTED IN THE FORM OF A HISTOGRAM. C TOTAL, AVERAGE, STANDARD DEVIATION, MINIMUM, AND MAXIMUM C ARE ALSO CALCULATED. C C .................................................................. cC c DIMENSION A(1000),C(63),UBO(3),S(200),R(21),FREQ(20), c 1PCT(20),STATS(5) c EXTERNAL BOOL c10 FORMAT(1H1,22HDATA SCREENING PROBLEM,I3) c11 FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4) c12 FORMAT(1H0,20HEXECUTION TERMINATED) c13 FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4) c14 FORMAT(1H0,18HGO ON TO NEXT CASE) c15 FORMAT(1H0,11HEND OF CASE) c16 FORMAT(7(F2.0,F1.0,F7.0)) c17 FORMAT(3F10.0) c18 FORMAT(1H0,13HSUBSET VECTOR,///) c19 FORMAT(1H ,I3,F5.0) c20 FORMAT(1H1,32HSUMMARY STATISTICS FOR VARIABLE ,I3) c21 FORMAT(1H0,7HTOTAL =,F10.3,2X,9HAVERAGE =,F10.3,2X,20HSTANDARD DEV c 1IATION =,F10.3,2X,9HMINIMUM =,F10.3,2X,9HMAXIMUM =,F10.3) c22 FORMAT(2I2) cC DOUBLE PRECISION TMPFIL,FILE cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC FILE = TMPFIL('SSP') cC OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT', cC 1 DISPOSE='DELETE') cC c KC=0 c24 KC=KC+1 c CALL MATIN(ICOD,A,1000,NO,NV,MS,IER) c IF(NO) 25,50,25 c25 IF(IER-1) 40,30,35 c30 WRITE(6,11) ICOD c WRITE(6,14) c GO TO 24 c35 WRITE(6,13) c WRITE(6,12) c GO TO 50 c40 READ(5,22)NC,NOVAR c JC=NC*3 c READ(5,16)(C(I),I=1,JC) c READ(5,17)(UBO(I),I=1,3) c CALL SUBST(A,C,R,BOOL,S,NO,NV,NC) c WRITE(6,10)KC c WRITE(6,18) c WRITE(6,19) (I,S(I),I=1,NO) c CALL TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV) c WRITE(6,20) NOVAR c WRITE(6,21)(STATS(I),I=1,5) c JZ=UBO(2) c CALL HIST(KC,FREQ,JZ) c WRITE(6,15) c GO TO 24 c 50 CONTINUE c END C C .................................................................. C C SAMPLE INPUT SUBROUTINE - DATA C C PURPOSE C READ AN OBSERVATION (M DATA VALUES) FROM INPUT DEVICE. C THIS SUBROUTINE IS CALLED BY THE SUBROUTINE CORRE AND MUST C BE PROVIDED BY THE USER. IF SIZE AND LOCATION OF DATA C FIELDS ARE DIFFERENT FROM PROBLEM TO PROBLEM, THIS SUB- C ROUTINE MUST BE RECOMPILED WITH A PROPER FORMAT STATEMENT. C C USAGE C CALL DATA (M,D) C C DESCRIPTION OF PARAMETERS C M - THE NUMBER OF VARIABLES IN AN OBSERVATION. C D - OUTPUT VECTOR OF LENGTH M CONTAINING THE OBSERVATION C DATA. C C REMARKS C THE TYPE OF CONVERSION SPECIFIED IN THE FORMAT MUST BE C EITHER F OR E. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C .................................................................. C SUBROUTINE DATA (M,D) C DIMENSION D(1) C 1 FORMAT(12F6.0) C C READ AN OBSERVATION FROM INPUT DEVICE. C READ (5,1) (D(I),I=1,M) C C INPUT DATA ARE WRITTEN ON LOGICAL TAPE 9 FOR THE RESIDUAL ANALY- C SIS PERFORMED IN THE SAMPLE MULTIPLE REGRESSION PROGRAM. C WRITE (9) (D(I),I=1,M) RETURN END C C .................................................................. C C SUBROUTINE DATSE C C PURPOSE C NDIM POINTS OF A GIVEN TABLE WITH EQUIDISTANT ARGUMENTS ARE C SELECTED AND ORDERED SUCH THAT C ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL DATSE (X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION SEARCH ARGUMENT. C ZS - DOUBLE PRECISION STARTING VALUE OF ARGUMENTS. C DZ - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES. C F - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR C OF FUNCTION VALUES (DIMENSION IROW). C IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2 C MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC- C TION VALUES AND THE SECOND VECTOR OF DERIVATIVES. C IROW - THE DIMENSION OF EACH COLUMN IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND C ORDERED ARGUMENT VALUES (DIMENSION NDIM). C VAL - RESULTING DOUBLE PRECISION VECTOR OF SELECTED C FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1. C IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR C OF FUNCTION AND DERIVATIVE VALUES (DIMENSION C 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC- C TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE. C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE DATSE. C SUBROUTINE DATSE ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY COMPUTING THE SUBSCRIPT J OF THAT C ARGUMENT, WHICH IS NEXT TO X. C AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND C SELECTED IN THE ABOVE SENSE. C C .................................................................. C SUBROUTINE DATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION F(1),ARG(1),VAL(1) DOUBLE PRECISION X,ZS,DZ,F,ARG,VAL IF(IROW-1)19,17,1 C C CASE DZ=0 IS CHECKED OUT 1 IF(DZ)2,17,2 2 N=NDIM C C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)4,4,3 3 N=IROW C C COMPUTATION OF STARTING SUBSCRIPT J. 4 J=(X-ZS)/DZ+1.5D0 IF(J)5,5,6 5 J=1 6 IF(J-IROW)8,8,7 7 J=IROW C C GENERATION OF TABLE ARG,VAL IN CASE DZ.NE.0. 8 II=J JL=0 JR=0 DO 16 I=1,N ARG(I)=ZS+DFLOAT(II-1)*DZ IF(ICOL-2)9,10,10 9 VAL(I)=F(II) GOTO 11 10 VAL(2*I-1)=F(II) III=II+IROW VAL(2*I)=F(III) 11 IF(J+JR-IROW)12,15,12 12 IF(J-JL-1)13,14,13 13 IF((ARG(I)-X)*DZ)14,15,15 14 JR=JR+1 II=J+JR GOTO 16 15 JL=JL+1 II=J-JL 16 CONTINUE RETURN C C CASE DZ=0 17 ARG(1)=ZS VAL(1)=F(1) IF(ICOL-2)19,19,18 18 VAL(2)=F(2) 19 RETURN END C C .................................................................. C C SUBROUTINE DATSG C C PURPOSE C NDIM POINTS OF A GIVEN GENERAL TABLE ARE SELECTED AND C ORDERED SUCH THAT ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL DATSG (X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION SEARCH ARGUMENT. C Z - DOUBLE PRECISION VECTOR OD ARGUMENT VALUES C (DIMENSION IROW). C F - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR C OF FUNCTION VALUES (DIMENSION IROW). C IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2 C MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC- C TION VALUES AND THE SECOND VECTOR OF DERIVATIVES. C WORK - DOUBLE PRECISION WORKING STORAGE (DIMENSION IROW). C IROW - THE DIMENSION OF VECTORS Z AND WORK AND OF EACH C COLUMN IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND C ORDERED ARGUMENT VALUES (DIMENSION NDIM). C VAL - RESULTING DOUBLE PRECISION VECTOR OF SELECTED C FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1. C IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR C OF FUNCTION AND DERIVATIVE VALUES (DIMENSION C 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC- C TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE (Z,F). C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE DATSG. C SUBROUTINE DATSG ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY GENERATING THE VECTOR WORK WITH C COMPONENTS WORK(I)=ABS(Z(I)-X) AND AT EACH OF THE NDIM STEPS C (OR IROW STEPS IF NDIM IS GREATER THAN IROW) C SEARCHING FOR THE SUBSCRIPT OF THE SMALLEST COMPONENT, WHICH C IS AFTERWARDS REPLACED BY A NUMBER GREATER THAN C MAX(WORK(I)). C C .................................................................. C SUBROUTINE DATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1) DOUBLE PRECISION X,Z,F,WORK,ARG,VAL,B,DELTA IF(IROW)11,11,1 1 N=NDIM C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)3,3,2 2 N=IROW C C GENERATION OF VECTOR WORK AND COMPUTATION OF ITS GREATEST ELEMENT. 3 B=0.D0 DO 5 I=1,IROW DELTA=DABS(Z(I)-X) IF(DELTA-B)5,5,4 4 B=DELTA 5 WORK(I)=DELTA C C GENERATION OF TABLE (ARG,VAL) B=B+1.D0 DO 10 J=1,N DELTA=B DO 7 I=1,IROW IF(WORK(I)-DELTA)6,7,7 6 II=I DELTA=WORK(I) 7 CONTINUE ARG(J)=Z(II) IF(ICOL-1)8,9,8 8 VAL(2*J-1)=F(II) III=II+IROW VAL(2*J)=F(III) GOTO 10 9 VAL(J)=F(II) 10 WORK(II)=B 11 RETURN END C C .................................................................. C C SUBROUTINE DATSM C C PURPOSE C NDIM POINTS OF A GIVEN TABLE WITH MONOTONIC ARGUMENTS ARE C SELECTED AND ORDERED SUCH THAT C ABS(ARG(I)-X).GE.ABS(ARG(J)-X) IF I.GT.J. C C USAGE C CALL DATSM (X,Z,F,IROW,ICOL,ARG,VAL,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION SEARCH ARGUMENT. C Z - DOUBLE PRECISION VECTOR OF ARGUMENT VALUES (DIMEN- C SION IROW). THE ARGUMENT VALUES MUST BE STORED IN C INCREASING OR DECREASING SEQUENCE. C F - IN CASE ICOL=1, F IS THE DOUBLE PRECISION VECTOR C OF FUNCTION VALUES (DIMENSION IROW). C IN CASE ICOL=2, F IS A DOUBLE PRECISION IROW BY 2 C MATRIX. THE FIRST COLUMN SPECIFIES VECTOR OF FUNC- C TION VALUES AND THE SECOND VECTOR OF DERIVATIVES. C IROW - THE DIMENSION OF VECTOR Z AND OF EACH COLUMN C IN MATRIX F. C ICOL - THE NUMBER OF COLUMNS IN F (I.E. 1 OR 2). C ARG - RESULTING DOUBLE PRECISION VECTOR OF SELECTED AND C ORDERED ARGUMENT VALUES (DIMENSION NDIM). C VAL - RESULTING DOUBLE PRECISION VECTOR OF SELECTED C FUNCTION VALUES (DIMENSION NDIM) IN CASE ICOL=1. C IN CASE ICOL=2, VAL IS THE DOUBLE PRECISION VECTOR C OF FUNCTION AND DERIVATIVE VALUES (DIMENSION C 2*NDIM) WHICH ARE STORED IN PAIRS (I.E. EACH FUNC- C TION VALUE IS FOLLOWED BY ITS DERIVATIVE VALUE). C NDIM - THE NUMBER OF POINTS WHICH MUST BE SELECTED OUT OF C THE GIVEN TABLE (Z,F). C C REMARKS C NO ACTION IN CASE IROW LESS THAN 1. C IF INPUT VALUE NDIM IS GREATER THAN IROW, THE PROGRAM C SELECTS ONLY A MAXIMUM TABLE OF IROW POINTS. THEREFORE THE C USER OUGHT TO CHECK CORRESPONDENCE BETWEEN TABLE (ARG,VAL) C AND ITS DIMENSION BY COMPARISON OF NDIM AND IROW, IN ORDER C TO GET CORRECT RESULTS IN FURTHER WORK WITH TABLE (ARG,VAL). C THIS TEST MAY BE DONE BEFORE OR AFTER CALLING C SUBROUTINE DATSM. C SUBROUTINE DATSM ESPECIALLY CAN BE USED FOR GENERATING THE C TABLE (ARG,VAL) NEEDED IN SUBROUTINES DALI, DAHI, AND DACFI. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SELECTION IS DONE BY SEARCHING THE SUBSCRIPT J OF THAT C ARGUMENT, WHICH IS NEXT TO X (BINARY SEARCH). C AFTERWARDS NEIGHBOURING ARGUMENT VALUES ARE TESTED AND C SELECTED IN THE ABOVE SENSE. C C .................................................................. C SUBROUTINE DATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM) C C DIMENSION Z(1),F(1),ARG(1),VAL(1) DOUBLE PRECISION X,Z,F,ARG,VAL C C CASE IROW=1 IS CHECKED OUT IF(IROW-1)23,21,1 1 N=NDIM C C IF N IS GREATER THAN IROW, N IS SET EQUAL TO IROW. IF(N-IROW)3,3,2 2 N=IROW C C CASE IROW.GE.2 C SEARCHING FOR SUBSCRIPT J SUCH THAT Z(J) IS NEXT TO X. 3 IF(Z(IROW)-Z(1))5,4,4 4 J=IROW I=1 GOTO 6 5 I=IROW J=1 6 K=(J+I)/2 IF(X-Z(K))7,7,8 7 J=K GOTO 9 8 I=K 9 IF(IABS(J-I)-1)10,10,6 10 IF(DABS(Z(J)-X)-DABS(Z(I)-X))12,12,11 11 J=I C C TABLE SELECTION 12 K=J JL=0 JR=0 DO 20 I=1,N ARG(I)=Z(K) IF(ICOL-1)14,14,13 13 VAL(2*I-1)=F(K) KK=K+IROW VAL(2*I)=F(KK) GOTO 15 14 VAL(I)=F(K) 15 JJR=J+JR IF(JJR-IROW)16,18,18 16 JJL=J-JL IF(JJL-1)19,19,17 17 IF(DABS(Z(JJR+1)-X)-DABS(Z(JJL-1)-X))19,19,18 18 JL=JL+1 K=J-JL GOTO 20 19 JR=JR+1 K=J+JR 20 CONTINUE RETURN C C CASE IROW=1 21 ARG(1)=Z(1) VAL(1)=F(1) IF(ICOL-2)23,22,23 22 VAL(2)=F(2) 23 RETURN END C C .................................................................. C C SUBROUTINE DBAR C C PURPOSE C TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE C DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11- C TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL - C THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING C FUNCTION VALUES ONLY ON THAT INTERVAL. C C USAGE C CALL DBAR(X,H,IH,FCT,Z) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C X - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED C H - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END- C POINTS ARE X AND X+H (SEE PURPOSE) C IH - INPUT PARAMETER (SEE REMARKS AND METHOD) C IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL C VALUE HH C IH = 0 - THE INTERNAL VALUE HH IS SET TO H C FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL C GENERATE THE NECESSARY FUNCTION VALUES C Z - RESULTING DERIVATIVE VALUE C C REMARKS C (1) IF H = 0, THEN THERE IS NO COMPUTATION. C (2) THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER- C MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN C THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE C METHOD.) IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES C HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN- C CATION ERROR. HH ALWAYS HAS THE SAME SIGN AS H AND IT IS C ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB- C SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED C INTERVAL DETERMINED BY H. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY C THE USER. C C METHOD C THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S C EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED C DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS C (X,X+(K*HH)/10)K=1,...,10. (SEE FILLIPI, S. AND ENGELS, H., C ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE C DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.) C C .................................................................. C SUBROUTINE DBAR(X,H,IH,FCT,Z) C C DIMENSION AUX(10) C C NO ACTION IN CASE OF ZERO INTERVAL LENGTH IF(H)1,17,1 C C GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES 1 C=ABS(H) B=H D=X D=FCT(D) IF(IH)2,9,2 2 HH=.5 IF(C-HH)3,4,4 3 HH=B 4 HH=SIGN(HH,B) Z=ABS((FCT(X+HH)-D)/HH) A=ABS(D) HH=1. IF(A-1.)6,6,5 5 HH=HH*A 6 IF(Z-1.)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=B 10 HH=SIGN(HH,B) C C INITIALIZE DIFFERENTIATION LOOP Z=(FCT(X+HH)-D)/HH J=10 JJ=J-1 AUX(J)=Z DH=HH/FLOAT(J) DZ=1.7E38 0 C C START DIFFERENTIATION LOOP 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-D)/HH C C INITIALIZE EXTRAPOLATION LOOP D2=1.7E38 0 B=0. A=1./C C C START EXTRAPOLATION LOOP DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/B AUX(I+1)=AUX(I)+HH C C TEST ON OSCILLATING INCREMENTS D2=ABS(HH) IF(D2-D1)12,13,13 12 CONTINUE C END OF EXTRAPOLATION LOOP C C UPDATE RESULT VALUE Z I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 C END OF DIFFERENTIATION LOOP C 17 RETURN END C C .................................................................. C C SUBROUTINE DCAR C C PURPOSE C TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE C DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11- C TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED C SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION C VALUES ONLY ON THAT CLOSED INTERVAL. C C USAGE C CALL DCAR (X,H,IH,FCT,Z) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C X - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED C H - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED, C SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE) C IH - INPUT PARAMETER (SEE REMARKS AND METHOD) C IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL C VALUE HH C IH = 0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H C FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM THAT WILL C GENERATE THE NECESSARY FUNCTION VALUES C Z - RESULTING DERIVATIVE VALUE C C REMARKS C (1) IF H = 0, THEN THERE IS NO COMPUTATION. C (2) THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO C IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF C THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.) IF IH IS C NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO C CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR. HH C IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE C VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS C ABSOLUTE H OF X. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY C THE USER. C C METHOD C THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S C EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL C DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS C (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5. (SEE FILLIPI, S. AND C ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, C ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.) C C .................................................................. C SUBROUTINE DCAR(X,H,IH,FCT,Z) C C DIMENSION AUX(5) C C NO ACTION IN CASE OF ZERO INTERVAL LENGTH IF(H)1,17,1 C C GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES 1 C=ABS(H) IF(IH)2,9,2 2 HH=.5 IF(C-HH)3,4,4 3 HH=C 4 A=FCT(X+HH) B=FCT(X-HH) Z=ABS((A-B)/(HH+HH)) A=.5*ABS(A+B) HH=.5 IF(A-1.)6,6,5 5 HH=HH*A 6 IF(Z-1.)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=C C C INITIALIZE DIFFERENTIATION LOOP 10 Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH) J=5 JJ=J-1 AUX(J)=Z DH=HH/FLOAT(J) DZ=1.7E38 0 C C START DIFFERENTIATION LOOP 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH) C C INITIALIZE EXTRAPOLATION LOOP D2=1.7E38 0 B=0. A=1./C C C START EXTRAPOLATION LOOP DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/(B*(2.+B)) AUX(I+1)=AUX(I)+HH C C TEST ON OSCILLATING INCREMENTS D2=ABS(HH) IF(D2-D1)12,13,13 12 CONTINUE C END OF EXTRAPOLATION LOOP C C UPDATE RESULT VALUE Z I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 C END OF DIFFERENTIATION LOOP C 17 RETURN END C C .................................................................. C C SUBROUTINE DCEL1 C C PURPOSE C CALCULATE COMPLETE ELLIPTIC INTEGRAL OF FIRST KIND C C USAGE C CALL DCEL1(RES,AK,IER) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE IN DOUBLE PRECISION C AK - MODULUS (INPUT) IN DOUBLE PRECISION C IER - RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 AK NOT IN RANGE -1 TO +1 C C REMARKS C THE RESULT IS SET TO 1.E75 IF ABS(AK) GE 1 C FOR MODULUS AK AND COMPLEMENTARY MODULUS CK, C EQUATION AK*AK+CK*CK=1.D0 IS USED. C AK MUST BE IN THE RANGE -1 TO +1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C CEL1(AK)=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED C OVER T FROM 0 TO INFINITY). C EQUIVALENT ARE THE DEFINITIONS C CEL1(AK)=INTEGRAL(1/(COS(T)SQRT(1+(CK*TAN(T))**2)),SUMMED C OVER T FROM 0 TO PI/2), C CEL1(AK)=INTEGRAL(1/SQRT(1-(AK*SIN(T))**2),SUMMED OVER T C FROM 0 TO PI/2), WHERE K=SQRT(1.-CK*CK). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS C AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS, C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE DCEL1(RES,AK,IER) DOUBLE PRECISION RES,AK,GEO,ARI,AARI IER=0 ARI=2.D0 GEO=(0.5D0-AK)+0.5D0 GEO=GEO+GEO*AK RES=0.5D0 IF(GEO)1,2,4 1 IER=1 2 RES=1.7D38 0 RETURN 3 GEO=GEO*AARI 4 GEO=DSQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO RES=RES+RES IF(GEO/AARI-0.999999995D0)3,5,5 5 RES=RES/ARI*6.2831853071795865D0 RETURN END C C .................................................................. C C SUBROUTINE DCEL2 C C PURPOSE C COMPUTES THE GENERALIZED COMPLETE ELLIPTIC INTEGRAL OF C SECOND KIND. C C USAGE C CALL DCEL2(RES,AK,A,B,IER) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE IN DOUBLE PRECISION C AK - MODULUS (INPUT) IN DOUBLE PRECISION C A - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR C B - DOUBLE PRECISION FACTOR OF QUADRATIC TERM C IN NUMERATOR C IER - RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 AK NOT IN RANGE -1 TO +1 C C REMARKS C FOR ABS(AK) GE 1 THE RESULT IS SET TO 1.E75 IF B IS C POSITIVE, TO -1.7D38 IF B IS NEGATIVE. 0 C SPECIAL CASES ARE C K(K) OBTAINED WITH A = 1, B = 1 C E(K) OBTAINED WITH A = 1, B = CK*CK WHERE CK IS C COMPLEMENTARY MODULUS. C B(K) OBTAINED WITH A = 1, B = 0 C D(K) OBTAINED WITH A = 0, B = 1 C WHERE K, E, B, D DEFINE SPECIAL CASES OF THE GENERALIZED C COMPLETE ELLIPTIC INTEGRAL OF SECOND KIND IN THE USUAL C NOTATION, AND THE ARGUMENT K OF THESE FUNCTIONS MEANS C THE MODULUS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C RES=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)) C SUMMED OVER T FROM 0 TO INFINITY). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R.BULIRSCH, 'NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS C AND ELLIPTIC FUNCTIONS', HANDBOOK SERIES SPECIAL FUNCTIONS, C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE DCEL2(RES,AK,A,B,IER) DOUBLE PRECISION RES,AK,A,B,GEO,ARI,AARI,B0,A1 IER=0 ARI=2.D0 GEO=(0.5D0-AK)+0.5D0 GEO=GEO+GEO*AK RES=A A1=A+B B0=B+B IF(GEO)1,2,6 1 IER=1 2 IF(B)3,8,4 3 RES=-1.7D38 0 RETURN 4 RES=1.7D38 0 RETURN 5 GEO=GEO*AARI 6 GEO=DSQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO B0=B0+RES*GEO RES=A1 B0=B0+B0 A1=B0/ARI+A1 IF(GEO/AARI-0.999999995D0)5,7,7 7 RES=A1/ARI RES=RES+0.57079632679489662D0*RES 8 RETURN END C C .................................................................. C C SUBROUTINE DCLA C C PURPOSE C SET EACH DIAGONAL ELEMENT OF A MATRIX EQUAL TO A SCALAR C C USAGE C CALL DCLA (A,C,N,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C N - NUMBER OF ROWS AND COLUMNS IN MATRIX A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C INPUT MATRIX MUST BE A SQUARE MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT ON DIAGONAL OF MATRIX IS REPLACED BY SCALAR C C C .................................................................. C SUBROUTINE DCLA(A,C,N,MS) DIMENSION A(1) C DO 3 I=1,N C C LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,I,ID,N,N,MS) C C REPLACE DIAGONAL ELEMENTS C 3 A(ID)=C RETURN END C C .................................................................. C C SUBROUTINE DCNP C C PURPOSE C COMPUTE THE VALUES OF THE CHEBYSHEV POLYNOMIALS T(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL DCNP,Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C DOUBLE PRECISION VECTOR. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE. C X - ARGUMENT OF CHEBYSHEV POLYNOMIAL C N - ORDER OF CHEBYSHEV POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C CHEBYSHEV POLYNOMIALS T(N,X) C T(N+1,X)=2*X*T(N,X)-T(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE T(0,X)=1, T(1,X)=X. C C .................................................................. C SUBROUTINE DCNP(Y,X,N) C DIMENSION Y(1) DOUBLE PRECISION Y,X,F C Y(1)=1.D0 IF(N)1,1,2 1 RETURN C 2 Y(2)=X IF(N-1)1,1,3 C C INITIALIZATION 3 F=X+X C DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END C C .................................................................. C C SUBROUTINE DCNPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN CHEBYSHEV C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL DCNPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE C X - ARGUMENT VALUE C DOUBLE PRECISION VARIABLE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION C USING THE RECURRENCE EQUATION FOR CHEBYSHEV POLYNOMIALS C T(N+1,X)=2*X*T(N,X)-T(N-1,X). C C .................................................................. C SUBROUTINE DCNPS(Y,X,C,N) C DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 IF(N-2)3,4,4 3 Y=C(1) RETURN C C INITIALIZATION 4 ARG=X+X H1=0.D0 H0=0.D0 C DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5D0*(C(1)-H2+H0) RETURN END C C .................................................................. C C SUBROUTINE DCPY C C PURPOSE C COPY DIAGONAL ELEMENTS OF A MATRIX INTO A VECTOR C C USAGE C CALL DCPY (A,R,N,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF OUTPUT VECTOR OF LENGTH N C N - NUMBER OF ROWS AND COLUMNS IN MATRIX A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C INPUT MATRIX MUST BE A SQUARE MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS ON DIAGONAL OF MATRIX ARE MOVED TO CORRESPONDING C POSITIONS OF VECTOR R C C .................................................................. C SUBROUTINE DCPY(A,R,N,MS) DIMENSION A(1),R(1) C DO 3 J=1,N C C LOCATE DIAGONAL ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(J,J,IJ,N,N,MS) C C MOVE DIAGONAL ELEMENT TO VECTOR R C 3 R(J)=A(IJ) RETURN END C C .................................................................. C C SUBROUTINE DCSP C C PURPOSE C COMPUTE THE VALUES OF THE SHIFTED CHEBYSHEV POLYNOMIALS C TS(N,X) FOR ARGUMENT X AND ORDERS 0 UP TO N. C C USAGE C CALL DCSP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF SHIFTED CHEBYSHEV POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C DOUBLE PRECISION VECTOR. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF SHIFTED CHEBYSHEV POLYNOMIAL C DOUBLE PRECISION VARIABLE. C N - ORDER OF SHIFTED CHEBYSHEV POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X) C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1. C C .................................................................. C SUBROUTINE DCSP(Y,X,N) C DIMENSION Y(1) DOUBLE PRECISION Y,X,F C C TEST OF ORDER Y(1)=1.D0 IF(N)1,1,2 1 RETURN C 2 Y(2)=X+X-1.D0 IF(N-1)1,1,3 C C INITIALIZATION 3 F=Y(2)+Y(2) C DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END C C .................................................................. C C SUBROUTINE DCSPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN SHIFTED C CHEBYSHEV POLYNOMIALS WITH COEFFICIENT VECTOR C C FOR ARGUMENT VALUE X. C C USAGE C CALL DCSPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE C X - ARGUMENT VALUE C DOUBLE PRECISION VARIABLE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF BACKWARD RECURSION C USING THE RECURRENCE EQUATION FOR SHIFTED C CHEBYSHEV POLYNOMIALS C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X). C C .................................................................. C SUBROUTINE DCSPS(Y,X,C,N) C DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 IF(N-2)3,4,4 3 Y=C(1) RETURN C C INITIALIZATION 4 ARG=X+X-1.D0 ARG=ARG+ARG H1=0.D0 H0=0.D0 DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5D0*(C(1)-H2+H0) RETURN END C C .................................................................. C C SUBROUTINE DDBAR C C PURPOSE C TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE C DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11- C TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED INTERVAL - C THE SET OF T BETWEEN X AND X+H (H POSITIVE OR NEGATIVE) - USING C FUNCTION VALUES ONLY ON THAT INTERVAL. C C USAGE C CALL DDBAR(X,H,IH,FCT,Z,) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C X - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED C X IS IN DOUBLE PRECISION C H - THE NUMBER THAT DEFINES THE CLOSED INTERVAL WHOSE END- C POINTS ARE X AND X+H (SEE PURPOSE) C H IS IN SINGLE PRECISION C IH - INPUT PARAMETER (SEE REMARKS AND METHOD) C IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL C VALUE HH C IH = 0 - THE INTERNAL VALUE HH IS SET TO H C FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION C VALUES. C Z - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION C C REMARKS C (1) IF H = 0, THEN THERE IS NO COMPUTATION. C (2) THE (MAGNITUDE OF THE) INTERNAL VALUE HH, WHICH IS DETER- C MINED ACCORDING TO IH, IS THE MAXIMUM STEP-SIZE USED IN C THE COMPUTATION OF THE ONE-SIDED DIVIDED DIFFERENCES (SEE C METHOD.) IF IH IS NON-ZERO, THEN THE SUBROUTINE GENERATES C HH ACCORDING TO CRITERIA THAT BALANCE ROUND-OFF AND TRUN- C CATION ERROR. HH ALWAYS HAS THE SAME SIGN AS H AND IT IS C ALWAYS LESS THAN OR EQUAL TO THE MAGNITUDE OF H IN AB- C SOLUTE VALUE, SO THAT ALL COMPUTATION OCCURS IN THE CLOSED C INTERVAL DETERMINED BY H. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY C THE USER. FCT(T) IS IN DOUBLE PRECISION C C METHOD C THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S C EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF ONE-SIDED C DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS C (X,X+(K*HH)/10)K=1,...,10. (SEE FILLIPI, S. AND ENGELS, H., C ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, ELECTRONISCHE C DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.) C C .................................................................. C SUBROUTINE DDBAR(X,H,IH,FCT,Z) C C DIMENSION AUX(10) DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,D,DH,HH C C NO ACTION IN CASE OF ZERO INTERVAL LENGTH IF(H)1,17,1 C C GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES 1 C=ABS(H) B=H D=X D=FCT(D) IF(IH)2,9,2 2 HH=.5D-2 IF(C-HH)3,4,4 3 HH=B 4 HH=DSIGN(HH,B) Z=DABS((FCT(X+HH)-D)/HH) A=DABS(D) HH=1.D-2 IF(A-1.D0)6,6,5 5 HH=HH*A 6 IF(Z-1.D0)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=B 10 HH=DSIGN(HH,B) C C INITIALIZE DIFFERENTIATION LOOP Z=(FCT(X+HH)-D)/HH J=10 JJ=J-1 AUX(J)=Z DH=HH/DFLOAT(J) DZ=1.7E38 0 C C START DIFFERENTIATION LOOP 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-D)/HH C C INITIALIZE EXTRAPOLATION LOOP D2=1.7E38 0 B=0.D0 A=1.D0/C C C START EXTRAPOLATION LOOP DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/B AUX(I+1)=AUX(I)+HH C C TEST ON OSCILLATING INCREMENTS D2=DABS(HH) IF(D2-D1)12,13,13 12 CONTINUE C END OF EXTRAPOLATION LOOP C C UPDATE RESULT VALUE Z I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 C END OF DIFFERENTIATION LOOP C 17 RETURN END C C .................................................................. C C SUBROUTINE DDCAR C C PURPOSE C TO COMPUTE, AT A GIVEN POINT X, AN APPROXIMATION Z TO THE C DERIVATIVE OF AN ANALYTICALLY GIVEN FUNCTION FCT THAT IS 11- C TIMES DIFFERENTIABLE IN A DOMAIN CONTAINING A CLOSED, 2-SIDED C SYMMETRIC INTERVAL OF RADIUS ABSOLUTE H ABOUT X, USING FUNCTION C VALUES ONLY ON THAT CLOSED INTERVAL. C C USAGE C CALL DDCAR(X,H,IH,FCT,Z) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C X - THE POINT AT WHICH THE DERIVATIVE IS TO BE COMPUTED C X IS IN DOUBLE PRECISION. C H - THE NUMBER WHOSE ABSOLUTE VALUE DEFINES THE CLOSED, C SYMMETRIC 2-SIDED INTERVAL ABOUT X (SEE PURPOSE) C H IS IN SINGLE PRECISION C IH - INPUT PARAMETER (SEE REMARKS AND METHOD) C IH NON-ZERO - THE SUBROUTINE GENERATES THE INTERNAL C VALUE HH C IH = 0 - THE INTERNAL VALUE HH IS SET TO ABSOLUTE H C FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM THAT WILL GENERATE THE NECESSARY FUNCTION C VALUES. C Z - RESULTING DERIVATIVE VALUE - DOUBLE PRECISION C C REMARKS C (1) IF H = 0, THEN THERE IS NO COMPUTATION. C (2) THE INTERNAL VALUE HH, WHICH IS DETERMINED ACCORDING TO C IH, IS THE MAXIMUM STEP-SIZE USED IN THE COMPUTATION OF C THE CENTRAL DIVIDED DIFFERENCES (SEE METHOD.) IF IH IS C NON-ZERO, THEN THE SUBROUTINE GENERATES HH ACCORDING TO C CRITERIA THAT BALANCE ROUND-OFF AND TRUNCATION ERROR. HH C IS ALWAYS LESS THAN OR EQUAL TO ABSOLUTE H IN ABSOLUTE C VALUE, SO THAT ALL COMPUTATION OCCURS WITHIN A RADIUS C ABSOLUTE H OF X. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(T) MUST BE FURNISHED BY C THE USER. FCT(T) IS IN DOUBLE PRECISION C C METHOD C THE COMPUTATION OF Z IS BASED ON RICHARDSON'S AND ROMBERG'S C EXTRAPOLATION METHOD AS APPLIED TO THE SEQUENCE OF CENTRAL C DIVIDED DIFFERENCES ASSOCIATED WITH THE POINT PAIRS C (X-(K*HH)/5,X+(K*HH)/5) K=1,...,5. (SEE FILLIPI, S. AND C ENGELS, H., ALTES UND NEUES ZUR NUMERISCHEN DIFFERENTIATION, C ELECTRONISCHE DATENVERARBEITUNG, ISS. 2 (1966), PP. 57-65.) C C .................................................................. C SUBROUTINE DDCAR(X,H,IH,FCT,Z) C C DIMENSION AUX(5) DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,DH,HH C C NO ACTION IN CASE OF ZERO INTERVAL LENGTH IF(H)1,17,1 C C GENERATE STEPSIZE HH FOR DIVIDED DIFFERENCES 1 C=ABS(H) IF(IH)2,9,2 2 HH=.5D-2 IF(C-HH)3,4,4 3 HH=C 4 A=FCT(X+HH) B=FCT(X-HH) Z=DABS((A-B)/(HH+HH)) A=.5D0*DABS(A+B) HH=.5D-2 IF(A-1.D0)6,6,5 5 HH=HH*A 6 IF(Z-1.D0)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=C C C INITIALIZE DIFFERENTIATION LOOP 10 Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH) J=5 JJ=J-1 AUX(J)=Z DH=HH/DFLOAT(J) DZ=1.7E38 0 C C START DIFFERENTIATION LOOP 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH) C C INITIALIZE EXTRAPOLATION LOOP D2=1.7E38 0 B=0.D0 A=1.D0/C C C START EXTRAPOLATION LOOP DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/(B*(2.D0+B)) AUX(I+1)=AUX(I)+HH C C TEST ON OSCILLATING INCREMENTS D2=DABS(HH) IF(D2-D1)12,13,13 12 CONTINUE C END OF EXTRAPOLATION LOOP C C UPDATE RESULT VALUE Z I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 C END OF DIFFERENTIATION LOOP C 17 RETURN END C C .................................................................. C C SUBROUTINE DDET3 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF C FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY C SPACED ARGUMENT VALUES. C C USAGE C CALL DDET3(H,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN C SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE C ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE) C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE C VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C IER = 1 - H = 0 C C REMARKS C (1) IF IER = -1,1, THEN THERE IS NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE C DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP.82-84.) C C .................................................................. C SUBROUTINE DDET3(H,Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION H,Y,Z,HH,YY,A,B C C TEST OF DIMENSION IF(NDIM-3)4,1,1 C C TEST OF STEPSIZE 1 IF(H)2,5,2 C C PREPARE DIFFERENTIATION LOOP 2 HH=.5D0/H YY=Y(NDIM-2) B=Y(2)+Y(2) B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1)) C C START DIFFERENTIATION LOOP DO 3 I=3,NDIM A=B B=HH*(Y(I)-Y(I-2)) 3 Z(I-2)=A C END OF DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 A=Y(NDIM-1)+Y(NDIM-1) Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY) Z(NDIM-1)=B RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 3 4 IER=-1 RETURN C C ERROR EXIT IN CASE OF ZERO STEPSIZE 5 IER=1 RETURN END C C .................................................................. C C SUBROUTINE DDET5 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF C FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY C SPACED ARGUMENT VALUES. C C USAGE C CALL DDET5(H,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION CONSTANT DIFFERENCE BETWEEN C SUCCESSIVE ARGUMENT VALUES (H IS POSITIVE IF THE C ARGUMENT VALUES INCREASE AND NEGATIVE OTHERWISE) C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE C VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C IER = 1 - H = 0 C C REMARKS C (1) IF IER = -1,1, THEN THERE IS NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I) C IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 82-84.) C C .................................................................. C SUBROUTINE DDET5(H,Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION H,Y,Z,HH,YY,A,B,C C C TEST OF DIMENSION IF(NDIM-5)4,1,1 C C TEST OF STEPSIZE 1 IF(H)2,5,2 C C PREPARE DIFFERENTIATION LOOP 2 HH=.08333333333333333D0/H YY=Y(NDIM-4) B=HH*(-25.D0*Y(1)+48.D0*Y(2)-36.D0*Y(3)+16.D0*Y(4)-3.D0*Y(5)) C=HH*(-3.D0*Y(1)-10.D0*Y(2)+18.D0*Y(3)-6.D0*Y(4)+Y(5)) C C START DIFFERENTIATION LOOP DO 3 I=5,NDIM A=B B=C C=HH*(Y(I-4)-Y(I)+8.D0*(Y(I-1)-Y(I-3))) 3 Z(I-4)=A C END OF DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 A=HH*(-YY+6.D0*Y(NDIM-3)-18.D0*Y(NDIM-2)+10.D0*Y(NDIM-1) 1 +3.D0*Y(NDIM)) Z(NDIM)=HH*(3.D0*YY-16.D0*Y(NDIM-3)+36.D0*Y(NDIM-2) 1 -48.D0*Y(NDIM-1)+25.D0*Y(NDIM)) Z(NDIM-1)=A Z(NDIM-2)=C Z(NDIM-3)=B RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 4 IER=-1 RETURN C C ERROR EXIT IN CASE OF ZERO STEPSIZE 5 IER=1 RETURN END C C .................................................................. C C SUBROUTINE DDGT3 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF C ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES. C C USAGE C CALL DDGT3(X,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C X - GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES C (DIMENSION NDIM) C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C CORRESPONDING TO X (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION DERIVATIVE C VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS X,Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C IER POSITIVE - X(IER) = X(IER-1) OR X(IER) = C X(IER-2) C C REMARKS C (1) IF IER = -1,2,3, THEN THERE IS NO COMPUTATION. C (2) IF IER = 4,...,N, THEN THE DERIVATIVE VALUES Z(1) C ,..., Z(IER-1) HAVE BEEN COMPUTED. C (3) Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y. IF C X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE C DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 64-68.) C C .................................................................. C SUBROUTINE DDGT3(X,Y,Z,NDIM,IER) C C DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,DY1,DY2,DY3,A,B C C TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3 IER=-1 IF(NDIM-3)8,1,1 C C PREPARE DIFFERENTIATION LOOP 1 A=X(1) B=Y(1) I=2 DY2=X(2)-A IF(DY2)2,9,2 2 DY2=(Y(2)-B)/DY2 C C START DIFFERENTIATION LOOP DO 6 I=3,NDIM A=X(I)-A IF(A)3,9,3 3 A=(Y(I)-B)/A B=X(I)-X(I-1) IF(B)4,9,4 4 DY1=DY2 DY2=(Y(I)-Y(I-1))/B DY3=A A=X(I-1) B=Y(I-1) IF(I-3)5,5,6 5 Z(1)=DY1+DY3-DY2 6 Z(I-1)=DY1+DY2-DY3 C END OF DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 I=NDIM 7 Z(I)=DY2+DY3-DY1 8 RETURN C C ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS 9 IER=I I=I-1 IF(I-2)8,8,7 END C C .................................................................. C C SUBROUTINE DELI1 C C PURPOSE C COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND C C USAGE C CALL DELI1(RES,X,CK) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE IN DOUBLE PRECISION C X - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC C INTEGRAL OF FIRST KIND) IN DOUBLE PRECISION C CK - COMPLEMENTARY MODULUS IN DOUBLE PRECISION C C REMARKS C DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED C OVER T FROM 0 TO X). C EQUIVALENT ARE THE DEFINITIONS C RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED C OVER T FROM 0 TO ATAN(X)), C RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER C T FROM 0 TO ATAN(X)). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIONS. C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE DELI1(RES,X,CK) C DOUBLE PRECISION RES,X,CK,ANGLE,GEO,ARI,PIM,SQGEO,AARI,TEST C IF(X)2,1,2 1 RES=0.D0 RETURN C 2 IF(CK)4,3,4 3 RES=DLOG(DABS(X)+DSQRT(1.D0+X*X)) GOTO 13 C 4 ANGLE=DABS(1.D0/X) GEO=DABS(CK) ARI=1.D0 PIM=0.D0 5 SQGEO=ARI*GEO AARI=ARI ARI=GEO+ARI ANGLE=-SQGEO/ANGLE+ANGLE SQGEO=DSQRT(SQGEO) IF(ANGLE)7,6,7 C C REPLACE 0 BY SMALL VALUE C 6 ANGLE=SQGEO*1.D-17 7 TEST=AARI*1.D-9 IF(DABS(AARI-GEO)-TEST)10,10,8 8 GEO=SQGEO+SQGEO PIM=PIM+PIM IF(ANGLE)9,5,5 9 PIM=PIM+3.1415926535897932 GOTO 5 10 IF(ANGLE)11,12,12 11 PIM=PIM+3.1415926535897932 12 RES=(DATAN(ARI/ANGLE)+PIM)/ARI 13 IF(X)14,15,15 14 RES=-RES 15 RETURN END C C .................................................................. C C SUBROUTINE DELI2 C C PURPOSE C COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND C C USAGE C CALL DELI2(R,X,CK,A,B) C C DESCRIPTION OF PARAMETERS C R - RESULT VALUE IN DOUBLE PRECISION C X - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC C INTEGRAL OF SECOND KIND) IN DOUBLE PRECISION C CK - COMPLEMENTARY MODULUS IN DOUBLE PRECISION C A - DOUBLE PRECISION CONSTANT TERM IN NUMERATOR C B - DOUBLE PRECISION QUATRATIC TERM IN NUMERATOR C C REMARKS C DOUBLE PRECISION MODULUS K = DSQRT(1.D0-CK*CK). C SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF C SECOND KIND ARE C F(DATAN(X),K) OBTAINED WITH A=1.D0, B=1.D0 C E(DATAN(X),K) OBTAINED WITH A=1.D0, B=CK*CK C B(DATAN(X),K) OBTAINED WITH A=1.D0, B=0.D0 C D(DATAN(X),K) OBTAINED WITH A=0.D0, B=1.D0. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)), C SUMMED OVER T FROM 0 TO X). C EQUIVALENT IS THE DEFINITION C R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2), C SUMMED OVER T FROM 0 TO ATAN(X)). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIONS C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE DELI2(R,X,CK,A,B) C DOUBLE PRECISION R,X,A,B,AN,AA,ANG,AANG,PIM,PIMA,ARI,AARI DOUBLE PRECISION GEO,SGEO,C,D,P,CK C C TEST ARGUMENT C IF(X)2,1,2 1 R=0.D0 RETURN C C TEST MODULUS C 2 C=0.D0 D=0.5D0 IF(CK)7,3,7 3 R=DSQRT(1.D0+X*X) R=(A-B)*DABS(X)/R+B*DLOG(DABS(X)+R) 4 R=R+C*(A-B) C C TEST SIGN OF ARGUMENT C IF(X)5,6,6 5 R=-R 6 RETURN C C INITIALIZATION C 7 AN=(B+A)*0.5D0 AA=A R=B ANG=DABS(1.D0/X) PIM=0.D0 ISI=0 ARI=1.D0 GEO=DABS(CK) C C LANDEN TRANSFORMATION C 8 R=AA*GEO+R SGEO=ARI*GEO AA=AN AARI=ARI C C ARITHMETIC MEAN C ARI=GEO+ARI C C SUM OF SINE VALUES C AN=(R/ARI+AA)*0.5D0 AANG=DABS(ANG) ANG=-SGEO/ANG+ANG PIMA=PIM IF(ANG)10,9,11 C C REPLACE 0 BY SMALL VALUE C 9 ANG=-1.D-17*AANG 10 PIM=PIM+3.1415926535897932 ISI=ISI+1 11 AANG=ARI*ARI+ANG*ANG P=D/DSQRT(AANG) IF(ISI-4)13,12,12 12 ISI=ISI-4 13 IF(ISI-2)15,14,14 14 P=-P 15 C=C+P D=D*(AARI-GEO)*0.5D0/ARI IF(DABS(AARI-GEO)-1.D-9*AARI)17,17,16 16 SGEO=DSQRT(SGEO) C C GEOMETRIC MEAN C GEO=SGEO+SGEO PIM=PIM+PIMA ISI=ISI+ISI GOTO 8 C C ACCURACY WAS SUFFICIENT C 17 R=(DATAN(ARI/ANG)+PIM)*AN/ARI C=C+D*ANG/AANG GOTO 4 END C C .................................................................. C C SUBROUTINE DET3 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF C FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY C SPACED ARGUMENT VALUES. C C USAGE C CALL DET3(H,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C H - CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT C VALUES (H IS POSITIVE IF THE ARGUMENT VALUES C INCREASE AND NEGATIVE OTHERWISE) C Y - GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM) C Z - RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION C NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C IER = 1 - H = 0 C C REMARKS C (1) IF IER = -1,1, THEN THERE IS NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE C DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC-GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP.82-84.) C C .................................................................. C SUBROUTINE DET3(H,Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-3)4,1,1 C C TEST OF STEPSIZE 1 IF(H)2,5,2 C C PREPARE DIFFERENTIATION LOOP 2 HH=.5/H YY=Y(NDIM-2) B=Y(2)+Y(2) B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1)) C C START DIFFERENTIATION LOOP DO 3 I=3,NDIM A=B B=HH*(Y(I)-Y(I-2)) 3 Z(I-2)=A C END OF DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 A=Y(NDIM-1)+Y(NDIM-1) Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY) Z(NDIM-1)=B RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 3 4 IER=-1 RETURN C C ERROR EXIT IN CASE OF ZERO STEPSIZE 5 IER=1 RETURN END C C .................................................................. C C SUBROUTINE DET5 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN A VECTOR OF C FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO EQUIDISTANTLY C SPACED ARGUMENT VALUES. C C USAGE C CALL DET5(H,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C H - CONSTANT DIFFERENCE BETWEEN SUCCESSIVE ARGUMENT C VALUES (H IS POSITIVE IF THE ARGUMENT VALUES C INCREASE AND NEGATIVE OTHERWISE) C Y - GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM) C Z - RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION C NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C IER = 1 - H = 0 C C REMARKS C (1) IF IER = -1,1, THEN THERE IS NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), Z(I) C IS THE DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 4 RELEVANT TO THE 5 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 82-84.) C C .................................................................. C SUBROUTINE DET5(H,Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-5)4,1,1 C C TEST OF STEPSIZE 1 IF(H)2,5,2 C C PREPARE DIFFERENTIATION LOOP 2 HH=.08333333/H YY=Y(NDIM-4) B=HH*(-25.*Y(1)+48.*Y(2)-36.*Y(3)+16.*Y(4)-3.*Y(5)) C=HH*(-3.*Y(1)-10.*Y(2)+18.*Y(3)-6.*Y(4)+Y(5)) C C START DIFFERENTIATION LOOP DO 3 I=5,NDIM A=B B=C C=HH*(Y(I-4)-Y(I)+8.*(Y(I-1)-Y(I-3))) 3 Z(I-4)=A C END OF DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 A=HH*(-YY+6.*Y(NDIM-3)-18.*Y(NDIM-2)+10.*Y(NDIM-1)+3.*Y(NDIM)) Z(NDIM)=HH*(3.*YY-16.*Y(NDIM-3)+36.*Y(NDIM-2)-48.*Y(NDIM-1) 1 +25.*Y(NDIM)) Z(NDIM-1)=A Z(NDIM-2)=C Z(NDIM-3)=B RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 4 IER=-1 RETURN C C ERROR EXIT IN CASE OF ZERO STEPSIZE 5 IER=1 RETURN END C C .................................................................. C C SUBROUTINE DFMCG C C PURPOSE C TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES C BY THE METHOD OF CONJUGATE GRADIENTS C C USAGE C CALL DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DESCRIPTION OF PARAMETERS C FUNCT - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO C BE MINIMIZED. IT MUST BE OF THE FORM C SUBROUTINE FUNCT(N,ARG,VAL,GRAD) C AND MUST SERVE THE FOLLOWING PURPOSE C FOR EACH N-DIMENSIONAL ARGUMENT VECTOR ARG, C FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED C AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY C ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION. C N - NUMBER OF VARIABLES C X - VECTOR OF DIMENSION N CONTAINING THE INITIAL C ARGUMENT WHERE THE ITERATION STARTS. ON RETURN, C X HOLDS THE ARGUMENT CORRESPONDING TO THE C COMPUTED MINIMUM FUNCTION VALUE C DOUBLE PRECISION VECTOR. C F - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION C VALUE ON RETURN, I.E. F=F(X). C DOUBLE PRECISION VARIABLE. C G - VECTOR OF DIMENSION N CONTAINING THE GRADIENT C VECTOR CORRESPONDING TO THE MINIMUM ON RETURN, C I.E. G=G(X). C DOUBLE PRECISION VECTOR. C EST - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE. C SINGLE PRECISION VARIABLE. C EPS - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR. C A REASONABLE CHOICE IS 10**(-16), I.E. C SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE C NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT C REPRESENTATION. C SINGLE PRECISION VARIABLE. C LIMIT - MAXIMUM NUMBER OF ITERATIONS. C IER - ERROR PARAMETER C IER = 0 MEANS CONVERGENCE WAS OBTAINED C IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS C IER =-1 MEANS ERRORS IN GRADIENT CALCULATION C IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES C IT IS LIKELY THAT THERE EXISTS NO MINIMUM. C H - WORKING STORAGE OF DIMENSION 2*N. C DOUBLE PRECISION ARRAY. C C REMARKS C I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT FUNCT C MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM. C II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED C DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN C A TOLERABLE RANGE OF ARGUMENT. C IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F C INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS C RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE C MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH C TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT C IS FOUND WHERE THE FUNCTION INCREASES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUNCT C C METHOD C THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE C R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY C CONJUGATE GRADIENTS, C COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154. C C .................................................................. C SUBROUTINE DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DIMENSIONED DUMMY VARIABLES DIMENSION X(1),G(1),H(1) DOUBLE PRECISION X,G,GNRM,H,HNRM,F,FX,FY,OLDF,OLDG,SNRM,AMBDA, 1ALFA,DALFA,T,Z,W,DX,DY C C COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT CALL FUNCT(N,X,F,G) C C RESET ITERATION COUNTER KOUNT=0 IER=0 N1=N+1 C C START ITERATION CYCLE FOR EVERY N+1 ITERATIONS 1 DO 43 II=1,N1 C C STEP ITERATION COUNTER AND SAVE FUNCTION VALUE KOUNT=KOUNT+1 OLDF=F C C COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO GNRM=0.D0 DO 2 J=1,N 2 GNRM=GNRM+G(J)*G(J) IF(GNRM)46,46,3 C C EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL C BE IN DIRECTION OF STEEPEST DESCENT 3 IF(II-1)4,4,6 4 DO 5 J=1,N 5 H(J)=-G(J) GO TO 8 C C FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING C TO THE CONJUGATE GRADIENT METHOD 6 AMBDA=GNRM/OLDG DO 7 J=1,N 7 H(J)=AMBDA*H(J)-G(J) C C COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL C DERIVATIVE 8 DY=0.D0 HNRM=0.D0 DO 9 J=1,N K=J+N C C SAVE ARGUMENT VECTOR H(K)=X(J) HNRM=HNRM+DABS(H(J)) 9 DY=DY+H(J)*G(J) C C CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND C SKIP LINEAR SEARCH ROUTINE IF NOT IF(DY)10,42,42 C C COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE 10 SNRM=1.D0/HNRM C C SEARCH MINIMUM ALONG DIRECTION H C C SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE FY=F ALFA=2.D0*(EST-F)/DY AMBDA=SNRM C C USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN C SNRM. OTHERWISE TAKE SNRM AS STEPSIZE. IF(ALFA)13,13,11 11 IF(ALFA-AMBDA)12,13,13 12 AMBDA=ALFA 13 ALFA=0.D0 C C SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT 14 FX=FY DX=DY C C STEP ARGUMENT ALONG H DO 15 I=1,N 15 X(I)=X(I)+AMBDA*H(I) C C COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT CALL FUNCT(N,X,F,G) FY=F C C COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT. TERMINATE C SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND DY=0.D0 DO 16 I=1,N 16 DY=DY+G(I)*H(I) IF(DY)17,38,20 C C TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT C A MINIMUM HAS BEEN PASSED 17 IF(FY-FX)18,20,20 C C REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES 18 AMBDA=AMBDA+ALFA ALFA=AMBDA C C TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE IF(HNRM*AMBDA-1.D10)14,14,19 C C LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS 19 IER=2 C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS F=OLDF DO 100 J=1,N G(J)=H(J) K=N+J 100 X(J)=H(K) RETURN C END OF SEARCH LOOP C C INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH C ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION C POLYNOMIAL IS MINIMIZED C 20 T=0. 21 IF(AMBDA)22,38,22 22 Z=3.D0*(FX-FY)/AMBDA+DX+DY ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)23,27,27 C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS 23 DO 24 J=1,N K=N+J 24 X(J)=H(K) CALL FUNCT(N,X,F,G) C C TEST FOR REPEATED FAILURE OF ITERATION 25 IF(IER)47,26,47 26 IER=-1 GOTO 1 27 W=ALFA*DSQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA)270,271,270 270 ALFA=(DY-Z+W)/ALFA GO TO 272 271 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 272 ALFA=ALFA*AMBDA DO 28 I=1,N 28 X(I)=X(I)+(T-ALFA)*H(I) C C TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS C THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE C THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT C THE INTERPOLATION. WHICH END-POINT IS CHOOSEN DEPENDS ON THE C VALUE OF THE FUNCTION AND ITS GRADIENT AT X C CALL FUNCT(N,X,F,G) IF(F-FX)29,29,30 29 IF(F-FY)38,38,30 C C COMPUTE DIRECTIONAL DERIVATIVE 30 DALFA=0.D0 DO 31 I=1,N 31 DALFA=DALFA+G(I)*H(I) IF(DALFA)32,35,35 32 IF(F-FX)34,33,35 33 IF(DX-DALFA)34,38,34 34 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 21 35 IF(FY-F)37,36,37 36 IF(DY-DALFA)37,38,37 37 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 20 C C TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION C OTHERWISE SAVE GRADIENT NORM 38 IF(OLDF-F+EPS)19,25,39 39 OLDG=GNRM C C COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR T=0.D0 DO 40 J=1,N K=J+N H(K)=X(J)-H(K) 40 T=T+DABS(H(K)) C C TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS C HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS IF(KOUNT-N1)42,41,41 41 IF(T-EPS)45,45,42 C C TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED LIMIT 42 IF(KOUNT-LIMIT)43,44,44 43 IER=0 C END OF ITERATION CYCLE C C START NEXT ITERATION CYCLE GO TO 1 C C NO CONVERGENCE AFTER LIMIT ITERATIONS 44 IER=1 IF(GNRM-EPS)46,46,47 C C TEST FOR SUFFICIENTLY SMALL GRADIENT 45 IF(GNRM-EPS)46,46,25 46 IER=0 47 RETURN END C C .................................................................. C C SUBROUTINE DFMFP C C PURPOSE C TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES C BY THE METHOD OF FLETCHER AND POWELL C C USAGE C CALL DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DESCRIPTION OF PARAMETERS C FUNCT - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO C BE MINIMIZED. IT MUST BE OF THE FORM C SUBROUTINE FUNCT(N,ARG,VAL,GRAD) C AND MUST SERVE THE FOLLOWING PURPOSE C FOR EACH N-DIMENSIONAL ARGUMENT VECTOR ARG, C FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED C AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY C ARG,VAL AND GRAD MUST BE OF DOUBLE PRECISION. C N - NUMBER OF VARIABLES C X - VECTOR OF DIMENSION N CONTAINING THE INITIAL C ARGUMENT WHERE THE ITERATION STARTS. ON RETURN, C X HOLDS THE ARGUMENT CORRESPONDING TO THE C COMPUTED MINIMUM FUNCTION VALUE C DOUBLE PRECISION VECTOR. C F - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION C VALUE ON RETURN, I.E. F=F(X). C DOUBLE PRECISION VARIABLE. C G - VECTOR OF DIMENSION N CONTAINING THE GRADIENT C VECTOR CORRESPONDING TO THE MINIMUM ON RETURN, C I.E. G=G(X). C DOUBLE PRECISION VECTOR. C EST - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE. C SINGLE PRECISION VARIABLE. C EPS - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR. C A REASONABLE CHOICE IS 10**(-16), I.E. C SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE C NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT C REPRESENTATION. C SINGLE PRECISION VARIABLE. C LIMIT - MAXIMUM NUMBER OF ITERATIONS. C IER - ERROR PARAMETER C IER = 0 MEANS CONVERGENCE WAS OBTAINED C IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS C IER =-1 MEANS ERRORS IN GRADIENT CALCULATION C IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES C IT IS LIKELY THAT THERE EXISTS NO MINIMUM. C H - WORKING STORAGE OF DIMENSION N*(N+7)/2. C DOUBLE PRECISION ARRAY. C C REMARKS C I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT FUNCT C MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM. C II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED C DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN C A TOLERABLE RANGE OF ARGUMENT. C IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F C INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS C RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE C MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH C TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT C IS FOUND WHERE THE FUNCTION INCREASES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUNCT C C METHOD C THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE C R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR C MINIMIZATION, C COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168. C C .................................................................. C SUBROUTINE DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DIMENSIONED DUMMY VARIABLES DIMENSION H(1),X(1),G(1) DOUBLE PRECISION X,F,FX,FY,OLDF,HNRM,GNRM,H,G,DX,DY,ALFA,DALFA, 1AMBDA,T,Z,W C C COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT CALL FUNCT(N,X,F,G) C C RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX IER=0 KOUNT=0 N2=N+N N3=N2+N N31=N3+1 1 K=N31 DO 4 J=1,N H(K)=1.D0 NJ=N-J IF(NJ)5,5,2 2 DO 3 L=1,NJ KL=K+L 3 H(KL)=0.D0 4 K=KL+1 C C START ITERATION LOOP 5 KOUNT=KOUNT +1 C C SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR OLDF=F DO 9 J=1,N K=N+J H(K)=G(J) K=K+N H(K)=X(J) C C DETERMINE DIRECTION VECTOR H K=J+N3 T=0.D0 DO 8 L=1,N T=T-G(L)*H(K) IF(L-J)6,7,7 6 K=K+N-L GO TO 8 7 K=K+1 8 CONTINUE 9 H(J)=T C C CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H. DY=0.D0 HNRM=0.D0 GNRM=0.D0 C C CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION C VECTOR H AND GRADIENT VECTOR G. DO 10 J=1,N HNRM=HNRM+DABS(H(J)) GNRM=GNRM+DABS(G(J)) 10 DY=DY+H(J)*G(J) C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL C DERIVATIVE APPEARS TO BE POSITIVE OR ZERO. IF(DY)11,51,51 C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION C VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G. 11 IF(HNRM/GNRM-EPS)51,51,12 C C SEARCH MINIMUM ALONG DIRECTION H C C SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE 12 FY=F ALFA=2.D0*(EST-F)/DY AMBDA=1.D0 C C USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN C 1. OTHERWISE TAKE 1. AS STEPSIZE IF(ALFA)15,15,13 13 IF(ALFA-AMBDA)14,15,15 14 AMBDA=ALFA 15 ALFA=0.D0 C C SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT 16 FX=FY DX=DY C C STEP ARGUMENT ALONG H DO 17 I=1,N 17 X(I)=X(I)+AMBDA*H(I) C C COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT CALL FUNCT(N,X,F,G) FY=F C C COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT. TERMINATE C SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND DY=0.D0 DO 18 I=1,N 18 DY=DY+G(I)*H(I) IF(DY)19,36,22 C C TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT C A MINIMUM HAS BEEN PASSED 19 IF(FY-FX)20,22,22 C C REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES 20 AMBDA=AMBDA+ALFA ALFA=AMBDA C END OF SEARCH LOOP C C TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE IF(HNRM*AMBDA-1.D10)16,16,21 C C LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS 21 IER=2 RETURN C C INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH C ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION C POLYNOMIAL IS MINIMIZED 22 T=0.D0 23 IF(AMBDA)24,36,24 24 Z=3.D0*(FX-FY)/AMBDA+DX+DY ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)51,25,25 25 W=ALFA*DSQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA) 250,251,250 250 ALFA=(DY-Z+W)/ALFA GO TO 252 251 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 252 ALFA=ALFA*AMBDA DO 26 I=1,N 26 X(I)=X(I)+(T-ALFA)*H(I) C C TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS C THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE C THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT C THE INTERPOLATION. WHICH END-POINT IS CHOOSEN DEPENDS ON THE C VALUE OF THE FUNCTION AND ITS GRADIENT AT X C CALL FUNCT(N,X,F,G) IF(F-FX)27,27,28 27 IF(F-FY)36,36,28 28 DALFA=0.D0 DO 29 I=1,N 29 DALFA=DALFA+G(I)*H(I) IF(DALFA)30,33,33 30 IF(F-FX)32,31,33 31 IF(DX-DALFA)32,36,32 32 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 23 33 IF(FY-F)35,34,35 34 IF(DY-DALFA)35,36,35 35 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 22 C C TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION 36 IF(OLDF-F+EPS)51,38,38 C C COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM C TWO CONSECUTIVE ITERATIONS 38 DO 37 J=1,N K=N+J H(K)=G(J)-H(K) K=N+K 37 H(K)=X(J)-H(K) C C TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR C IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF C BOTH ARE LESS THAN EPS IER=0 IF(KOUNT-N)42,39,39 39 T=0.D0 Z=0.D0 DO 40 J=1,N K=N+J W=H(K) K=K+N T=T+DABS(H(K)) 40 Z=Z+W*H(K) IF(HNRM-EPS)41,41,42 41 IF(T-EPS)56,56,42 C C TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED LIMIT 42 IF(KOUNT-LIMIT)43,50,50 C C PREPARE UPDATING OF MATRIX H 43 ALFA=0.D0 DO 47 J=1,N K=J+N3 W=0.D0 DO 46 L=1,N KL=N+L W=W+H(KL)*H(K) IF(L-J)44,45,45 44 K=K+N-L GO TO 46 45 K=K+1 46 CONTINUE K=N+J ALFA=ALFA+W*H(K) 47 H(J)=W C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS C ARE NOT SATISFACTORY IF(Z*ALFA)48,1,48 C C UPDATE MATRIX H 48 K=N31 DO 49 L=1,N KL=N2+L DO 49 J=L,N NJ=N2+J H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA 49 K=K+1 GO TO 5 C END OF ITERATION LOOP C C NO CONVERGENCE AFTER LIMIT ITERATIONS 50 IER=1 RETURN C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS 51 DO 52 J=1,N K=N2+J 52 X(J)=H(K) CALL FUNCT(N,X,F,G) C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE C FAILS TO BE SUFFICIENTLY SMALL IF(GNRM-EPS)55,55,53 C C TEST FOR REPEATED FAILURE OF ITERATION 53 IF(IER)56,54,54 54 IER=-1 GOTO 1 55 IER=0 56 RETURN END C C .................................................................. C C SUBROUTINE DFRAT C C PURPOSE C DFRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS C WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF C RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY C C USAGE C CALL DFRAT(I,N,M,P,DATI,WGT,IER) C C DESCRIPTION OF PARAMETERS C I - SUBSCRIPT OF CURRENT DATA POINT C N - NUMBER OF ALL DATA POINTS C M - NUMBER OF FUNDAMENTAL FUNCTIONS USED C P - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS C ON RETURN THE VALUES OF THE M FUNDAMENTAL C FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE C P MUST BE OF DOUBLE PRECISION C DATI - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED C BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY C N WEIGHT VALUES C DATI MUST BE OF DOUBLE PRECISION C WGT - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM C WGT MUST BE OF DOUBLE PRECISION C IER - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT C VALUES FOR CONTROL C IER(2) MEANS DIMENSION OF NUMERATOR C IER(3) MEANS DIMENSION OF DENOMINATOR C IER(1) IS USED AS RESULTANT ERROR PARAMETER, C IER(1) = 0 IN CASE OF NO ERRORS C IER(1) = 1 OTHERWISE (ZERO DENOMINATOR) C C REMARKS C VECTOR IER IS USED FOR COMMUNICATION BETWEEN DARAT AND DFRAT C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DCNP C C METHOD C CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT C C .................................................................. C SUBROUTINE DFRAT(I,N,M,P,DATI,WGT,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION P(1),DATI(1),IER(1) DOUBLE PRECISION P,DATI,WGT,T,F,FNUM,FDEN C C INITIALIZATION IP=IER(2) IQ=IER(3) IQM1=IQ-1 IPQ=IP+IQ C C LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT C LOOK UP NUMERATOR AND DENOMINATOR T=DATI(I) J=I+N F=DATI(J) FNUM=P(J) J=J+N WGT=1.D0 IF(DATI(2*N+1))2,2,1 1 WGT=DATI(J) 2 FDEN=P(J) C C CALCULATE FUNCTION VALUE USED F=F*FDEN-FNUM C C CHECK FOR ZERO DENOMINATOR IF(FDEN)4,3,4 C C ERROR RETURN IN CASE OF ZERO DENOMINATOR 3 IER(1)=1 RETURN C C CALCULATE WEIGHT FACTORS USED 4 WGT=WGT/(FDEN*FDEN) FNUM=-FNUM/FDEN C C CALCULATE FUNDAMENTAL FUNCTIONS J=IQM1 IF(IP-IQ)6,6,5 5 J=IP-1 6 CALL DCNP(P(IQ),T,J) C C STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS 7 IF(IQM1)10,10,8 8 DO 9 II=1,IQM1 J=II+IQ 9 P(II)=P(J)*FNUM C C STORE FUNCTION VALUE 10 P(IPQ)=F C C NORMAL RETURN IER(1)=0 RETURN END C C .................................................................. C C SUBROUTINE DGELB C C PURPOSE C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A C COEFFICIENT MATRIX OF BAND STRUCTURE. C C USAGE C CALL DGELB(R,A,M,N,MUD,MLD,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX C (DESTROYED). ON RETURN R CONTAINS THE SOLUTION C OF THE EQUATIONS. C A - DOUBLE PRECISION M BY M COEFFICIENT MATRIX WITH C BAND STRUCTURE (DESTROYED). C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C MUD - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS C CODIAGONALS ABOVE MAIN DIAGONAL). C MLD - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS C CODIAGONALS BELOW MAIN DIAGONAL). C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C RELATIVE TOLERANCE FOR TEST ON LOSS OF C SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT C AT ANY ELIMINATION STEP EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST ELEMENT OF MATRIX A. C C REMARKS C BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST C ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA C STORAGE LOCATIONS, WHERE C MA=M*MC-ML*(ML+1)/2 AND ME=MA-MU*(MU+1)/2 WITH C MC=MIN(M,1+MUD+MLD), ML=MC-1-MLD, MU=MC-1-MUD. C RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE C IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION C MATRIX R IS STORED COLUMNWISE TOO. C INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING C RESTRICTIONS MUD NOT LESS THAN ZERO C MLD NOT LESS THAN ZERO C MUD+MLD NOT GREATER THAN 2*M-2. C NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE C RESTRICTIONS ARE NOT SATISFIED. C THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT C PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL C ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING C IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE. C IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE C EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K. C NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH C COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE C IN REMAINING COEFFICIENT MATRICES. C C .................................................................. C SUBROUTINE DGELB(R,A,M,N,MUD,MLD,EPS,IER) C C DIMENSION R(1),A(1) DOUBLE PRECISION R,A,PIV,TB,TOL C C TEST ON WRONG INPUT PARAMETERS IF(MLD)47,1,1 1 IF(MUD)47,2,2 2 MC=1+MLD+MUD IF(MC+1-M-M)3,3,47 C C PREPARE INTEGER PARAMETERS C MC=NUMBER OF COLUMNS IN MATRIX A C MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A C ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A C MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS C MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A C MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A C NM=NUMBER OF ELEMENTS IN MATRIX R 3 IF(MC-M)5,5,4 4 MC=M 5 MU=MC-MUD-1 ML=MC-MLD-1 MR=M-ML MZ=(MU*(MU+1))/2 MA=M*MC-(ML*(ML+1))/2 NM=N*M C C MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT C (NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS) IER=0 PIV=0.D0 IF(MLD)14,14,6 6 JJ=MA J=MA-MZ KST=J DO 9 K=1,KST TB=A(J) A(JJ)=TB TB=DABS(TB) IF(TB-PIV)8,8,7 7 PIV=TB 8 J=J-1 9 JJ=JJ-1 C C INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0) IF(MZ)14,14,10 10 JJ=1 J=1+MZ IC=1+MUD DO 13 I=1,MU DO 12 K=1,MC A(JJ)=0.D0 IF(K-IC)11,11,12 11 A(JJ)=A(J) J=J+1 12 JJ=JJ+1 13 IC=IC+1 C C GENERATE TEST VALUE FOR SINGULARITY 14 TOL=EPS*PIV C C C START DECOMPOSITION LOOP KST=1 IDST=MC IC=MC-1 DO 38 K=1,M IF(K-MR-1)16,16,15 15 IDST=IDST-1 16 ID=IDST ILR=K+MLD IF(ILR-M)18,18,17 17 ILR=M 18 II=KST C C PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR) PIV=0.D0 DO 22 I=K,ILR TB=DABS(A(II)) IF(TB-PIV)20,20,19 19 PIV=TB J=I JJ=II 20 IF(I-MR)22,22,21 21 ID=ID-1 22 II=II+ID C C TEST ON SINGULARITY IF(PIV)47,47,23 23 IF(IER)26,24,26 24 IF(PIV-TOL)25,25,26 25 IER=K-1 26 PIV=1.D0/A(JJ) C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R ID=J-K DO 27 I=K,NM,M II=I+ID TB=PIV*R(II) R(II)=R(I) 27 R(I)=TB C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A II=KST J=JJ+IC DO 28 I=JJ,J TB=PIV*A(I) A(I)=A(II) A(II)=TB 28 II=II+1 C C ELEMENT REDUCTION IF(K-ILR)29,34,34 29 ID=KST II=K+1 MU=KST+1 MZ=KST+IC DO 33 I=II,ILR C C IN MATRIX A ID=ID+MC JJ=I-MR-1 IF(JJ)31,31,30 30 ID=ID-JJ 31 PIV=-A(ID) J=ID+1 DO 32 JJ=MU,MZ A(J-1)=A(J)+PIV*A(JJ) 32 J=J+1 A(J-1)=0.D0 C C IN MATRIX R J=K DO 33 JJ=I,NM,M R(JJ)=R(JJ)+PIV*R(J) 33 J=J+M 34 KST=KST+MC IF(ILR-MR)36,35,35 35 IC=IC-1 36 ID=K-MR IF(ID)38,38,37 37 KST=KST-ID 38 CONTINUE C END OF DECOMPOSITION LOOP C C C BACK SUBSTITUTION IF(MC-1)46,46,39 39 IC=2 KST=MA+ML-MC+2 II=M DO 45 I=2,M KST=KST-MC II=II-1 J=II-MR IF(J)41,41,40 40 KST=KST+J 41 DO 43 J=II,NM,M TB=R(J) MZ=KST+IC-2 ID=J DO 42 JJ=KST,MZ ID=ID+1 42 TB=TB-A(JJ)*R(ID) 43 R(J)=TB IF(IC-MC)44,45,45 44 IC=IC+1 45 CONTINUE 46 RETURN C C C ERROR RETURN 47 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DGELG C C PURPOSE C TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS. C C USAGE C CALL DGELG(R,A,M,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX C (DESTROYED). ON RETURN R CONTAINS THE SOLUTIONS C OF THE EQUATIONS. C A - DOUBLE PRECISION M BY M COEFFICIENT MATRIX C (DESTROYED). C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C RELATIVE TOLERANCE FOR TEST ON LOSS OF C SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR C PIVOT ELEMENT AT ANY ELIMINATION STEP C EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST ELEMENT OF MATRIX A. C C REMARKS C INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE C IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN C SOLUTION MATRIX R IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS C GIVEN IN CASE M=1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH C COMPLETE PIVOTING. C C .................................................................. C SUBROUTINE DGELG(R,A,M,N,EPS,IER) C C DIMENSION A(1),R(1) DOUBLE PRECISION R,A,PIV,TB,TOL,PIVI IF(M)23,23,1 C C SEARCH FOR GREATEST ELEMENT IN MATRIX A 1 IER=0 PIV=0.D0 MM=M*M NM=N*M DO 3 L=1,MM TB=DABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L 3 CONTINUE TOL=EPS*PIV C A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I). C C C START ELIMINATION LOOP LST=1 DO 17 K=1,M C C TEST ON SINGULARITY IF(PIV)23,23,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 PIVI=1.D0/A(I) J=(I-1)/M I=I-J*M-K J=J+1-K C I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R DO 8 L=K,NM,M LL=L+I TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB C C IS ELIMINATION TERMINATED IF(K-M)9,18,18 C C COLUMN INTERCHANGE IN MATRIX A 9 LEND=LST+M-K IF(J)12,12,10 10 II=J*M DO 11 L=LST,LEND TB=A(L) LL=L+II A(L)=A(LL) 11 A(LL)=TB C C ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A 12 DO 13 L=LST,MM,M LL=L+I TB=PIVI*A(LL) A(LL)=A(L) 13 A(L)=TB C C SAVE COLUMN INTERCHANGE INFORMATION A(LST)=J C C ELEMENT REDUCTION AND NEXT PIVOT SEARCH PIV=0.D0 LST=LST+1 J=0 DO 16 II=LST,LEND PIVI=-A(II) IST=II+M J=J+1 DO 15 L=IST,MM,M LL=L-J A(L)=A(L)+PIVI*A(LL) TB=DABS(A(L)) IF(TB-PIV)15,15,14 14 PIV=TB I=L 15 CONTINUE DO 16 L=K,NM,M LL=L+J 16 R(LL)=R(LL)+PIVI*R(L) 17 LST=LST+M C END OF ELIMINATION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE 18 IF(M-1)23,22,19 19 IST=MM+M LST=M+1 DO 21 I=2,M II=LST-I IST=IST-LST L=IST-M L=A(L)+.5D0 DO 21 J=II,NM,M TB=R(J) LL=J DO 20 K=IST,MM,M LL=LL+1 20 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 21 R(K)=TB 22 RETURN C C C ERROR RETURN 23 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DGELS C C PURPOSE C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH C IS ASSUMED TO BE STORED COLUMNWISE. C C USAGE C CALL DGELS(R,A,M,N,EPS,IER,AUX) C C DESCRIPTION OF PARAMETERS C R - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX C (DESTROYED). ON RETURN R CONTAINS THE SOLUTION OF C THE EQUATIONS. C A - UPPER TRIANGULAR PART OF THE SYMMETRIC DOUBLE C PRECISION M BY M COEFFICIENT MATRIX. (DESTROYED) C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS C RELATIVE TOLERANCE FOR TEST ON LOSS OF C SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR C PIVOT ELEMENT AT ANY ELIMINATION STEP C EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST MAIN DIAGONAL C ELEMENT OF MATRIX A. C AUX - DOUBLE PRECISION AUXILIARY STORAGE ARRAY C WITH DIMENSION M-1. C C REMARKS C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE C TOO. C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS C GIVEN IN CASE M=1. C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE DGELG (WHICH C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE C SYMMETRY IN REMAINING COEFFICIENT MATRICES. C C .................................................................. C SUBROUTINE DGELS(R,A,M,N,EPS,IER,AUX) C C DIMENSION A(1),R(1),AUX(1) DOUBLE PRECISION R,A,AUX,PIV,TB,TOL,PIVI IF(M)24,24,1 C C SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT 1 IER=0 PIV=0.D0 L=0 DO 3 K=1,M L=L+K TB=DABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L J=K 3 CONTINUE TOL=EPS*PIV C MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT. C PIV CONTAINS THE ABSOLUTE VALUE OF A(I). C C C START ELIMINATION LOOP LST=0 NM=N*M LEND=M-1 DO 18 K=1,M C C TEST ON USEFULNESS OF SYMMETRIC ALGORITHM IF(PIV)24,24,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 LT=J-K LST=LST+K C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R PIVI=1.D0/A(I) DO 8 L=K,NM,M LL=L+LT TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB C C IS ELIMINATION TERMINATED IF(K-M)9,19,19 C C ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A. C ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX. 9 LR=LST+(LT*(K+J-1))/2 LL=LR L=LST DO 14 II=K,LEND L=L+II LL=LL+1 IF(L-LR)12,10,11 10 A(LL)=A(LST) TB=A(L) GO TO 13 11 LL=L+LT 12 TB=A(LL) A(LL)=A(L) 13 AUX(II)=TB 14 A(L)=PIVI*TB C C SAVE COLUMN INTERCHANGE INFORMATION A(LST)=LT C C ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT PIV=0.D0 LLST=LST LT=0 DO 18 II=K,LEND PIVI=-AUX(II) LL=LLST LT=LT+1 DO 15 LLD=II,LEND LL=LL+LLD L=LL+LT 15 A(L)=A(L)+PIVI*A(LL) LLST=LLST+II LR=LLST+LT TB=DABS(A(LR)) IF(TB-PIV)17,17,16 16 PIV=TB I=LR J=II+1 17 DO 18 LR=K,NM,M LL=LR+LT 18 R(LL)=R(LL)+PIVI*R(LR) C END OF ELIMINATION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE 19 IF(LEND)24,23,20 20 II=M DO 22 I=2,M LST=LST-II II=II-1 L=A(LST)+.5D0 DO 22 J=II,NM,M TB=R(J) LL=J K=LST DO 21 LT=II,LEND LL=LL+1 K=K+LT 21 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 22 R(K)=TB 23 RETURN C C C ERROR RETURN 24 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DGT3 C C PURPOSE C TO COMPUTE A VECTOR OF DERIVATIVE VALUES GIVEN VECTORS OF C ARGUMENT VALUES AND CORRESPONDING FUNCTION VALUES. C C USAGE C CALL DGT3(X,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C X - GIVEN VECTOR OF ARGUMENT VALUES (DIMENSION NDIM) C Y - GIVEN VECTOR OF FUNCTION VALUES CORRESPONDING TO X C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DERIVATIVE VALUES (DIMENSION C NDIM) C NDIM - DIMENSION OF VECTORS X,Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C IER POSITIVE - X(IER) = X(IER-1) OR X(IER) = C X(IER-2) C C REMARKS C (1) IF IER = -1,2,3, THEN THERE IS NO COMPUTATION. C (2) IF IER = 4,...,N, THEN THE DERIVATIVE VALUES Z(1) C ,..., Z(IER-1) HAVE BEEN COMPUTED. C (3) Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y. IF C X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), Z(I) IS THE C DERIVATIVE AT X(I) OF THE LAGRANGIAN INTERPOLATION C POLYNOMIAL OF DEGREE 2 RELEVANT TO THE 3 SUCCESSIVE POINTS C (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 64-68.) C C .................................................................. C SUBROUTINE DGT3(X,Y,Z,NDIM,IER) C C DIMENSION X(1),Y(1),Z(1) C C TEST OF DIMENSION AND ERROR EXIT IN CASE NDIM IS LESS THAN 3 IER=-1 IF(NDIM-3)8,1,1 C C PREPARE DIFFERENTIATION LOOP 1 A=X(1) B=Y(1) I=2 DY2=X(2)-A IF(DY2)2,9,2 2 DY2=(Y(2)-B)/DY2 C C START DIFFERENTIATION LOOP DO 6 I=3,NDIM A=X(I)-A IF(A)3,9,3 3 A=(Y(I)-B)/A B=X(I)-X(I-1) IF(B)4,9,4 4 DY1=DY2 DY2=(Y(I)-Y(I-1))/B DY3=A A=X(I-1) B=Y(I-1) IF(I-3)5,5,6 5 Z(1)=DY1+DY3-DY2 6 Z(I-1)=DY1+DY2-DY3 C END DIFFERENTIATION LOOP C C NORMAL EXIT IER=0 I=NDIM 7 Z(I)=DY2+DY3-DY1 8 RETURN C C ERROR EXIT IN CASE OF IDENTICAL ARGUMENTS 9 IER=I I=I-1 IF(I-2)8,8,7 END C C .................................................................. C C SUBROUTINE DHARM C C PURPOSE C PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX C DOUBLE PRECISION,THREE DIMENSIONAL ARRAY C C USAGE C CALL DHARM(A,M,INV,S,IFSET,IFERR) C C DESCRIPTION OF PARAMETERS C A - A DOUBLE PRECISION VECTOR C AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL C ARRAY TO BE TRANSFORMED. THE REAL PART OF C A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL C WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE C NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC. C THE IMAGINARY PART IS IN THE CELL IMMEDIATELY C FOLLOWING. NOTE THAT THE SUBSCRIPT I1 INCREASES C MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY. C AS OUTPUT, A CONTAINS THE COMPLEX FOURIER C TRANSFORM. THE NUMBER OF CORE LOCATIONS OF C ARRAY A IS 2*(N1*N2*N3) C M - A THREE CELL VECTOR WHICH DETERMINES THE SIZES C OF THE 3 DIMENSIONS OF THE ARRAY A. THE SIZE, C NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3 C INV - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION C OF DIMENSION ONE FOURTH OF THE QUANTITY C MAX(N1,N2,N3) C LOCATIONS OF A, VIZ., (1/8)*2*N1*N2*N3 C S - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES C WITH DIMENSION THE SAME AS INV C IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS C 0 SET UP SINE AND INV TABLES ONLY C 1 SET UP SINE AND INV TABLES ONLY AND C CALCULATE FOURIER TRANSFORM C -1 SET UP SINE AND INV TABLES ONLY AND C CALCULATE INVERSE FOURIER TRANSFORM (FOR C THE MEANING OF INVERSE SEE THE EQUATIONS C UNDER METHOD BELOW) C 2 CALCULATE FOURIER TRANSFORM ONLY (ASSUME C SINE AND INV TABLES EXIST) C -2 CALCULATE INVERSE FOURIER TRANSFORM ONLY C (ASSUME SINE AND INV TABLES EXIST) C IFERR - ERROR INDICATOR. WHEN IFSET IS 0,+1,-1, C IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN C 20, I=1,2,3 WHEN IFSET IS 2,-2 , IFERR = 1 C MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE C ENOUGH OR HAVE NOT BEEN COMPUTED . C IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE C CONDITIONS ARE PRESENT C C REMARKS C THIS SUBROUTINE IS TO BE USED FOR COMPLEX, DOUBLE PRECISION, C 3-DIMENSIONAL ARRAYS IN WHICH EACH DIMENSION IS A POWER OF C 2. THE MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN C 20, I = 1,2,3. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX C ARRAY A IS OBTAINED. C C N1-1 N2-1 N3-1 L1 L2 L3 C X(J1,J2,J3)=SUM SUM SUM A(K1,K2,K3)*W1 *W2 *W3 C K1=0 K2=0 K3=0 C C WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1, C L2=K2*J2, L3=K3*J3 C C C FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF C COMPLEX ARRAY X IS OBTAINED. C C A(K1,K2,K3)= C 1 N1-1 N2-1 N3-1 -L1 -L2 -L3 C -------- *SUM SUM SUM X(J1,J2,J3)*W1 *W2 *W3 C N1*N2*N3 J1=0 J2=0 J3=0 C C C SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE C MACHINE CALCULATION OF COMPLEX FOURIER SERIES', C MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297. C C .................................................................. C SUBROUTINE DHARM(A,M,INV,S,IFSET,IFERR) DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2) DOUBLE PRECISION A,R,W3,AWI,THETA,ROOT2,S,T,W,W2,FN,AWR EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3) 10 IF( IABS(IFSET) - 1) 900,900,12 12 MTT=MAX0(M(1),M(2),M(3)) -2 ROOT2=DSQRT(2.0D0) IF (MTT-MT ) 14,14,13 13 IFERR=1 RETURN 14 IFERR=0 M1=M(1) M2=M(2) M3=M(3) N1=2**M1 N2=2**M2 N3=2**M3 16 IF(IFSET) 18,18,20 18 NX= N1*N2*N3 FN = NX DO 19 I = 1,NX A(2*I-1) = A(2*I-1)/FN 19 A(2*I) = -A(2*I)/FN 20 NP(1)=N1*2 NP(2)= NP(1)*N2 NP(3)=NP(2)*N3 DO 250 ID=1,3 IL = NP(3)-NP(ID) IL1 = IL+1 MI = M(ID) IF (MI)250,250,30 30 IDIF=NP(ID) KBIT=NP(ID) MEV = 2*(MI/2) IF (MI - MEV )60,60,40 C C M IS ODD. DO L=1 CASE 40 KBIT=KBIT/2 KL=KBIT-2 DO 50 I=1,IL1,IDIF KLAST=KL+I DO 50 K=I,KLAST,2 KD=K+KBIT C C DO ONE STEP WITH L=1,J=0 C A(K)=A(K)+A(KD) C A(KD)=A(K)-A(KD) C T=A(KD) A(KD)=A(K)-T A(K)=A(K)+T T=A(KD+1) A(KD+1)=A(K+1)-T 50 A(K+1)=A(K+1)+T IF (MI - 1)250,250,52 52 LFIRST =3 C C DEF - JLAST = 2**(L-2) -1 JLAST=1 GO TO 70 C C M IS EVEN 60 LFIRST = 2 JLAST=0 70 DO 240 L=LFIRST,MI,2 JJDIF=KBIT KBIT=KBIT/4 KL=KBIT-2 C C DO FOR J=0 DO 80 I=1,IL1,IDIF KLAST=I+KL DO 80 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT C C DO TWO STEPS WITH J=0 C A(K)=A(K)+A(K2) C A(K2)=A(K)-A(K2) C A(K1)=A(K1)+A(K3) C A(K3)=A(K1)-A(K3) C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C T=A(K2) A(K2)=A(K)-T A(K)=A(K)+T T=A(K2+1) A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C T=A(K3) A(K3)=A(K1)-T A(K1)=A(K1)+T T=A(K3+1) A(K3+1)=A(K1+1)-T A(K1+1)=A(K1+1)+T C T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T C R=-A(K3+1) T = A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 80 A(K2+1)=A(K2+1)+T IF (JLAST) 235,235,82 82 JJ=JJDIF +1 C C DO FOR J=1 ILAST= IL +JJ DO 85 I = JJ,ILAST,IDIF KLAST = KL+I DO 85 K=I,KLAST,2 K1 = K+KBIT K2 = K1+KBIT K3 = K2+KBIT C C LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I, C A(K)=A(K)+A(K2)*I C A(K2)=A(K)-A(K2)*I C A(K1)=A(K1)*W+A(K3)*W3 C A(K3)=A(K1)*W-A(K3)*W3 C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C R =-A(K2+1) T = A(K2) A(K2) = A(K)-R A(K) = A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C AWR=A(K1)-A(K1+1) AWI = A(K1+1)+A(K1) R=-A(K3)-A(K3+1) T=A(K3)-A(K3+1) A(K3)=(AWR-R)/ROOT2 A(K3+1)=(AWI-T)/ROOT2 A(K1)=(AWR+R)/ROOT2 A(K1+1)=(AWI+T)/ROOT2 T= A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 85 A(K2+1)=A(K2+1)+T IF(JLAST-1) 235,235,90 90 JJ= JJ + JJDIF C C NOW DO THE REMAINING J'S DO 230 J=2,JLAST C C FETCH W'S C DEF- W=W**INV(J), W2=W**2, W3=W**3 96 I=INV(J+1) 98 IC=NT-I W(1)=S(IC) W(2)=S(I) I2=2*I I2C=NT-I2 IF(I2C)120,110,100 C C 2*I IS IN FIRST QUADRANT 100 W2(1)=S(I2C) W2(2)=S(I2) GO TO 130 110 W2(1)=0. W2(2)=1. GO TO 130 C C 2*I IS IN SECOND QUADRANT 120 I2CC = I2C+NT I2C=-I2C W2(1)=-S(I2C) W2(2)=S(I2CC) 130 I3=I+I2 I3C=NT-I3 IF(I3C)160,150,140 C C I3 IN FIRST QUADRANT 140 W3(1)=S(I3C) W3(2)=S(I3) GO TO 200 150 W3(1)=0. W3(2)=1. GO TO 200 C 160 I3CC=I3C+NT IF(I3CC)190,180,170 C C I3 IN SECOND QUADRANT 170 I3C=-I3C W3(1)=-S(I3C) W3(2)=S(I3CC) GO TO 200 180 W3(1)=-1. W3(2)=0. GO TO 200 C C 3*I IN THIRD QUADRANT 190 I3CCC=NT+I3CC I3CC = -I3CC W3(1)=-S(I3CCC) W3(2)=-S(I3CC) 200 ILAST=IL+JJ DO 220 I=JJ,ILAST,IDIF KLAST=KL+I DO 220 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT C C DO TWO STEPS WITH J NOT 0 C A(K)=A(K)+A(K2)*W2 C A(K2)=A(K)-A(K2)*W2 C A(K1)=A(K1)*W+A(K3)*W3 C A(K3)=A(K1)*W-A(K3)*W3 C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C R=A(K2)*W2(1)-A(K2+1)*W2(2) T=A(K2)*W2(2)+A(K2+1)*W2(1) A(K2)=A(K)-R A(K)=A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C R=A(K3)*W3(1)-A(K3+1)*W3(2) T=A(K3)*W3(2)+A(K3+1)*W3(1) AWR=A(K1)*W(1)-A(K1+1)*W(2) AWI=A(K1)*W(2)+A(K1+1)*W(1) A(K3)=AWR-R A(K3+1)=AWI-T A(K1)=AWR+R A(K1+1)=AWI+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 220 A(K2+1)=A(K2+1)+T C END OF I AND K LOOPS C 230 JJ=JJDIF+JJ C END OF J-LOOP C 235 JLAST=4*JLAST+3 240 CONTINUE C END OF L LOOP C 250 CONTINUE C END OF ID LOOP C C WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE C BIT-REVERSED. THE FOLLOWING ROUTINE PUTS THEM IN ORDER NTSQ=NT*NT M3MT=M3-MT 350 IF(M3MT) 370,360,360 C C M3 GR. OR EQ. MT 360 IGO3=1 N3VNT=N3/NT MINN3=NT GO TO 380 C C M3 LESS THAN MT 370 IGO3=2 N3VNT=1 NTVN3=NT/N3 MINN3=N3 380 JJD3 = NTSQ/N3 M2MT=M2-MT 450 IF (M2MT)470,460,460 C C M2 GR. OR EQ. MT 460 IGO2=1 N2VNT=N2/NT MINN2=NT GO TO 480 C C M2 LESS THAN MT 470 IGO2 = 2 N2VNT=1 NTVN2=NT/N2 MINN2=N2 480 JJD2=NTSQ/N2 M1MT=M1-MT 550 IF(M1MT)570,560,560 C C M1 GR. OR EQ. MT 560 IGO1=1 N1VNT=N1/NT MINN1=NT GO TO 580 C C M1 LESS THAN MT 570 IGO1=2 N1VNT=1 NTVN1=NT/N1 MINN1=N1 580 JJD1=NTSQ/N1 600 JJ3=1 J=1 DO 880 JPP3=1,N3VNT IPP3=INV(JJ3) DO 870 JP3=1,MINN3 GO TO (610,620),IGO3 610 IP3=INV(JP3)*N3VNT GO TO 630 620 IP3=INV(JP3)/NTVN3 630 I3=(IPP3+IP3)*N2 700 JJ2=1 DO 870 JPP2=1,N2VNT IPP2=INV(JJ2)+I3 DO 860 JP2=1,MINN2 GO TO (710,720),IGO2 710 IP2=INV(JP2)*N2VNT GO TO 730 720 IP2=INV(JP2)/NTVN2 730 I2=(IPP2+IP2)*N1 800 JJ1=1 DO 860 JPP1=1,N1VNT IPP1=INV(JJ1)+I2 DO 850 JP1=1,MINN1 GO TO (810,820),IGO1 810 IP1=INV(JP1)*N1VNT GO TO 830 820 IP1=INV(JP1)/NTVN1 830 I=2*(IPP1+IP1)+1 IF (J-I) 840,850,850 840 T=A(I) A(I)=A(J) A(J)=T T=A(I+1) A(I+1)=A(J+1) A(J+1)=T 850 J=J+2 860 JJ1=JJ1+JJD1 C 870 JJ2=JJ2+JJD2 C END OF JPP2 AND JP3 LOOPS C 880 JJ3 = JJ3+JJD3 C END OF JPP3 LOOP C 890 IF(IFSET)891,895,895 891 DO 892 I = 1,NX 892 A(2*I) = -A(2*I) 895 RETURN C C THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES. C 900 MT=MAX0(M(1),M(2),M(3)) -2 MT = MAX0(2,MT) 904 IF (MT-18) 906,906,13 906 IFERR=0 NT=2**MT NTV2=NT/2 C C SET UP SIN TABLE C THETA=PIE/2**(L+1) FOR L=1 910 THETA=.7853981633974483 C C JSTEP=2**(MT-L+1) FOR L=1 JSTEP=NT C C JDIF=2**(MT-L) FOR L=1 JDIF=NTV2 S(JDIF)=DSIN(THETA) DO 950 L=2,MT THETA=THETA/2.0D0 JSTEP2=JSTEP JSTEP=JDIF JDIF=JSTEP/2 S(JDIF)=DSIN(THETA) JC1=NT-JDIF S(JC1)=DCOS(THETA) JLAST=NT-JSTEP2 IF(JLAST - JSTEP) 950,920,920 920 DO 940 J=JSTEP,JLAST,JSTEP JC=NT-J JD=J+JDIF 940 S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC) 950 CONTINUE C C SET UP INV(J) TABLE C 960 MTLEXP=NTV2 C C MTLEXP=2**(MT-L). FOR L=1 LM1EXP=1 C C LM1EXP=2**(L-1). FOR L=1 INV(1)=0 DO 980 L=1,MT INV(LM1EXP+1) = MTLEXP DO 970 J=2,LM1EXP JJ=J+LM1EXP 970 INV(JJ)=INV(J)+MTLEXP MTLEXP=MTLEXP/2 980 LM1EXP=LM1EXP*2 982 IF(IFSET)12,895,12 END C C .................................................................. C C SUBROUTINE DHEP C C PURPOSE C COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL DHEP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C DOUBLE PRECISION VECTOR. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF HERMITE POLYNOMIAL C DOUBLE PRECISION VARIABLE. C N - ORDER OF HERMITE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C HERMITE POLYNOMIALS H(N,X) C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)) C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X. C C .................................................................. C SUBROUTINE DHEP(Y,X,N) C DIMENSION Y(1) DOUBLE PRECISION Y,X,F C C TEST OF ORDER Y(1)=1.D0 IF(N)1,1,2 1 RETURN C 2 Y(2)=X+X IF(N-1)1,1,3 C 3 DO 4 I=2,N F=X*Y(I)-DFLOAT(I-1)*Y(I-1) 4 Y(I+1)=F+F RETURN END C C .................................................................. C C SUBROUTINE DHEPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL DHEPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE C X - ARGUMENT VALUE C DOUBLE PRECISION VARIABLE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)). C C .................................................................. C SUBROUTINE DHEPS(Y,X,C,N) C DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2 C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1.D0 H1=X+X C DO 4 I=2,N H2=X*H1-DFLOAT(I-1)*H0 H0=H1 H1=H2+H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE DHPCG C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL C DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL DHPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH C DIMENSION GREATER THAN OR EQUAL TO 5, WHICH C SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF C ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN C OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND C SUBROUTINE DHPCG. EXCEPT PRMT(5) THE COMPONENTS C ARE NOT DESTROYED BY SUBROUTINE DHPCG AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCG INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE DHPCG AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE DHPCG DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING DHPCG) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES C (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF C DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE C POINTS X. C DERY - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS C (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE C EQUAL TO 1. LATERON DERY IS THE VECTOR OF C DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT C INTERMEDIATE POINTS X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE DHPCG RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM C TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST C MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT C DESTROY X AND Y. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE DHPCG IS TERMINATED. C AUX - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16 C ROWS AND NDIM COLUMNS. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR- C CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4 C PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE C DEPENDENT VARIABLES. C FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS C USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR C COMPUTATION OF STARTING VALUES. C SUBROUTINE DHPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE CODED BY THE USER. C FOR REFERENCE, SEE C (1) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (2) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C C .................................................................. C SUBROUTINE DHPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C C DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1) DOUBLE PRECISION Y,DERY,AUX,PRMT,X,H,Z,DELT N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0.D0 DO 1 I=1,NDIM AUX(16,I)=0.D0 AUX(15,I)=DERY(I) 1 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))3,2,4 C C ERROR RETURNS 2 IHLF=12 GOTO 4 3 IHLF=13 C C COMPUTATION OF DERY FOR STARTING VALUES 4 CALL FCT(X,Y,DERY) C C RECORDING OF STARTING VALUES CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,5,6 5 IF(IHLF)7,7,6 6 RETURN 7 DO 8 I=1,NDIM 8 AUX(8,I)=DERY(I) C C COMPUTATION OF AUX(2,I) ISW=1 GOTO 100 C 9 X=X+H DO 10 I=1,NDIM 10 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 11 IHLF=IHLF+1 X=X-H DO 12 I=1,NDIM 12 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW=2 GOTO 100 C 13 X=X+H CALL FCT(X,Y,DERY) N=2 DO 14 I=1,NDIM AUX(2,I)=Y(I) 14 AUX(9,I)=DERY(I) ISW=3 GOTO 100 C C COMPUTATION OF TEST VALUE DELT 15 DELT=0.D0 DO 16 I=1,NDIM 16 DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I)) DELT=.066666666666666667D0*DELT IF(DELT-PRMT(4))19,19,17 17 IF(IHLF-10)11,18,18 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 18 IHLF=11 X=X+H GOTO 4 C C THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS. 19 X=X+H CALL FCT(X,Y,DERY) DO 20 I=1,NDIM AUX(3,I)=Y(I) 20 AUX(10,I)=DERY(I) N=3 ISW=4 GOTO 100 C 21 N=1 X=X+H CALL FCT(X,Y,DERY) X=PRMT(1) DO 22 I=1,NDIM AUX(11,I)=DERY(I) 22 Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 23 X=X+H N=N+1 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,24,6 24 IF(N-4)25,200,200 25 DO 26 I=1,NDIM AUX(N,I)=Y(I) 26 AUX(N+7,I)=DERY(I) IF(N-3)27,29,200 C 27 DO 28 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 28 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 23 C 29 DO 30 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 30 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 23 C C THE FOLLOWING PART OF SUBROUTINE DHPCG COMPUTES BY MEANS OF C RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING C PREDICTOR-CORRECTOR METHOD. 100 DO 101 I=1,NDIM Z=H*AUX(N+7,I) AUX(5,I)=Z 101 Y(I)=AUX(N,I)+.4D0*Z C Z IS AN AUXILIARY STORAGE LOCATION C Z=X+.4D0*H CALL FCT(Z,Y,DERY) DO 102 I=1,NDIM Z=H*DERY(I) AUX(6,I)=Z 102 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*Z C Z=X+.45573725421878943D0*H CALL FCT(Z,Y,DERY) DO 103 I=1,NDIM Z=H*DERY(I) AUX(7,I)=Z 103 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*Z C Z=X+H CALL FCT(Z,Y,DERY) DO 104 I=1,NDIM 104 Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) GOTO(9,13,15,21),ISW C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 200 ISTEP=3 201 IF(N-8)204,202,204 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 202 DO 203 N=2,7 DO 203 I=1,NDIM AUX(N-1,I)=AUX(N,I) 203 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 204 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 205 I=1,NDIM AUX(N-1,I)=Y(I) 205 AUX(N+6,I)=DERY(I) X=X+H 206 ISTEP=ISTEP+1 DO 207 I=1,NDIM 0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 207 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. C CALL FCT(X,Y,DERY) C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY C DO 208 I=1,NDIM 0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 208 Y(I)=DELT+.07438016528925620D0*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0.D0 DO 209 I=1,NDIM 209 DELT=DELT+AUX(15,I)*DABS(AUX(16,I)) IF(DELT-PRMT(4))210,222,222 C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. 210 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))212,211,212 211 IF(IHLF-11)213,212,212 212 RETURN 213 IF(H*(X-PRMT(2)))214,212,212 214 IF(DABS(X-PRMT(2))-.1D0*DABS(H))212,215,215 215 IF(DELT-.02D0*PRMT(4))216,216,201 C C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE 216 IF(IHLF)201,201,217 217 IF(N-7)201,218,218 218 IF(ISTEP-4)201,219,219 219 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)201,220,201 220 H=H+H IHLF=IHLF-1 ISTEP=0 DO 221 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 221 AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 201 C C C H MUST BE HALVED 222 IHLF=IHLF+1 IF(IHLF-10)223,223,210 223 H=.5D0*H ISTEP=0 DO 224 I=1,NDIM 0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 224 AUX(N+4,I)=AUX(N+5,I) X=X-H DELT=X-(H+H) CALL FCT(DELT,Y,DERY) DO 225 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 225 Y(I)=AUX(N-4,I) DELT=DELT-(H+H) CALL FCT(DELT,Y,DERY) DO 226 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 226 AUX(N+3,I)=DERY(I) GOTO 206 END C C .................................................................. C C SUBROUTINE DHPCL C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR C DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL DHPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) C PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH C DIMENSION GREATER THAN OR EQUAL TO 5, WHICH C SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF C ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN C OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND C SUBROUTINE DHPCL. EXCEPT PRMT(5) THE COMPONENTS C ARE NOT DESTROYED BY SUBROUTINE DHPCL AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DHPCL INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE DHPCL AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE DHPCL DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING DHPCL) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES C (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF C DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE C POINTS X. C DERY - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS C (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE C EQUAL TO 1. LATERON DERY IS THE VECTOR OF C DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT C INTERMEDIATE POINTS X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE DHPCL RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C AFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE C RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE. C ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE C SHOULD NOT DESTROY X. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE C RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE. C ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE C SHOULD NOT DESTROY X. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE DHPCL IS TERMINATED. C AUX - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 16 C ROWS AND NDIM COLUMNS. C A - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED C AS AUXILIARY STORAGE ARRAY. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR- C CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4 C PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE C DEPENDENT VARIABLES. C FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS C USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR C COMPUTATION OF STARTING VALUES. C SUBROUTINE DHPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE CODED BY THE USER. C FOR REFERENCE, SEE C (1) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (2) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C C .................................................................. C SUBROUTINE DHPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) C C C THE FOLLOWING FIRST PART OF SUBROUTINE DHPCL (UNTIL FIRST BREAK- C POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE C COMPUTATION C DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1) DOUBLE PRECISION PRMT,Y,DERY,AUX,X,H,Z,DELT,A,HS GOTO 100 C C THIS PART OF SUBROUTINE DHPCL COMPUTES THE RIGHT HAND SIDE DERY OF C THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS. 1 CALL AFCT(X,A) CALL FCT(X,DERY) DO 3 M=1,NDIM LL=M-NDIM HS=0.D0 DO 2 L=1,NDIM LL=LL+NDIM 2 HS=HS+A(LL)*Y(L) 3 DERY(M)=HS+DERY(M) GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2 C C POSSIBLE BREAK-POINT FOR LINKAGE C 100 N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0.D0 DO 101 I=1,NDIM AUX(16,I)=0.D0 AUX(15,I)=DERY(I) 101 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))103,102,104 C C ERROR RETURNS 102 IHLF=12 GOTO 104 103 IHLF=13 C C COMPUTATION OF DERY FOR STARTING VALUES 104 ISW2=1 GOTO 1 C C RECORDING OF STARTING VALUES 105 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,106,107 106 IF(IHLF)108,108,107 107 RETURN 108 DO 109 I=1,NDIM C 109 AUX(8,I)=DERY(I) C COMPUTATION OF AUX(2,I) ISW1=1 GOTO 200 110 X=X+H DO 111 I=1,NDIM 111 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 112 IHLF=IHLF+1 X=X-H DO 113 I=1,NDIM 113 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW1=2 GOTO 200 C 114 X=X+H ISW2=5 GOTO 1 115 N=2 DO 116 I=1,NDIM AUX(2,I)=Y(I) 116 AUX(9,I)=DERY(I) ISW1=3 GOTO 200 C C COMPUTATION OF TEST VALUE DELT 117 DELT=0.D0 DO 118 I=1,NDIM 118 DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I)) DELT=.066666666666666667D0*DELT IF(DELT-PRMT(4))121,121,119 119 IF(IHLF-10)112,120,120 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 120 IHLF=11 X=X+H GOTO 104 C C SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS 121 X=X+H ISW2=6 GOTO 1 122 DO 123 I=1,NDIM AUX(3,I)=Y(I) 123 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 200 C 124 N=1 X=X+H ISW2=7 GOTO 1 125 X=PRMT(1) DO 126 I=1,NDIM AUX(11,I)=DERY(I) 126 Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 127 X=X+H N=N+1 ISW2=12 GOTO 1 128 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,129,107 129 IF(N-4)130,300,300 130 DO 131 I=1,NDIM AUX(N,I)=Y(I) 131 AUX(N+7,I)=DERY(I) IF(N-3)132,134,300 C 132 DO 133 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 133 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 127 C 134 DO 135 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 135 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 127 C C THE FOLLOWING PART OF SUBROUTINE DHPCL COMPUTES BY MEANS OF C RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING C PREDICTOR-CORRECTOR METHOD. 200 Z=X DO 201 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 201 Y(I)=AUX(N,I)+.4D0*X C X IS AN AUXILIARY STORAGE LOCATION C X=Z+.4D0*H ISW2=2 GOTO 1 202 DO 203 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 203 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X C X=Z+.45573725421878943D0*H ISW2=3 GOTO 1 204 DO 205 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 205 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*X C X=Z+H ISW2=4 GOTO 1 206 DO 207 I=1,NDIM 207 Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) X=Z GOTO(110,114,117,124),ISW1 C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 300 ISTEP=3 301 IF(N-8)304,302,304 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 302 DO 303 N=2,7 DO 303 I=1,NDIM AUX(N-1,I)=AUX(N,I) 303 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 304 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 305 I=1,NDIM AUX(N-1,I)=Y(I) 305 AUX(N+6,I)=DERY(I) X=X+H 306 ISTEP=ISTEP+1 DO 307 I=1,NDIM DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 307 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. ISW2=8 GOTO 1 C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY C 308 DO 309 I=1,NDIM DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 309 Y(I)=DELT+.07438016528925620D0*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0.D0 DO 310 I=1,NDIM 310 DELT=DELT+AUX(15,I)*DABS(AUX(16,I)) IF(DELT-PRMT(4))311,324,324 C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. 311 ISW2=9 GOTO 1 312 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))314,313,314 313 IF(IHLF-11)315,314,314 314 RETURN 315 IF(H*(X-PRMT(2)))316,314,314 316 IF(DABS(X-PRMT(2))-.1D0*DABS(H))314,317,317 317 IF(DELT-.02D0*PRMT(4))318,318,301 C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE 318 IF(IHLF)301,301,319 319 IF(N-7)301,320,320 320 IF(ISTEP-4)301,321,321 321 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)301,322,301 322 H=H+H IHLF=IHLF-1 ISTEP=0 DO 323 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 323 AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 301 C C H MUST BE HALVED 324 IHLF=IHLF+1 IF(IHLF-10)325,325,311 325 H=.5D0*H ISTEP=0 DO 326 I=1,NDIM Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 326 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=10 GOTO 1 327 DO 328 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 328 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=11 GOTO 1 329 X=DELT DO 330 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 330 AUX(N+3,I)=DERY(I) GOTO 306 END C C .................................................................. C C SUBROUTINE DISCR C C PURPOSE C COMPUTE A SET OF LINEAR FUNCTIONS WHICH SERVE AS INDICES C FOR CLASSIFYING AN INDIVIDUAL INTO ONE OF SEVERAL GROUPS. C NORMALLY THIS SUBROUTINE IS USED IN THE PERFORMANCE OF C DISCRIMINANT ANALYSIS. C C USAGE C CALL DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF GROUPS. K MUST BE GREATER THAN ONE. C M - NUMBER OF VARIABLES C N - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF C GROUPS. C X - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA- C LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1), C X(2,1,1), X(3,1,1), ETC. THE FIRST SUBSCRIPT IS C CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER C AND THE THIRD SUBSCRIPT IS GROUP NUMBER. THE C LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF C DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K). C XBAR - INPUT MATRIX (M X K) CONTAINING MEANS OF M VARIABLES C IN K GROUPS C D - INPUT MATRIX (M X M) CONTAINING THE INVERSE OF C POOLED DISPERSION MATRIX. C CMEAN - OUTPUT VECTOR OF LENGTH M CONTAINING COMMON MEANS. C V - OUTPUT VARIABLE CONTAINING GENERALIZED MAHALANOBIS C D-SQUARE. C C - OUTPUT MATRIX (M+1 X K) CONTAINING THE COEFFICIENTS C OF DISCRIMINANT FUNCTIONS. THE FIRST POSITION OF C EACH COLUMN (FUNCTION) CONTAINS THE VALUE OF THE C CONSTANT FOR THAT FUNCTION. C P - OUTPUT VECTOR CONTAINING THE PROBABILITY ASSOCIATED C WITH THE LARGEST DISCRIMINANT FUNCTIONS OF ALL CASES C IN ALL GROUPS. CALCULATED RESULTS ARE STORED IN THE C MANNER EQUIVALENT TO A 2-DIMENSIONAL AREA (THE C FIRST SUBSCRIPT IS CASE NUMBER, AND THE SECOND C SUBSCRIPT IS GROUP NUMBER). VECTOR P HAS LENGTH C EQUAL TO THE TOTAL NUMBER OF CASES, T (T = N(1)+N(2) C +...+N(K)). C LG - OUTPUT VECTOR CONTAINING THE SUBSCRIPTS OF THE C LARGEST DISCRIMINANT FUNCTIONS STORED IN VECTOR P. C THE LENGTH OF VECTOR LG IS THE SAME AS THE LENGTH C OF VECTOR P. C C REMARKS C THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO C THE NUMBER OF GROUPS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J. C DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO C MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS, C 1958, SECTION 6.6-6.8. C C .................................................................. C SUBROUTINE DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG) DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1),C(1),P(1),LG(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION XBAR,D,CMEAN,V,C,SUM,P,PL C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. EXP IN STATEMENT C 250 MUST BE CHANGED TO DEXP. C C ............................................................... C C CALCULATE COMMON MEANS C N1=N(1) DO 100 I=2,K 100 N1=N1+N(I) FNT=N1 DO 110 I=1,K 110 P(I)=N(I) DO 130 I=1,M CMEAN(I)=0 N1=I-M DO 120 J=1,K N1=N1+M 120 CMEAN(I)=CMEAN(I)+P(J)*XBAR(N1) 130 CMEAN(I)=CMEAN(I)/FNT C C CALCULATE GENERALIZED MAHALANOBIS D SQUARE C L=0 DO 140 I=1,K DO 140 J=1,M L=L+1 140 C(L)=XBAR(L)-CMEAN(J) V=0.0 L=0 DO 160 J=1,M DO 160 I=1,M N1=I-M N2=J-M SUM=0.0 DO 150 IJ=1,K N1=N1+M N2=N2+M 150 SUM=SUM+P(IJ)*C(N1)*C(N2) L=L+1 160 V=V+D(L)*SUM C C CALCULATE THE COEFFICIENTS OF DISCRIMINANT FUNCTIONS C N2=0 DO 190 KA=1,K DO 170 I=1,M N2=N2+1 170 P(I)=XBAR(N2) IQ=(M+1)*(KA-1)+1 SUM=0.0 DO 180 J=1,M N1=J-M DO 180 L=1,M N1=N1+M 180 SUM=SUM+D(N1)*P(J)*P(L) C(IQ)=-(SUM/2.0) DO 190 I=1,M N1=I-M IQ=IQ+1 C(IQ)=0.0 DO 190 J=1,M N1=N1+M 190 C(IQ)=C(IQ)+D(N1)*P(J) C C FOR EACH CASE IN EACH GROUP, CALCULATE.. C C DISCRIMINANT FUNCTIONS C LBASE=0 N1=0 DO 270 KG=1,K NN=N(KG) DO 260 I=1,NN L=I-NN+LBASE DO 200 J=1,M L=L+NN 200 D(J)=X(L) N2=0 DO 220 KA=1,K N2=N2+1 SUM=C(N2) DO 210 J=1,M N2=N2+1 210 SUM=SUM+C(N2)*D(J) 220 XBAR(KA)=SUM C C THE LARGEST DISCRIMINANT FUNCTION C L=1 SUM=XBAR(1) DO 240 J=2,K IF(SUM-XBAR(J)) 230, 240, 240 230 L=J SUM=XBAR(J) 240 CONTINUE C C PROBABILITY ASSOCIATED WITH THE LARGEST DISCRIMINANT FUNCTION C PL=0.0 DO 250 J=1,K 250 PL=PL+ EXP(XBAR(J)-SUM) N1=N1+1 LG(N1)=L 260 P(N1)=1.0/PL 270 LBASE=LBASE+NN*M C RETURN END C C .................................................................. C C SUBROUTINE DJELF C C PURPOSE C COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN. C C USAGE C CALL DJELF(SN,CN,DN,X,SCK) C C DESCRIPTION OF PARAMETERS C SN - RESULT VALUE SN(X) IN DOUBLE PRECISION C CN - RESULT VALUE CN(X) IN DOUBLE PRECISION C DN - RESULT VALUE DN(X) IN DOUBLE PRECISION C X - DOUBLE PRECISION ARGUMENT OF JACOBIAN ELLIPTIC C FUNCTIONS C SCK - SQUARE OF COMPLEMENTARY MODULUS IN DOUBLE PRECISION C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER C T FROM 0 TO SN), WHERE K=SQRT(1-SCK). C SN*SN + CN*CN = 1 C (K*SN)**2 + DN**2 = 1. C EVALUATION C CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC C GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION C BEFORE INVERSION OF THE INTEGRAL TAKES PLACE. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIOMS. C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE DJELF(SN,CN,DN,X,SCK) C DIMENSION ARI(12),GEO(12) DOUBLE PRECISION SN,CN,DN,X,SCK,ARI,GEO,CM,Y,A,B,C,D C C TEST MODULUS C CM=SCK Y=X IF(SCK)3,1,4 1 D=DEXP(X) A=1.D0/D B=A+D CN=2.D0/B DN=CN A=(D-A)/2.D0 SN=A*CN C DEGENERATE CASE SCK=0 GIVES RESULTS C CN X = DN X = 1/COSH X C SN X = TANH X 2 RETURN C C JACOBIS MODULUS TRANSFORMATION C 3 D=1.D0-SCK CM=-SCK/D D=DSQRT(D) Y=D*X 4 A=1.D0 DN=1.D0 DO 6 I=1,12 L=I ARI(I)=A CM=DSQRT(CM) GEO(I)=CM C=(A+CM)*.5D0 IF(DABS(A-CM)-1.D-9*A)7,7,5 5 CM=A*CM 6 A=C C C START BACKWARD RECURSION C 7 Y=C*Y SN=DSIN(Y) CN=DCOS(Y) IF(SN)8,13,8 8 A=CN/SN C=A*C DO 9 I=1,L K=L-I+1 B=ARI(K) A=C*A C=DN*C DN=(GEO(K)+A)/(B+A) 9 A=C/B A=1.D0/DSQRT(C*C+1.D0) IF(SN)10,11,11 10 SN=-A GOTO 12 11 SN=A 12 CN=C*SN 13 IF(SCK)14,2,2 14 A=DN DN=CN CN=A SN=SN/D RETURN END C C .................................................................. C C SUBROUTINE DLAP C C PURPOSE C COMPUTE THE VALUES OF THE LAGUERRE POLYNOMIALS L(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL DLAP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF LAGUERRE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C DOUBLE PRECISION VECTOR. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF LAGUERRE POLYNOMIAL C DOUBLE PRECISION VARIABLE. C N - ORDER OF LAGUERRE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C LAGUERRE POLYNOMIALS L(N,X) C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE L(0,X)=1, L(1,X)=1.-X. C C .................................................................. C SUBROUTINE DLAP(Y,X,N) C DIMENSION Y(1) DOUBLE PRECISION Y,X,T C C TEST OF ORDER Y(1)=1.D0 IF(N)1,1,2 1 RETURN C 2 Y(2)=1.D0-X IF(N-1)1,1,3 C C INITIALIZATION 3 T=1.D0+X C DO 4 I=2,N 4 Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/DFLOAT(I) RETURN END C C .................................................................. C C SUBROUTINE DLAPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LAGUERRE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL DLAPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE C X - ARGUMENT VALUE C DOUBLE PRECISION VARIABLE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR LAGUERRE POLYNOMIALS C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1). C C .................................................................. C SUBROUTINE DLAPS(Y,X,C,N) C DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,T C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1.D0 H1=1.D0-X T=1.D0+X DO 4 I=2,N H2=H1-H0+H1-(T*H1-H0)/DFLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE DLBVP C C PURPOSE C TO SOLVE A LINEAR BOUNDARY VALUE PROBLEM, WHICH CONSISTS OF C A SYSTEM OF NDIM LINEAR FIRST ORDER DIFFERENTIAL EQUATIONS C DY/DX=A(X)*Y(X)+F(X) C AND NDIM LINEAR BOUNDARY CONDITIONS C B*Y(XL)+C*Y(XU)=R. C C USAGE C CALL DLBVP (PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, C AUX,A) C PARAMETERS AFCT,FCT,DFCT,OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH C DIMENSION GREATER THAN OR EQUAL TO 5, WHICH C SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF C ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN C OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND C SUBROUTINE DLBVP. EXCEPT PRMT(5) THE COMPONENTS C ARE NOT DESTROYED BY SUBROUTINE DLBVP AND THEY ARE C PRMT(1)- LOWER BOUND XL OF THE INTERVAL (INPUT), C PRMT(1)- UPPER BOUND XU OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF RELATIVE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND RELATIVE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DLBVP INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE DLBVP AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE DLBVP DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING DLBVP) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C B - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX C (DESTROYED). IT IS THE COEFFICIENT MATRIX OF Y(XL) C IN THE BOUNDARY CONDITIONS. C C - DOUBLE PRECISION NDIM BY NDIM INPUT MATRIX C (POSSIBLY DESTROYED). IT IS THE COEFFICIENT MATRIX C OF Y(XU) IN THE BOUNDARY CONDITIONS. C R - DOUBLE PRECISION INPUT VECTOR WITH DIMENSION NDIM C (DESTROYED). IT SPECIFIES THE RIGHT HAND SIDE OF C THE BOUNDARY CONDITIONS. C Y - DOUBLE PRECISION AUXILIARY VECTOR WITH C DIMENSION NDIM. IT IS USED AS STORAGE LOCATION C FOR THE RESULTING VALUES OF DEPENDENT VARIABLES C COMPUTED AT INTERMEDIATE POINTS X. C DERY - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS C (DESTROYED). ITS MAXIMAL COMPONENT SHOULD BE C EQUAL TO 1. LATERON DERY IS THE VECTOR OF C DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT C INTERMEDIATE POINTS X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C DIFFERENTIAL EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE DLBVP RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. FINALLY ERROR MESSAGE C IHLF=14 INDICATES, THAT THERE IS NO SOLUTION OR C THAT THERE ARE MORE THAN ONE SOLUTION OF THE C PROBLEM. C A NEGATIVE VALUE OF IHLF HANDED TO SUBROUTINE OUTP C TOGETHER WITH INITIAL VALUES OF FINALLY GENERATED C INITIAL VALUE PROBLEM INDICATES, THAT THERE WAS C POSSIBLE LOSS OF SIGNIFICANCE IN THE SOLUTION OF C THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS FOR C THESE INITIAL VALUES. THE ABSOLUTE VALUE OF IHLF C SHOWS, AFTER WHICH ELIMINATION STEP OF GAUSS C ALGORITHM POSSIBLE LOSS OF SIGNIFICANCE WAS C DETECTED. C AFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES THE COEFFICIENT MATRIX A OF VECTOR Y ON C THE RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS FOR A GIVEN X-VALUE. ITS PARAMETER LIST C MUST BE X,A. SUBROUTINE AFCT SHOULD NOT DESTROY X. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE C RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS) FOR A GIVEN X-VALUE. ITS PARAMETER LIST C MUST BE X,F. SUBROUTINE FCT SHOULD NOT DESTROY X. C DFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR DF (DERIVATIVE OF THE INHOMOGENEOUS C PART ON THE RIGHT HAND SIDE OF THE SYSTEM OF C DIFFERENTIAL EQUATIONS) FOR A GIVEN X-VALUE. ITS C PARAMETER LIST MUST BE X,DF. SUBROUTINE DFCT C SHOULD NOT DESTROY X. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE DLBVP IS TERMINATED. C AUX - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 20 C ROWS AND NDIM COLUMNS. C A - DOUBLE PRECISION NDIM BY NDIM MATRIX, WHICH IS USED C AS AUXILIARY STORAGE ARRAY. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR IF IT HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THERE IS NO OR MORE THAN ONE SOLUTION OF THE PROBLEM C (ERROR MESSAGE IHLF=14), C (4) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (5) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SUBROUTINE DGELG SYSTEM OF LINEAR EQUATIONS. C THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F), DFCT(X,DF), C AND OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE USING THE METHOD OF ADJOINT EQUATIONS. C HAMMINGS FOURTH ORDER MODIFIED PREDICTOR-CORRECTOR METHOD C IS USED TO SOLVE THE ADJOINT INITIAL VALUE PROBLEMS AND FI- C NALLY TO SOLVE THE GENERATED INITIAL VALUE PROBLEM FOR Y(X). C THE INITIAL INCREMENT PRMT(3) IS AUTOMATICALLY ADJUSTED. C FOR COMPUTATION OF INTEGRAL SUM, A FOURTH ORDER HERMITEAN C INTEGRATION FORMULA IS USED. C FOR REFERENCE, SEE C (1) LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS, C ILIFFE, LONDON, 1960, PP.64-67. C (2) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (3) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C (4) ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-232. C C .................................................................. C SUBROUTINE DLBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, 1AUX,A) C C DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1) DOUBLE PRECISION PRMT,B,C,R,Y,DERY,AUX,A,H,X,Z,GL,HS,GU,SUM, 1DGL,DGU,XST,XEND,DELT C C ERROR TEST IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3 1 IHLF=12 RETURN 2 IHLF=13 RETURN C C SEARCH FOR ZERO-COLUMNS IN MATRICES B AND C 3 KK=-NDIM IB=0 IC=0 DO 7 K=1,NDIM AUX(15,K)=DERY(K) AUX(1,K)=1.D0 AUX(17,K)=1.D0 KK=KK+NDIM DO 4 I=1,NDIM II=KK+I IF(B(II))5,4,5 4 CONTINUE IB=IB+1 AUX(1,K)=0.D0 5 DO 6 I=1,NDIM II=KK+I IF(C(II))7,6,7 6 CONTINUE IC=IC+1 AUX(17,K)=0.D0 7 CONTINUE C C DETERMINATION OF LOWER AND UPPER BOUND IF(IC-IB)8,11,11 8 H=PRMT(2) PRMT(2)=PRMT(1) PRMT(1)=H PRMT(3)=-PRMT(3) DO 9 I=1,NDIM 9 AUX(17,I)=AUX(1,I) II=NDIM*NDIM DO 10 I=1,II H=B(I) B(I)=C(I) 10 C(I)=H C C PREPARATIONS FOR CONSTRUCTION OF ADJOINT INITIAL VALUE PROBLEMS 11 X=PRMT(2) CALL FCT(X,Y) CALL DFCT(X,DERY) DO 12 I=1,NDIM AUX(18,I)=Y(I) 12 AUX(19,I)=DERY(I) C C POSSIBLE BREAK-POINT FOR LINKAGE C C THE FOLLOWING PART OF SUBROUTINE DLBVP UNTIL NEXT BREAK-POINT FOR C LINKAGE HAS TO REMAIN IN CORE DURING THE WHOLE REST OF THE C COMPUTATIONS C C START LOOP FOR GENERATING ADJOINT INITIAL VALUE PROBLEMS K=0 KK=0 100 K=K+1 IF(AUX(17,K))108,108,101 C C INITIALIZATION OF ADJOINT INITIAL VALUE PROBLEM 101 X=PRMT(2) CALL AFCT(X,A) SUM=0.D0 GL=AUX(18,K) DGL=AUX(19,K) II=K DO 104 I=1,NDIM H=-A(II) DERY(I)=H AUX(20,I)=R(I) Y(I)=0.D0 IF(I-K)103,102,103 102 Y(I)=1.D0 103 DGL=DGL+H*AUX(18,I) 104 II=II+NDIM XEND=PRMT(1) H=.0625D0*(XEND-X) ISW=0 GOTO 400 C THIS IS BRANCH TO ADJOINT LINEAR INITIAL VALUE PROBLEM C C THIS IS RETURN FROM ADJOINT LINEAR INITIAL VALUE PROBLEM 105 IF(IHLF-10)106,106,117 C C UPDATING OF COEFFICIENT MATRIX B AND VECTOR R 106 DO 107 I=1,NDIM KK=KK+1 H=C(KK) R(I)=AUX(20,I)+H*SUM II=I DO 107 J=1,NDIM B(II)=B(II)+H*Y(J) 107 II=II+NDIM GOTO 109 108 KK=KK+NDIM 109 IF(K-NDIM)100,110,110 C C C GENERATION OF LAST INITIAL VALUE PROBLEM 110 EPS=PRMT(4) CALL DGELG(R,B,NDIM,1,EPS,I) IF(I)111,112,112 111 IHLF=14 RETURN C 112 PRMT(5)=0.D0 IHLF=-I X=PRMT(1) XEND=PRMT(2) H=PRMT(3) DO 113 I=1,NDIM 113 Y(I)=R(I) ISW=1 114 ISW2=12 GOTO 200 115 ISW3=-1 GOTO 300 116 IF(IHLF)400,400,117 C THIS WAS BRANCH INTO INITIAL VALUE PROBLEM C C THIS IS RETURN FROM INITIAL VALUE PROBLEM 117 RETURN C C THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE RIGHT C HAND SIDE DERY OF THE SYSTEM OF ADJOINT LINEAR DIFFERENTIAL C EQUATIONS (IN CASE ISW=0) OR OF THE GIVEN SYSTEM (IN CASE ISW=1). 200 CALL AFCT(X,A) IF(ISW)201,201,205 C C ADJOINT SYSTEM 201 LL=0 DO 203 M=1,NDIM HS=0.D0 DO 202 L=1,NDIM LL=LL+1 202 HS=HS-A(LL)*Y(L) 203 DERY(M)=HS 204 GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2 C C GIVEN SYSTEM 205 CALL FCT(X,DERY) DO 207 M=1,NDIM LL=M-NDIM HS=0.D0 DO 206 L=1,NDIM LL=LL+NDIM 206 HS=HS+A(LL)*Y(L) 207 DERY(M)=HS+DERY(M) GOTO 204 C C THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE VALUE OF C INTEGRAL SUM, WHICH IS A PART OF THE OUTPUT OF ADJOINT INITIAL C VALUE PROBLEM (IN CASE ISW=0) OR RECORDS RESULT VALUES OF THE C FINAL INITIAL VALUE PROBLEM (IN CASE ISW=1). 300 IF(ISW)301,301,305 C C ADJOINT PROBLEM 301 CALL FCT(X,R) GU=0.D0 DGU=0.D0 DO 302 L=1,NDIM GU=GU+Y(L)*R(L) 302 DGU=DGU+DERY(L)*R(L) CALL DFCT(X,R) DO 303 L=1,NDIM 303 DGU=DGU+Y(L)*R(L) SUM=SUM+.5D0*H*((GL+GU)+.16666666666666667D0*H*(DGL-DGU)) GL=GU DGL=DGU 304 IF(ISW3)116,422,618 C C GIVEN PROBLEM 305 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))117,304,117 C C POSSIBLE BREAK-POINT FOR LINKAGE C C THE FOLLOWING PART OF SUBROUTINE DLBVP SOLVES IN CASE ISW=0 THE C ADJOINT INITIAL VALUE PROBLEM. IT COMPUTES INTEGRAL SUM AND C THE VECTOR Y OF DEPENDENT VARIABLES AT THE LOWER BOUND PRMT(1). C IN CASE ISW=1 IT SOLVES FINALLY GENERATED INITIAL VALUE PROBLEM. 400 N=1 XST=X IHLF=0 DO 401 I=1,NDIM AUX(16,I)=0.D0 AUX(1,I)=Y(I) 401 AUX(8,I)=DERY(I) ISW1=1 GOTO 500 C 402 X=X+H DO 403 I=1,NDIM 403 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 404 IHLF=IHLF+1 X=X-H DO 405 I=1,NDIM 405 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW1=2 GOTO 500 C 406 X=X+H ISW2=4 GOTO 200 407 N=2 DO 408 I=1,NDIM AUX(2,I)=Y(I) 408 AUX(9,I)=DERY(I) ISW1=3 GOTO 500 C C TEST ON SATISFACTORY ACCURACY 409 DO 414 I=1,NDIM Z=DABS(Y(I)) IF(Z-1.D0)410,411,411 410 Z=1.D0 411 DELT=.066666666666666667D0*DABS(Y(I)-AUX(4,I)) IF(ISW)413,413,412 412 DELT=AUX(15,I)*DELT 413 IF(DELT-Z*PRMT(4))414,414,429 414 CONTINUE C C SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS X=X+H ISW2=5 GOTO 200 415 DO 416 I=1,NDIM AUX(3,I)=Y(I) 416 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 500 C 417 N=1 X=X+H ISW2=6 GOTO 200 418 X=XST DO 419 I=1,NDIM AUX(11,I)=DERY(I) 419 Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 420 X=X+H N=N+1 ISW2=11 GOTO 200 421 ISW3=0 GOTO 300 422 IF(N-4)423,600,600 423 DO 424 I=1,NDIM AUX(N,I)=Y(I) 424 AUX(N+7,I)=DERY(I) IF(N-3)425,427,600 C 425 DO 426 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 426 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 420 C 427 DO 428 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 428 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 420 C C NO SATISFACTORY ACCURACY. H MUST BE HALVED. 429 IF(IHLF-10)404,430,430 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 430 IHLF=11 X=X+H IF(ISW)105,105,114 C C THIS PART OF LINEAR INITIAL VALUE PROBLEM COMPUTES C STARTING VALUES BY MEANS OF RUNGE-KUTTA METHOD. 500 Z=X DO 501 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 501 Y(I)=AUX(N,I)+.4D0*X C X=Z+.4D0*H ISW2=1 GOTO 200 502 DO 503 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 503 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X C X=Z+.45573725421878943D0*H ISW2=2 GOTO 200 504 DO 505 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 505 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*X C X=Z+H ISW2=3 GOTO 200 506 DO 507 I=1,NDIM 507 Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) X=Z GOTO(402,406,409,417),ISW1 C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 600 ISTEP=3 601 IF(N-8)604,602,604 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 602 DO 603 N=2,7 DO 603 I=1,NDIM AUX(N-1,I)=AUX(N,I) 603 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 604 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 605 I=1,NDIM AUX(N-1,I)=Y(I) 605 AUX(N+6,I)=DERY(I) X=X+H 606 ISTEP=ISTEP+1 DO 607 I=1,NDIM DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 607 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. C ISW2=7 GOTO 200 C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY. C 608 DO 609 I=1,NDIM DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 609 Y(I)=DELT+.07438016528925620D0*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0.D0 DO 616 I=1,NDIM Z=DABS(Y(I)) IF(Z-1.D0)610,611,611 610 Z=1.D0 611 Z=DABS(AUX(16,I))/Z IF(ISW)613,613,612 612 Z=AUX(15,I)*Z 613 IF(Z-PRMT(4))614,614,628 614 IF(DELT-Z)615,616,616 615 DELT=Z 616 CONTINUE C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. ISW2=8 GOTO 200 617 ISW3=1 GOTO 300 618 IF(H*(X-XEND))619,621,621 619 IF(DABS(X-XEND)-.1D0*DABS(H))621,620,620 620 IF(DELT-.02D0*PRMT(4))622,622,601 621 IF(ISW)105,105,117 C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE. 622 IF(IHLF)601,601,623 623 IF(N-7)601,624,624 624 IF(ISTEP-4)601,625,625 625 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)601,626,601 626 H=H+H IHLF=IHLF-1 ISTEP=0 DO 627 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 627 AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 601 C C H MUST BE HALVED 628 IHLF=IHLF+1 IF(IHLF-10)630,630,629 629 IF(ISW)105,105,114 630 H=.5D0*H ISTEP=0 DO 631 I=1,NDIM Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 631 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=9 GOTO 200 632 DO 633 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 633 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=10 GOTO 200 634 X=DELT DO 635 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 635 AUX(N+3,I)=DERY(I) GOTO 606 C END OF INITIAL VALUE PROBLEM END C C .................................................................. C C SUBROUTINE DLEP C C PURPOSE C COMPUTE THE VALUES OF THE LEGENDRE POLYNOMIALS P(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL DLEP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF LEGENDRE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C DOUBLE PRECISION VECTOR. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF LEGENDRE POLYNOMIAL C DOUBLE PRECISION VARIABLE. C N - ORDER OF LEGENDRE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C LEGENDRE POLYNOMIALS P(N,X) C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE P(0,X)=1, P(1,X)=X. C C .................................................................. C SUBROUTINE DLEP(Y,X,N) C DIMENSION Y(1) DOUBLE PRECISION Y,X,G C C TEST OF ORDER Y(1)=1.D0 IF(N)1,1,2 1 RETURN C 2 Y(2)=X IF(N-1)1,1,3 C 3 DO 4 I=2,N G=X*Y(I) 4 Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/DFLOAT(I) RETURN END C C .................................................................. C C SUBROUTINE DLEPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LEGENDRE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL DLEPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C DOUBLE PRECISION VARIABLE C X - ARGUMENT VALUE C DOUBLE PRECISION VARIABLE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR LEGENDRE POLYNOMIALS C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1). C C .................................................................. C SUBROUTINE DLEPS(Y,X,C,N) C DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2 C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1.D0 H1=X C DO 4 I=2,N H2=X*H1 H2=H2-H0+H2-(H2-H0)/DFLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE DLGAM C C PURPOSE C COMPUTES THE DOUBLE PRECISION NATURAL LOGARITHM OF THE C GAMMA FUNCTION OF A GIVEN DOUBLE PRECISION ARGUMENT. C C USAGE C CALL DLGAM(XX,DLNG,IER) C C DESCRIPTION OF PARAMETERS C XX - THE DOUBLE PRECISION ARGUMENT FOR THE LOG GAMMA C FUNCTION. C DLNG - THE RESULTANT DOUBLE PRECISION LOG GAMMA FUNCTION C VALUE. C IER - RESULTANT ERROR CODE WHERE C IER= 0----NO ERROR. C IER=-1----XX IS WITHIN 10**(-9) OF BEING ZERO OR XX C IS NEGATIVE. DLNG IS SET TO -1.OD75. C IER=+1----XX IS GREATER THAN 10**70. DLNG IS SET TO C +1.OD75. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE EULER-MCLAURIN EXPANSION TO THE SEVENTH DERIVATIVE TERM C IS USED, AS GIVEN BY M. ABRAMOWITZ AND I.A. STEGUN, C 'HANDBOOK OF MATHEMATICAL FUNCTIONS', U. S. DEPARTMENT OF C COMMERCE, NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES, 1966, EQUATION 6.1.41. C C .................................................................. C SUBROUTINE DLGAM(XX,DLNG,IER) DOUBLE PRECISION XX,ZZ,TERM,RZ2,DLNG IER=0 ZZ=XX IF(XX-1.D10) 2,2,1 1 IF(XX-1.7D33) 8,9,9 0 C C SEE IF XX IS NEAR ZERO OR NEGATIVE C 2 IF(XX-1.D-9) 3,3,4 3 IER=-1 DLNG=-1.7D38 0 GO TO 10 C C XX GREATER THAN ZERO AND LESS THAN OR EQUAL TO 1.D+10 C 4 TERM=1.D0 5 IF(ZZ-18.D0) 6,6,7 6 TERM=TERM*ZZ ZZ=ZZ+1.D0 GO TO 5 7 RZ2=1.D0/ZZ**2 DLNG =(ZZ-0.5D0)*DLOG(ZZ)-ZZ +0.9189385332046727 -DLOG(TERM)+ 1(1.D0/ZZ)*(.8333333333333333D-1 -(RZ2*(.2777777777777777D-2 +(RZ2* 2(.7936507936507936D-3 -(RZ2*(.5952380952380952D-3))))))) GO TO 10 C C XX GREATER THAN 1.D+10 AND LESS THAN 1.D+70 C 8 DLNG=ZZ*(DLOG(ZZ)-1.D0) GO TO 10 C C XX GREATER THAN OR EQUAL TO 1.D+70 C 9 IER=+1 DLNG=1.7D38 0 10 RETURN END C C .................................................................. C C SUBROUTINE DLLSQ C C PURPOSE C TO SOLVE LINEAR LEAST SQUARES PROBLEMS, I.E. TO MINIMIZE C THE EUCLIDEAN NORM OF B-A*X, WHERE A IS A M BY N MATRIX C WITH M NOT LESS THAN N. IN THE SPECIAL CASE M=N SYSTEMS OF C LINEAR EQUATIONS MAY BE SOLVED. C C USAGE C CALL DLLSQ (A,B,M,N,L,X,IPIV,EPS,IER,AUX) C C DESCRIPTION OF PARAMETERS C A - DOUBLE PRECISION M BY N COEFFICIENT MATRIX C (DESTROYED). C B - DOUBLE PRECISION M BY L RIGHT HAND SIDE MATRIX C (DESTROYED). C M - ROW NUMBER OF MATRICES A AND B. C N - COLUMN NUMBER OF MATRIX A, ROW NUMBER OF MATRIX X. C L - COLUMN NUMBER OF MATRICES B AND X. C X - DOUBLE PRECISION N BY L SOLUTION MATRIX. C IPIV - INTEGER OUTPUT VECTOR OF DIMENSION N WHICH C CONTAINS INFORMATIONS ON COLUMN INTERCHANGES C IN MATRIX A. (SEE REMARK NO.3). C EPS - SINGLE PRECISION INPUT PARAMETER WHICH SPECIFIES C A RELATIVE TOLERANCE FOR DETERMINATION OF RANK OF C MATRIX A. C IER - A RESULTING ERROR PARAMETER. C AUX - A DOUBLE PRECISION AUXILIARY STORAGE ARRAY OF C DIMENSION MAX(2*N,L). ON RETURN FIRST L LOCATIONS C OF AUX CONTAIN THE RESULTING LEAST SQUARES. C C REMARKS C (1) NO ACTION BESIDES ERROR MESSAGE IER=-2 IN CASE C M LESS THAN N. C (2) NO ACTION BESIDES ERROR MESSAGE IER=-1 IN CASE C OF A ZERO-MATRIX A. C (3) IF RANK K OF MATRIX A IS FOUND TO BE LESS THAN N BUT C GREATER THAN 0, THE PROCEDURE RETURNS WITH ERROR CODE C IER=K INTO CALLING PROGRAM. THE LAST N-K ELEMENTS OF C VECTOR IPIV DENOTE THE USELESS COLUMNS IN MATRIX A. C THE REMAINING USEFUL COLUMNS FORM A BASE OF MATRIX A. C (4) IF THE PROCEDURE WAS SUCCESSFUL, ERROR PARAMETER IER C IS SET TO 0. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C HOUSEHOLDER TRANSFORMATIONS ARE USED TO TRANSFORM MATRIX A C TO UPPER TRIANGULAR FORM. AFTER HAVING APPLIED THE SAME C TRANSFORMATION TO THE RIGHT HAND SIDE MATRIX B, AN C APPROXIMATE SOLUTION OF THE PROBLEM IS COMPUTED BY C BACK SUBSTITUTION. FOR REFERENCE, SEE C G. GOLUB, NUMERICAL METHODS FOR SOLVING LINEAR LEAST C SQUARES PROBLEMS, NUMERISCHE MATHEMATIK, VOL.7, C ISS.3 (1965), PP.206-216. C C .................................................................. C SUBROUTINE DLLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX) C DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1) DOUBLE PRECISION A,B,X,AUX,PIV,H,SIG,BETA,TOL C C ERROR TEST IF(M-N)30,1,1 C C GENERATION OF INITIAL VECTOR S(K) (K=1,2,...,N) IN STORAGE C LOCATIONS AUX(K) (K=1,2,...,N) 1 PIV=0.D0 IEND=0 DO 4 K=1,N IPIV(K)=K H=0.D0 IST=IEND+1 IEND=IEND+M DO 2 I=IST,IEND 2 H=H+A(I)*A(I) AUX(K)=H IF(H-PIV)4,4,3 3 PIV=H KPIV=K 4 CONTINUE C C ERROR TEST IF(PIV)31,31,5 C C DEFINE TOLERANCE FOR CHECKING RANK OF A 5 SIG=DSQRT(PIV) TOL=SIG*ABS(EPS) C C C DECOMPOSITION LOOP LM=L*M IST=-M DO 21 K=1,N IST=IST+M+1 IEND=IST+M-K I=KPIV-K IF(I)8,8,6 C C INTERCHANGE K-TH COLUMN OF A WITH KPIV-TH IN CASE KPIV.GT.K 6 H=AUX(K) AUX(K)=AUX(KPIV) AUX(KPIV)=H ID=I*M DO 7 I=IST,IEND J=I+ID H=A(I) A(I)=A(J) 7 A(J)=H C C COMPUTATION OF PARAMETER SIG 8 IF(K-1)11,11,9 9 SIG=0.D0 DO 10 I=IST,IEND 10 SIG=SIG+A(I)*A(I) SIG=DSQRT(SIG) C C TEST ON SINGULARITY IF(SIG-TOL)32,32,11 C C GENERATE CORRECT SIGN OF PARAMETER SIG 11 H=A(IST) IF(H)12,13,13 12 SIG=-SIG C C SAVE INTERCHANGE INFORMATION 13 IPIV(KPIV)=IPIV(K) IPIV(K)=KPIV C C GENERATION OF VECTOR UK IN K-TH COLUMN OF MATRIX A AND OF C PARAMETER BETA BETA=H+SIG A(IST)=BETA BETA=1.D0/(SIG*BETA) J=N+K AUX(J)=-SIG IF(K-N)14,19,19 C C TRANSFORMATION OF MATRIX A 14 PIV=0.D0 ID=0 JST=K+1 KPIV=JST DO 18 J=JST,N ID=ID+M H=0.D0 DO 15 I=IST,IEND II=I+ID 15 H=H+A(I)*A(II) H=BETA*H DO 16 I=IST,IEND II=I+ID 16 A(II)=A(II)-A(I)*H C C UPDATING OF ELEMENT S(J) STORED IN LOCATION AUX(J) II=IST+ID H=AUX(J)-A(II)*A(II) AUX(J)=H IF(H-PIV)18,18,17 17 PIV=H KPIV=J 18 CONTINUE C C TRANSFORMATION OF RIGHT HAND SIDE MATRIX B 19 DO 21 J=K,LM,M H=0.D0 IEND=J+M-K II=IST DO 20 I=J,IEND H=H+A(II)*B(I) 20 II=II+1 H=BETA*H II=IST DO 21 I=J,IEND B(I)=B(I)-A(II)*H 21 II=II+1 C END OF DECOMPOSITION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE IER=0 I=N LN=L*N PIV=1.D0/AUX(2*N) DO 22 K=N,LN,N X(K)=PIV*B(I) 22 I=I+M IF(N-1)26,26,23 23 JST=(N-1)*M+N DO 25 J=2,N JST=JST-M-1 K=N+N+1-J PIV=1.D0/AUX(K) KST=K-N ID=IPIV(KST)-KST IST=2-J DO 25 K=1,L H=B(KST) IST=IST+N IEND=IST+J-2 II=JST DO 24 I=IST,IEND II=II+M 24 H=H-A(II)*X(I) I=IST-1 II=I+ID X(I)=X(II) X(II)=PIV*H 25 KST=KST+M C C C COMPUTATION OF LEAST SQUARES 26 IST=N+1 IEND=0 DO 29 J=1,L IEND=IEND+M H=0.D0 IF(M-N)29,29,27 27 DO 28 I=IST,IEND 28 H=H+B(I)*B(I) IST=IST+M 29 AUX(J)=H RETURN C C ERROR RETURN IN CASE M LESS THAN N 30 IER=-2 RETURN C C ERROR RETURN IN CASE OF ZERO-MATRIX A 31 IER=-1 RETURN C C ERROR RETURN IN CASE OF RANK OF MATRIX A LESS THAN N 32 IER=K-1 RETURN END C C .................................................................. C C SUBROUTINE DMATX C C PURPOSE C COMPUTE MEANS OF VARIABLES IN EACH GROUP AND A POOLED C DISPERSION MATRIX FOR ALL THE GROUPS. NORMALLY THIS SUB- C ROUTINE IS USED IN THE PERFORMANCE OF DISCRIMINANT ANALYSIS. C C USAGE C CALL DMATX (K,M,N,X,XBAR,D,CMEAN) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF GROUPS C M - NUMBER OF VARIABLES (MUST BE THE SAME FOR ALL C GROUPS). C N - INPUT VECTOR OF LENGTH K CONTAINING SAMPLE SIZES OF C GROUPS. C X - INPUT VECTOR CONTAINING DATA IN THE MANNER EQUIVA- C LENT TO A 3-DIMENSIONAL FORTRAN ARRAY, X(1,1,1), C X(2,1,1), X(3,1,1), ETC. THE FIRST SUBSCRIPT IS C CASE NUMBER, THE SECOND SUBSCRIPT IS VARIABLE NUMBER C AND THE THIRD SUBSCRIPT IS GROUP NUMBER. THE C LENGTH OF VECTOR X IS EQUAL TO THE TOTAL NUMBER OF C DATA POINTS, T*M, WHERE T = N(1)+N(2)+...+N(K). C XBAR - OUTPUT MATRIX (M X K) CONTAINING MEANS OF VARIABLES C IN K GROUPS. C D - OUTPUT MATRIX (M X M) CONTAINING POOLED DISPERSION. C CMEAN - WORKING VECTOR OF LENGTH M. C C REMARKS C THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO C THE NUMBER OF GROUPS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J. C DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO C MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS, C 1958, SECTION 6.6-6.8. C C .................................................................. C SUBROUTINE DMATX (K,M,N,X,XBAR,D,CMEAN) DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION XBAR,D,CMEAN C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C INITIALIZATION C MM=M*M DO 100 I=1,MM 100 D(I)=0.0 C C CALCULATE MEANS C N4=0 L=0 LM=0 DO 160 NG=1,K N1=N(NG) FN=N1 DO 130 J=1,M LM=LM+1 XBAR(LM)=0.0 DO 120 I=1,N1 L=L+1 120 XBAR(LM)=XBAR(LM)+X(L) 130 XBAR(LM)=XBAR(LM)/FN C C CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS C LMEAN=LM-M DO 150 I=1,N1 LL=N4+I-N1 DO 140 J=1,M LL=LL+N1 N2=LMEAN+J 140 CMEAN(J)=X(LL)-XBAR(N2) LL=0 DO 150 J=1,M DO 150 JJ=1,M LL=LL+1 150 D(LL)=D(LL)+CMEAN(J)*CMEAN(JJ) 160 N4=N4+N1*M C C CALCULATE THE POOLED DISPERSION MATRIX C LL=-K DO 170 I=1,K 170 LL=LL+N(I) FN=LL DO 180 I=1,MM 180 D(I)=D(I)/FN C RETURN END C C .................................................................. C C SUBROUTINE DMCHB C C PURPOSE C FOR A GIVEN POSITIVE-DEFINITE M BY M MATRIX A WITH SYMMETRIC C BAND STRUCTURE AND - IF NECESSARY - A GIVEN GENERAL M BY N C MATRIX R, THE FOLLOWING CALCULATIONS (DEPENDENT ON THE C VALUE OF THE DECISION PARAMETER IOP) ARE PERFORMED C (1) MATRIX A IS FACTORIZED (IF IOP IS NOT NEGATIVE), THAT C MEANS BAND MATRIX TU WITH UPPER CODIAGONALS ONLY IS C GENERATED ON THE LOCATIONS OF A SUCH THAT C TRANSPOSE(TU)*TU=A. C (2) MATRIX R IS MULTIPLIED ON THE LEFT BY INVERSE(TU) C AND/OR INVERSE(TRANSPOSE(TU)) AND THE RESULT IS STORED C IN THE LOCATIONS OF R. C THIS SUBROUTINE ESPECIALLY CAN BE USED TO SOLVE THE SYSTEM C OF SIMULTANEOUS LINEAR EQUATIONS A*X=R WITH POSITIVE- C DEFINITE COEFFICIENT MATRIX A OF SYMMETRIC BAND STRUCTURE. C C USAGE C CALL DMCHB (R,A,M,N,MUD,IOP,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - INPUT IN CASES IOP=-3,-2,-1,1,2,3 DOUBLE PRECISION C M BY N RIGHT HAND SIDE MATRIX, C IN CASE IOP=0 IRRELEVANT. C OUTPUT IN CASES IOP=1,-1 INVERSE(A)*R, C IN CASES IOP=2,-2 INVERSE(TU)*R, C IN CASES IOP=3,-3 INVERSE(TRANSPOSE(TU))*R, C IN CASE IOP=0 UNCHANGED. C A - INPUT IN CASES IOP=0,1,2,3 DOUBLE PRECISION M BY M C POSITIVE-DEFINITE COEFFICIENT MATRIX OF C SYMMETRIC BAND STRUCTURE STORED IN C COMPRESSED FORM (SEE REMARKS), C IN CASES IOP=-1,-2,-3 DOUBLE PRECISION M BY M C BAND MATRIX TU WITH UPPER CODIAGONALS ONLY, C STORED IN COMPRESSED FORM (SEE REMARKS). C OUTPUT IN ALL CASES BAND MATRIX TU WITH UPPER C CODIAGONALS ONLY, STORED IN COMPRESSED FORM C (THAT MEANS UNCHANGED IF IOP=-1,-2,-3). C M - INPUT VALUE SPECIFYING THE NUMBER OF ROWS AND C COLUMNS OF A AND THE NUMBER OF ROWS OF R. C N - INPUT VALUE SPECIFYING THE NUMBER OF COLUMNS OF R C (IRRELEVANT IN CASE IOP=0). C MUD - INPUT VALUE SPECIFYING THE NUMBER OF UPPER C CODIAGONALS OF A. C IOP - ONE OF THE VALUES -3,-2,-1,0,1,2,3 GIVEN AS INPUT C AND USED AS DECISION PARAMETER. C EPS - SINGLE PRECISION INPUT VALUE USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANT DIGITS. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT C PARAMETERS M,MUD,IOP (SEE REMARKS), C OR BECAUSE OF A NONPOSITIVE RADICAND AT C SOME FACTORIZATION STEP, C OR BECAUSE OF A ZERO DIAGONAL ELEMENT C AT SOME DIVISION STEP. C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT FACTORIZATION STEP K+1 C WHERE RADICAND WAS NO LONGER GREATER C THAN EPS*A(K+1,K+1). C C REMARKS C UPPER PART OF SYMMETRIC BAND MATRIX A CONSISTING OF MAIN C DIAGONAL AND MUD UPPER CODIAGONALS (RESP. BAND MATRIX TU C CONSISTING OF MAIN DIAGONAL AND MUD UPPER CODIAGONALS) C IS ASSUMED TO BE STORED IN COMPRESSED FORM, I.E. ROWWISE C IN TOTALLY NEEDED M+MUD*(2M-MUD-1)/2 SUCCESSIVE STORAGE C LOCATIONS. ON RETURN UPPER BAND FACTOR TU (ON THE LOCATIONS C OF A) IS STORED IN THE SAME WAY. C RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE C IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN RESULT MATRIX C INVERSE(A)*R OR INVERSE(TU)*R OR INVERSE(TRANSPOSE(TU))*R C IS STORED COLUMNWISE TOO ON THE LOCATIONS OF R. C INPUT PARAMETERS M, MUD, IOP SHOULD SATISFY THE FOLLOWING C RESTRICTIONS MUD NOT LESS THAN ZERO, C 1+MUD NOT GREATER THAN M, C ABS(IOP) NOT GREATER THAN 3. C NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE C RESTRICTIONS ARE NOT SATISFIED. C THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT C PARAMETERS ARE SATISFIED, IF RADICANDS AT ALL FACTORIZATION C STEPS ARE POSITIVE AND/OR IF ALL DIAGONAL ELEMENTS OF C UPPER BAND FACTOR TU ARE NONZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C FACTORIZATION IS DONE USING CHOLESKY-S SQUARE-ROOT METHOD, C WHICH GENERATES THE UPPER BAND MATRIX TU SUCH THAT C TRANSPOSE(TU)*TU=A. TU IS RETURNED AS RESULT ON THE C LOCATIONS OF A. FURTHER, DEPENDENT ON THE ACTUAL VALUE OF C IOP, DIVISION OF R BY TRANSPOSE(TU) AND/OR TU IS PERFORMED C AND THE RESULT IS RETURNED ON THE LOCATIONS OF R. C FOR REFERENCE, SEE H. RUTISHAUSER, ALGORITHMUS 1 - LINEARES C GLEICHUNGSSYSTEM MIT SYMMETRISCHER POSITIV-DEFINITER C BANDMATRIX NACH CHOLESKY - , COMPUTING (ARCHIVES FOR C ELECTRONIC COMPUTING), VOL.1, ISS.1 (1966), PP.77-78. C C .................................................................. C c SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER) cC cC c DIMENSION R(1),A(1) c DOUBLE PRECISION TOL,SUM,PIV,R,A cC cC TEST ON WRONG INPUT PARAMETERS c IF(IABS(IOP)-3)1,1,43 c1 IF(MUD)43,2,2 c2 MC=MUD+1 c IF(M-MC)43,3,3 c3 MR=M-MUD c IER=0 cC cC MC IS THE MAXIMUM NUMBER OF ELEMENTS IN THE ROWS OF ARRAY A cC MR IS THE INDEX OF THE LAST ROW IN ARRAY A WITH MC ELEMENTS cC cC ****************************************************************** cC cC START FACTORIZATION OF MATRIX A c IF(IOP)24,4,4 c4 IEND=0 c LLDST=MUD c DO 23 K=1,M c IST=IEND+1 c IEND=IST+MUD c J=K-MR c IF(J)6,6,5 c5 IEND=IEND-J c6 IF(J-1)8,8,7 c7 LLDST=LLDST-1 c8 LMAX=MUD c J=MC-K c IF(J)10,10,9 c9 LMAX=LMAX-J c10 ID=0 c TOL=A(IST)*EPS cC cC START FACTORIZATION-LOOP OVER K-TH ROW c DO 23 I=IST,IEND c SUM=0.D0 c IF(LMAX)14,14,11 cC cC PREPARE INNER LOOP c11 LL=IST c LLD=LLDST cC cC START INNER LOOP c DO 13 L=1,LMAX c LL=LL-LLD c LLL=LL+ID c SUM=SUM+A(LL)*A(LLL) c IF(LLD-MUD)12,13,13 c12 LLD=LLD+1 c13 CONTINUE SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER) DIMENSION R(1),A(1) DOUBLE PRECISION TOL,SUM,PIV,R,A IF(IABS(IOP)-3)1,1,43 1 IF(MUD)43,2,2 2 MC=MUD+1 IF(M-MC)43,3,3 3 MR=M-MUD IER=0 IF(IOP)24,4,4 4 IEND=0 LLDST=MUD DO 23 K=1,M IST=IEND+1 IEND=IST+MUD J=K-MR IF(J)6,6,5 5 IEND=IEND-J 6 IF(J-1)8,8,7 7 LLDST=LLDST-1 8 LMAX=MUD J=MC-K IF(J)10,10,9 9 LMAX=LMAX-J 10 ID=0 TOL=A(IST)*EPS DO 23 I=IST,IEND SUM=0.D0 IF(LMAX)14,14,11 11 LL=IST LLD=LLDST DO 13 L=1,LMAX LL=LL-LLD LLL=LL+ID SUM=SUM+A(LL)*A(LLL) IF(LLD-MUD)12,13,13 12 LLD=LLD+1 13 CONTINUE 14 SUM=A(I)-SUM IF(I-IST)15,15,20 15 IF(SUM)43,43,16 16 IF(SUM-TOL)17,17,19 17 IF(IER)18,18,19 18 IER=K-1 19 PIV=DSQRT(SUM) A(I)=PIV PIV=1.D0/PIV GO TO 21 20 A(I)=SUM*PIV 21 ID=ID+1 IF(ID-J)23,23,22 22 LMAX=LMAX-1 23 CONTINUE IF(IOP)24,44,24 24 ID=N*M IEND=IABS(IOP)-2 IF(IEND)25,35,25 25 IST=1 LMAX=0 J=-MR LLDST=MUD DO 34 K=1,M PIV=A(IST) IF(PIV)26,43,26 26 PIV=1.D0/PIV DO 30 I=K,ID,M SUM=0.D0 IF(LMAX)30,30,27 27 LL=IST LLL=I LLD=LLDST DO 29 L=1,LMAX LL=LL-LLD LLL=LLL-1 SUM=SUM+A(LL)*R(LLL) IF(LLD-MUD)28,29,29 28 LLD=LLD+1 29 CONTINUE 30 R(I)=PIV*(R(I)-SUM) IF(MC-K)32,32,31 31 LMAX=K 32 IST=IST+MC J=J+1 IF(J)34,34,33 33 IST=IST-J LLDST=LLDST-1 34 CONTINUE IF(IEND)35,35,44 35 IST=M+(MUD*(M+M-MC))/2+1 LMAX=0 K=M 36 IEND=IST-1 IST=IEND-LMAX PIV=A(IST) IF(PIV)37,43,37 37 PIV=1.D0/PIV L=IST+1 DO 40 I=K,ID,M SUM=0.D0 IF(LMAX)40,40,38 38 LLL=I DO 39 LL=L,IEND LLL=LLL+1 39 SUM=SUM+A(LL)*R(LLL) 40 R(I)=PIV*(R(I)-SUM) IF(K-MR)42,42,41 41 LMAX=LMAX+1 42 K=K-1 IF(K)44,44,36 43 IER=-1 44 RETURN END C C .................................................................. C C SUBROUTINE DMFGR C C PURPOSE C FOR A GIVEN M BY N MATRIX THE FOLLOWING CALCULATIONS C ARE PERFORMED C (1) DETERMINE RANK AND LINEARLY INDEPENDENT ROWS AND C COLUMNS (BASIS). C (2) FACTORIZE A SUBMATRIX OF MAXIMAL RANK. C (3) EXPRESS NON-BASIC ROWS IN TERMS OF BASIC ONES. C (4) EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES. C C USAGE C CALL DMFGR(A,M,N,EPS,IRANK,IROW,ICOL) C C DESCRIPTION OF PARAMETERS C A - DOUBLE PRECISION GIVEN MATRIX WITH M ROWS C AND N COLUMNS. C ON RETURN A CONTAINS THE TRIANGULAR FACTORS C OF A SUBMATRIX OF MAXIMAL RANK. C M - NUMBER OF ROWS OF MATRIX A. C N - NUMBER OF COLUMNS OF MATRIX A. C EPS - SINGLE PRECISION TESTVALUE FOR ZERO AFFECTED BY C ROUNDOFF NOISE. C IRANK - RESULTANT RANK OF GIVEN MATRIX. C IROW - INTEGER VECTOR OF DIMENSION M CONTAINING THE C SUBSCRIPTS OF BASIC ROWS IN IROW(1),...,IROW(IRANK) C ICOL - INTEGER VECTOR OF DIMENSION N CONTAINING THE C SUBSCRIPTS OF BASIC COLUMNS IN ICOL(1) UP TO C ICOL(IRANK). C C REMARKS C THE LEFT HAND TRIANGULAR FACTOR IS NORMALIZED SUCH THAT C THE DIAGONAL CONTAINS ALL ONES THUS ALLOWING TO STORE ONLY C THE SUBDIAGONAL PART. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C GAUSSIAN ELIMINATION TECHNIQUE IS USED FOR CALCULATION C OF THE TRIANGULAR FACTORS OF A GIVEN MATRIX. C COMPLETE PIVOTING IS BUILT IN. C IN CASE OF A SINGULAR MATRIX ONLY THE TRIANGULAR FACTORS C OF A SUBMATRIX OF MAXIMAL RANK ARE RETAINED. C THE REMAINING PARTS OF THE RESULTANT MATRIX GIVE THE C DEPENDENCIES OF ROWS AND THE SOLUTION OF THE HOMOGENEOUS C MATRIX EQUATION A*X=0. C C .................................................................. C SUBROUTINE DMFGR(A,M,N,EPS,IRANK,IROW,ICOL) C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),IROW(1),ICOL(1) DOUBLE PRECISION A,PIV,HOLD,SAVE C C TEST OF SPECIFIED DIMENSIONS IF(M)2,2,1 1 IF(N)2,2,4 2 IRANK=-1 3 RETURN C RETURN IN CASE OF FORMAL ERRORS C C C INITIALIZE COLUMN INDEX VECTOR C SEARCH FIRST PIVOT ELEMENT 4 IRANK=0 PIV=0.D0 JJ=0 DO 6 J=1,N ICOL(J)=J DO 6 I=1,M JJ=JJ+1 HOLD=A(JJ) IF(DABS(PIV)-DABS(HOLD))5,6,6 5 PIV=HOLD IR=I IC=J 6 CONTINUE C C INITIALIZE ROW INDEX VECTOR DO 7 I=1,M 7 IROW(I)=I C C SET UP INTERNAL TOLERANCE TOL=ABS(EPS*SNGL(PIV)) C C INITIALIZE ELIMINATION LOOP NM=N*M DO 19 NCOL=M,NM,M C C TEST FOR FEASIBILITY OF PIVOT ELEMENT 8 IF(ABS(SNGL(PIV))-TOL)20,20,9 C C UPDATE RANK 9 IRANK=IRANK+1 C C INTERCHANGE ROWS IF NECESSARY JJ=IR-IRANK IF(JJ)12,12,10 10 DO 11 J=IRANK,NM,M I=J+JJ SAVE=A(J) A(J)=A(I) 11 A(I)=SAVE C C UPDATE ROW INDEX VECTOR JJ=IROW(IR) IROW(IR)=IROW(IRANK) IROW(IRANK)=JJ C C INTERCHANGE COLUMNS IF NECESSARY 12 JJ=(IC-IRANK)*M IF(JJ)15,15,13 13 KK=NCOL DO 14 J=1,M I=KK+JJ SAVE=A(KK) A(KK)=A(I) KK=KK-1 14 A(I)=SAVE C C UPDATE COLUMN INDEX VECTOR JJ=ICOL(IC) ICOL(IC)=ICOL(IRANK) ICOL(IRANK)=JJ 15 KK=IRANK+1 MM=IRANK-M LL=NCOL+MM C C TEST FOR LAST ROW IF(MM)16,25,25 C C TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT 16 JJ=LL SAVE=PIV PIV=0.D0 DO 19 J=KK,M JJ=JJ+1 HOLD=A(JJ)/SAVE A(JJ)=HOLD L=J-IRANK C C TEST FOR LAST COLUMN IF(IRANK-N)17,19,19 17 II=JJ DO 19 I=KK,N II=II+M MM=II-L A(II)=A(II)-HOLD*A(MM) IF(DABS(A(II))-DABS(PIV))19,19,18 18 PIV=A(II) IR=J IC=I 19 CONTINUE C C SET UP MATRIX EXPRESSING ROW DEPENDENCIES 20 IF(IRANK-1)3,25,21 21 IR=LL DO 24 J=2,IRANK II=J-1 IR=IR-M JJ=LL DO 23 I=KK,M HOLD=0.D0 JJ=JJ+1 MM=JJ IC=IR DO 22 L=1,II HOLD=HOLD+A(MM)*A(IC) IC=IC-1 22 MM=MM-M 23 A(MM)=A(MM)-HOLD 24 CONTINUE C C TEST FOR COLUMN REGULARITY 25 IF(N-IRANK)3,3,26 C C SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE C PARAMETERS (HOMOGENEOUS SOLUTION). 26 IR=LL KK=LL+M DO 30 J=1,IRANK DO 29 I=KK,NM,M JJ=IR LL=I HOLD=0.D0 II=J 27 II=II-1 IF(II)29,29,28 28 HOLD=HOLD-A(JJ)*A(LL) JJ=JJ-M LL=LL-1 GOTO 27 29 A(LL)=(HOLD-A(LL))/A(JJ) 30 IR=IR-1 RETURN END C C .................................................................. C C SUBROUTINE DMFSD C C PURPOSE C FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX C C USAGE C CALL DMFSD(A,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C A - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN C SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT C MATRIX. C ON RETURN A CONTAINS THE RESULTANT UPPER C TRIANGULAR MATRIX IN DOUBLE PRECISION. C N - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX. C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED C AS RELATIVE TOLERANCE FOR TEST ON LOSS OF C SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TER N OR BECAUSE SOME RADICAND IS NON- C POSITIVE (MATRIX A IS NOT POSITIVE C DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI- C FICANCE) C IER=K - WARNING WHICH INDICATES LOSS OF SIGNIFI- C CANCE. THE RADICAND FORMED AT FACTORIZA- C TION STEP K+1 WAS STILL POSITIVE BUT NO C LONGER GREATER THAN ABS(EPS*A(K+1,K+1)). C C REMARKS C THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE C STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS. C IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU- C LAR MATRIX IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL C CALCULATED RADICANDS ARE POSITIVE. C THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE C SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY. C THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR C MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF C THE RETURNED RIGHT HAND FACTOR. C C .................................................................. C SUBROUTINE DMFSD(A,N,EPS,IER) C C DIMENSION A(1) DOUBLE PRECISION DPIV,DSUM,A C C TEST ON WRONG INPUT PARAMETER N IF(N-1) 12,1,1 1 IER=0 C C INITIALIZE DIAGONAL-LOOP KPIV=0 DO 11 K=1,N KPIV=KPIV+K IND=KPIV LEND=K-1 C C CALCULATE TOLERANCE TOL=ABS(EPS*SNGL(A(KPIV))) C C START FACTORIZATION-LOOP OVER K-TH ROW DO 11 I=K,N DSUM=0.D0 IF(LEND) 2,4,2 C C START INNER LOOP 2 DO 3 L=1,LEND LANF=KPIV-L LIND=IND-L 3 DSUM=DSUM+A(LANF)*A(LIND) C END OF INNER LOOP C C TRANSFORM ELEMENT A(IND) 4 DSUM=A(IND)-DSUM IF(I-K) 10,5,10 C C TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE 5 IF(SNGL(DSUM)-TOL) 6,6,9 6 IF(DSUM) 12,12,7 7 IF(IER) 8,8,9 8 IER=K-1 C C COMPUTE PIVOT ELEMENT 9 DPIV=DSQRT(DSUM) A(KPIV)=DPIV DPIV=1.D0/DPIV GO TO 11 C C CALCULATE TERMS IN ROW 10 A(IND)=DSUM*DPIV 11 IND=IND+I C END OF DIAGONAL-LOOP C RETURN 12 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DMFSS C C PURPOSE C GIVEN A SYMMETRIC POSITIVE SEMI DEFINITE MATRIX ,DMFSS WILL C (1) DETERMINE THE RANK AND LINEARLY INDEPENDENT ROWS AND C COLUMNS C (2) FACTOR A SYMMETRIC SUBMATRIX OF MAXIMAL RANK C (3) EXPRESS NONBASIC ROWS IN TERMS OF BASIC ONES, C EXPRESS NONBASIC COLUMNS IN TERMS OF BASIC ONES C EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES C SUBROUTINE DMFSS MAY BE USED AS A PREPARATORY STEP FOR THE C CALCULATION OF THE LEAST SQUARES SOLUTION OF MINIMAL C LENGTH OF A SYSTEM OF LINEAR EQUATIONS WITH SYMMETRIC C POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX C C USAGE C CALL DMFSS(A,N,EPS,IRANK,TRAC) C C DESCRIPTION OF PARAMETERS C A - UPPER TRIANGULAR PART OF GIVEN SYMMETRIC SEMI- C DEFINITE MATRIX STORED COLUMNWISE IN COMPRESSED FORM C ON RETURN A CONTAINS THE MATRIX T AND, IF IRANK IS C LESS THAN N, THE MATRICES U AND TU C A MUST BE OF DOUBLE PRECISION C N - DIMENSION OF GIVEN MATRIX A C EPS - TESTVALUE FOR ZERO AFFECTED BY ROUND-OFF NOISE C IRANK - RESULTANT VARIABLE, CONTAINING THE RANK OF GIVEN C MATRIX A IF A IS SEMI-DEFINITE C IRANK = 0 MEANS A HAS NO POSITIVE DIAGONAL ELEMENT C AND/OR EPS IS NOT ABSOLUTELY LESS THAN ONE C IRANK =-1 MEANS DIMENSION N IS NOT POSITIVE C IRANK =-2 MEANS COMPLETE FAILURE, POSSIBLY DUE TO C INADEQUATE RELATIVE TOLERANCE EPS C TRAC - VECTOR OF DIMENSION N CONTAINING THE C SOURCE INDEX OF THE I-TH PIVOT ROW IN ITS I-TH C LOCATION, THIS MEANS THAT TRAC CONTAINS THE C PRODUCT REPRESENTATION OF THE PERMUTATION WHICH C IS APPLIED TO ROWS AND COLUMNS OF A IN TERMS OF C TRANSPOSITIONS C TRAC MUST BE OF DOUBLE PRECISION C C REMARKS C EPS MUST BE ABSOLUTELY LESS THAN ONE. A SENSIBLE VALUE IS C SOMEWHERE IN BETWEEN 10**(-4) AND 10**(-6) C THE ABSOLUTE VALUE OF INPUT PARAMETER EPS IS USED AS C RELATIVE TOLERANCE. C IN ORDER TO PRESERVE SYMMETRY ONLY PIVOTING ALONG THE C DIAGONAL IS BUILT IN. C ALL PIVOTELEMENTS MUST BE GREATER THAN THE ABSOLUTE VALUE C OF EPS TIMES ORIGINAL DIAGONAL ELEMENT C OTHERWISE THEY ARE TREATED AS IF THEY WERE ZERO C MATRIX A REMAINS UNCHANGED IF THE RESULTANT VALUE IRANK C EQUALS ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE SQUARE ROOT METHOD WITH DIAGONAL PIVOTING IS USED FOR C CALCULATION OF THE RIGHT HAND TRIANGULAR FACTOR. C IN CASE OF AN ONLY SEMI-DEFINITE MATRIX THE SUBROUTINE C RETURNS THE IRANK X IRANK UPPER TRIANGULAR FACTOR T OF A C SUBMATRIX OF MAXIMAL RANK, THE IRANK X (N-IRANK) MATRIX U C AND THE (N-IRANK) X (N-IRANK) UPPER TRIANGULAR TU SUCH C THAT TRANSPOSE(TU)*TU=I+TRANSPOSE(U)*U C C .................................................................. C SUBROUTINE DMFSS(A,N,EPS,IRANK,TRAC) C C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),TRAC(1) DOUBLE PRECISION SUM,A,TRAC,PIV,HOLD C C TEST OF SPECIFIED DIMENSION IF(N)36,36,1 C C INITIALIZE TRIANGULAR FACTORIZATION 1 IRANK=0 ISUB=0 KPIV=0 J=0 PIV=0.D0 C C SEARCH FIRST PIVOT ELEMENT DO 3 K=1,N J=J+K TRAC(K)=A(J) IF(A(J)-PIV)3,3,2 2 PIV=A(J) KSUB=J KPIV=K 3 CONTINUE C C START LOOP OVER ALL ROWS OF A DO 32 I=1,N ISUB=ISUB+I IM1=I-1 4 KMI=KPIV-I IF(KMI)35,9,5 C C PERFORM PARTIAL COLUMN INTERCHANGE 5 JI=KSUB-KMI IDC=JI-ISUB JJ=ISUB-IM1 DO 6 K=JJ,ISUB KK=K+IDC HOLD=A(K) A(K)=A(KK) 6 A(KK)=HOLD C C PERFORM PARTIAL ROW INTERCHANGE KK=KSUB DO 7 K=KPIV,N II=KK-KMI HOLD=A(KK) A(KK)=A(II) A(II)=HOLD 7 KK=KK+K C C PERFORM REMAINING INTERCHANGE JJ=KPIV-1 II=ISUB DO 8 K=I,JJ HOLD=A(II) A(II)=A(JI) A(JI)=HOLD II=II+K 8 JI=JI+1 9 IF(IRANK)22,10,10 C C RECORD INTERCHANGE IN TRANSPOSITION VECTOR 10 TRAC(KPIV)=TRAC(I) TRAC(I)=KPIV C C MODIFY CURRENT PIVOT ROW KK=IM1-IRANK KMI=ISUB-KK PIV=0.D0 IDC=IRANK+1 JI=ISUB-1 JK=KMI JJ=ISUB-I DO 19 K=I,N SUM=0.D0 C C BUILD UP SCALAR PRODUCT IF NECESSARY IF(KK)13,13,11 11 DO 12 J=KMI,JI SUM=SUM-A(J)*A(JK) 12 JK=JK+1 13 JJ=JJ+K IF(K-I)14,14,16 14 SUM=A(ISUB)+SUM C C TEST RADICAND FOR LOSS OF SIGNIFICANCE IF(SUM-DABS(A(ISUB)*DBLE(EPS)))20,20,15 15 A(ISUB)=DSQRT(SUM) KPIV=I+1 GOTO 19 16 SUM=(A(JK)+SUM)/A(ISUB) A(JK)=SUM C C SEARCH FOR NEXT PIVOT ROW IF(A(JJ))19,19,17 17 TRAC(K)=TRAC(K)-SUM*SUM HOLD=TRAC(K)/A(JJ) IF(PIV-HOLD)18,19,19 18 PIV=HOLD KPIV=K KSUB=JJ 19 JK=JJ+IDC GOTO 32 C C CALCULATE MATRIX OF DEPENDENCIES U 20 IF(IRANK)21,21,37 21 IRANK=-1 GOTO 4 22 IRANK=IM1 II=ISUB-IRANK JI=II DO 26 K=1,IRANK JI=JI-1 JK=ISUB-1 JJ=K-1 DO 26 J=I,N IDC=IRANK SUM=0.D0 KMI=JI KK=JK IF(JJ)25,25,23 23 DO 24 L=1,JJ IDC=IDC-1 SUM=SUM-A(KMI)*A(KK) KMI=KMI-IDC 24 KK=KK-1 25 A(KK)=(SUM+A(KK))/A(KMI) 26 JK=JK+J C C CALCULATE I+TRANSPOSE(U)*U JJ=ISUB-I PIV=0.D0 KK=ISUB-1 DO 31 K=I,N JJ=JJ+K IDC=0 DO 28 J=K,N SUM=0.D0 KMI=JJ+IDC DO 27 L=II,KK JK=L+IDC 27 SUM=SUM+A(L)*A(JK) A(KMI)=SUM 28 IDC=IDC+J A(JJ)=A(JJ)+1.D0 TRAC(K)=A(JJ) C C SEARCH NEXT DIAGONAL ELEMENT IF(PIV-A(JJ))29,30,30 29 KPIV=K KSUB=JJ PIV=A(JJ) 30 II=II+K KK=KK+K 31 CONTINUE GOTO 4 32 CONTINUE 33 IF(IRANK)35,34,35 34 IRANK=N 35 RETURN C C ERROR RETURNS C C RETURN IN CASE OF ILLEGAL DIMENSION 36 IRANK=-1 RETURN C C INSTABLE FACTORIZATION OF I+TRANSPOSE(U)*U 37 IRANK=-2 RETURN END C C .................................................................. C C SUBROUTINE DMLSS C C PURPOSE C SUBROUTINE DMLSS IS THE SECOND STEP IN THE PROCEDURE FOR C CALCULATING THE LEAST SQUARES SOLUTION OF MINIMAL LENGTH C OF A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH SYMMETRIC C POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX. C C USAGE C CALL DMLSS(A,N,IRANK,TRAC,INC,RHS,IER) C C DESCRIPTION OF PARAMETERS C A - COEFFICIENT MATRIX IN FACTORED FORM AS GENERATED C BY SUBROUTINE MFSS FROM INITIALLY GIVEN SYMMETRIC C COEFFICIENT MATRIX A STORED IN N*(N+1)/2 LOCATIONS C A REMAINS UNCHANGED C A MUST BE OF DOUBLE PRECISION C N - DIMENSION OF COEFFICIENT MATRIX C IRANK - RANK OF COEFFICIENT MATRIX, CALCULATED BY MEANS OF C SUBROUTINE DMFSS C TRAC - VECTOR OF DIMENSION N CONTAINING THE C SUBSCRIPTS OF PIVOT ROWS AND COLUMNS, I.E. THE C PRODUCT REPRESENTATION IN TRANSPOSITIONS OF THE C PERMUTATION WHICH WAS APPLIED TO ROWS AND COLUMNS C OF A IN THE FACTORIZATION PROCESS C TRAC IS A RESULTANT ARRAY OF SUBROUTINE MFSS C TRAC MUST BE OF DOUBLE PRECISION C INC - INPUT VARIABLE WHICH SHOULD CONTAIN THE VALUE ZERO C IF THE SYSTEM OF SIMULTANEOUS EQUATIONS IS KNOWN C TO BE COMPATIBLE AND A NONZERO VALUE OTHERWISE C RHS - VECTOR OF DIMENSION N CONTAINING THE RIGHT HAND SIDE C ON RETURN RHS CONTAINS THE MINIMAL LENGTH SOLUTION C RHS MUST BE OF DOUBLE PRECISION C IER - RESULTANT ERROR PARAMETER C IER = 0 MEANS NO ERRORS C IER =-1 MEANS N AND/OR IRANK IS NOT POSITIVE AND/OR C IRANK IS GREATER THAN N C IER = 1 MEANS THE FACTORIZATION CONTAINED IN A HAS C ZERO DIVISORS AND/OR TRAC CONTAINS C VALUES OUTSIDE THE FEASIBLE RANGE 1 UP TO N C C REMARKS C THE MINIMAL LENGTH SOLUTION IS PRODUCED IN THE STORAGE C LOCATIONS OCCUPIED BY THE RIGHT HAND SIDE. C SUBROUTINE DMLSS DOES TAKE CARE OF THE PERMUTATION C WHICH WAS APPLIED TO ROWS AND COLUMNS OF A. C OPERATION IS BYPASSED IN CASE OF A NON POSITIVE VALUE C OF IRANK C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C LET T, U, TU BE THE COMPONENTS OF THE FACTORIZATION OF A, C AND LET THE RIGHT HAND SIDE BE PARTITIONED INTO A FIRST C PART X1 OF DIMENSION IRANK AND A SECOND PART X2 OF DIMENSION C N-IRANK. THEN THE FOLLOWING OPERATIONS ARE APPLIED IN C SEQUENCE C (1) INTERCHANGE RIGHT HAND SIDE C (2) X1 = X1 + U * X2 C (3) X2 =-TRANSPOSE(U) * X1 C (4) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2 C (5) X1 = X1 + U * X2 C (6) X1 = INVERSE(T) * INVERSE(TRANSPOSE(T)) * X1 C (7) X2 =-TRANSPOSE(U) * X1 C (8) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2 C (9) X1 = X1 + U * X2 C (10)X2 = TRANSPOSE(U) * X1 C (11) REINTERCHANGE CALCULATED SOLUTION C IF THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS IS SPECIFIED C TO BE COMPATIBLE THEN STEPS (2), (3), (4) AND (5) ARE C CANCELLED. C IF THE COEFFICIENT MATRIX HAS RANK N, THEN THE ONLY STEPS C PERFORMED ARE (1), (6) AND (11). C C .................................................................. C SUBROUTINE DMLSS(A,N,IRANK,TRAC,INC,RHS,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),TRAC(1),RHS(1) DOUBLE PRECISION SUM,A,RHS,TRAC,HOLD C C TEST OF SPECIFIED DIMENSIONS IDEF=N-IRANK IF(N)33,33,1 1 IF(IRANK)33,33,2 2 IF(IDEF)33,3,3 C C CALCULATE AUXILIARY VALUES 3 ITE=IRANK*(IRANK+1)/2 IX2=IRANK+1 NP1=N+1 IER=0 C C INTERCHANGE RIGHT HAND SIDE JJ=1 II=1 4 DO 6 I=1,N J=TRAC(II) IF(J)31,31,5 5 HOLD=RHS(II) RHS(II)=RHS(J) RHS(J)=HOLD 6 II=II+JJ IF(JJ)32,7,7 C C PERFORM STEP 2 IF NECESSARY 7 ISW=1 IF(INC*IDEF)8,28,8 C C CALCULATE X1 = X1 + U * X2 8 ISTA=ITE DO 10 I=1,IRANK ISTA=ISTA+1 JJ=ISTA SUM=0.D0 DO 9 J=IX2,N SUM=SUM+A(JJ)*RHS(J) 9 JJ=JJ+J 10 RHS(I)=RHS(I)+SUM GOTO(11,28,11),ISW C C CALCULATE X2 = TRANSPOSE(U) * X1 11 ISTA=ITE DO 15 I=IX2,N JJ=ISTA SUM=0.D0 DO 12 J=1,IRANK JJ=JJ+1 12 SUM=SUM+A(JJ)*RHS(J) GOTO(13,13,14),ISW 13 SUM=-SUM 14 RHS(I)=SUM 15 ISTA=ISTA+I GOTO(16,29,30),ISW C C INITIALIZE STEP (4) OR STEP (8) 16 ISTA=IX2 IEND=N JJ=ITE+ISTA C C DIVISION OF X1 BY TRANSPOSE OF TRIANGULAR MATRIX 17 SUM=0.D0 DO 20 I=ISTA,IEND IF(A(JJ))18,31,18 18 RHS(I)=(RHS(I)-SUM)/A(JJ) IF(I-IEND)19,21,21 19 JJ=JJ+ISTA SUM=0.D0 DO 20 J=ISTA,I SUM=SUM+A(JJ)*RHS(J) 20 JJ=JJ+1 C C DIVISION OF X1 BY TRIANGULAR MATRIX 21 SUM=0.D0 II=IEND DO 24 I=ISTA,IEND RHS(II)=(RHS(II)-SUM)/A(JJ) IF(II-ISTA)25,25,22 22 KK=JJ-1 SUM=0.D0 DO 23 J=II,IEND SUM=SUM+A(KK)*RHS(J) 23 KK=KK+J JJ=JJ-II 24 II=II-1 25 IF(IDEF)26,30,26 26 GOTO(27,11,8),ISW C C PERFORM STEP (5) 27 ISW=2 GOTO 8 C C PERFORM STEP (6) 28 ISTA=1 IEND=IRANK JJ=1 ISW=2 GOTO 17 C C PERFORM STEP (8) 29 ISW=3 GOTO 16 C C REINTERCHANGE CALCULATED SOLUTION 30 II=N JJ=-1 GOTO 4 C C ERROR RETURN IN CASE OF ZERO DIVISOR 31 IER=1 32 RETURN C C ERROR RETURN IN CASE OF ILLEGAL DIMENSION 33 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DMPRC C C PURPOSE C TO PERMUTE THE ROWS OR COLUMNS OF A GIVEN MATRIX ACCORDING C TO A GIVEN TRANSPOSITION VECTOR OR ITS INVERSE. (SEE THE C DISCUSSION ON PERMUTATIONS FOR DEFINITIONS AND NOTATION.) C C USAGE C CALL DMPRC(A,M,N,ITRA,INV,IROCO,IER) C C DESCRIPTION OF PARAMETERS C A - GIVEN DOUBLE PRECISION M BY N MATRIX AND RESULTING C PERMUTED MATRIX C M - NUMBER OF ROWS OF A C N - NUMBER OF COLUMNS OF A C ITRA - GIVEN TRANSPOSITION VECTOR (DIMENSION M IF ROWS ARE C PERMUTED, N IF COLUMNS ARE PERMUTED) C INV - INPUT PARAMETER C INV NON-ZERO - PERMUTE ACCORDING TO ITRA C INV = 0 - PERMUTE ACCORDING TO ITRA INVERSE C IROCO - INPUT PARAMETER C IROCO NON-ZERO - PERMUTE THE COLUMNS OF A C IROCO = 0 - PERMUTE THE ROWS OF A C IER - RESULTING ERROR PARAMETER C IER = -1 - M AND N ARE NOT BOTH POSITIVE C IER = 0 - NO ERROR C IER = 1 - ITRA IS NOT A TRANSPOSITION VECTOR ON C 1,...,M IF ROWS ARE PERMUTED, 1,...,N C IF COLUMNS ARE PERMUTED C C REMARKS C (1) IF IER=-1 THERE IS NO COMPUTATION. C (2) IF IER= 1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE C TO ERROR, BUT THE MATRIX A WILL REFLECT THE ROW OR C COLUMN INTERCHANGES PERFORMED BEFORE THE ERROR WAS C DETECTED. C (3) THE MATRIX A IS ASSUMED TO BE STORED COLUMNWISE. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C THE ROWS OR COLUMNS ARE PERMUTED ELEMENTWISE, INTERCHANGING C ROW OR COLUMN 1 AND ITRA(1),...,ROW OR COLUMN K AND ITRA(K) C IN THAT ORDER IF INV=0, AND OTHERWISE INTERCHANGING ROW OR C COLUMN K AND ITRA(K),...,ROW OR COLUMN 1 AND ITRA(1), WHERE C K IS M OR N DEPENDING ON WHETHER WE PERMUTE ROWS OR COLUMNS. C C .................................................................. C SUBROUTINE DMPRC(A,M,N,ITRA,INV,IROCO,IER) C C DIMENSION A(1),ITRA(1) DOUBLE PRECISION A,SAVE C C TEST OF DIMENSIONS IF(M)14,14,1 1 IF(N)14,14,2 C C DETERMINE WHICH ARE TO BE PERMUTED-THE ROWS OR THE COLUMNS 2 IF(IROCO)3,4,3 C C INITIALIZE FOR COLUMN INTERCHANGES 3 MM=M MMM=-1 L=M LL=N GO TO 5 C C INITIALIZE FOR ROW INTERCHANGES 4 MM=1 MMM=M L=N LL=M C C INITIALIZE LOOP OVER ALL ROWS OR COLUMNS 5 IA=1 ID=1 C C TEST FOR INVERSE OPERATION IF(INV)6,7,6 6 IA=LL ID=-1 7 DO 12 I=1,LL K=ITRA(IA) IF(K-IA)8,12,9 8 IF(K)13,13,10 9 IF(LL-K)13,10,10 C C INITIALIZE ROW OR COLUMN INTERCHANGE 10 IL=IA*MM K=K*MM C C PERFORM ROW OR COLUMN INTERCHANGE DO 11 J=1,L SAVE=A(IL) A(IL)=A(K) A(K)=SAVE K=K+MMM 11 IL=IL+MMM C C ADDRESS NEXT INTERCHANGE STEP 12 IA=IA+ID C C NORMAL EXIT IER=0 RETURN C C ERROR RETURN IN CASE ITRA IS NOT A TRANSPOSITION VECTOR 13 IER=1 RETURN C C ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS 14 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DMTDS C C PURPOSE C MULTIPLY A GENERAL MATRIX A ON THE LEFT OR RIGHT BY C INVERSE(T),INVERSE(TRANSPOSE(T)) OR INVERSE(TRANSPOSE(T*T)) C THE TRIANGULAR MATRIX T IS STORED COLUMNWISE IN COMPRESSED C FORM, I.E. UPPER TRIANGULAR PART ONLY. C C USAGE C CALL DMTDS(A,M,N,T,IOP,IER) C C DESCRIPTION OF PARAMETERS C A - GIVEN GENERAL MATRIX WITH M ROWS AND N COLUMNS. C A MUST BE OF DOUBLE PRECISION C M - NUMBER OF ROWS OF MATRIX A C N - NUMBER OF COLUMNS OF MATRIX A C T - GIVEN TRIANGULAR MATRIX STORED COLUMNWISE UPPER C TRIANGULAR PART ONLY. ITS NUMBER OF ROWS AND C COLUMNS K IS IMPLIED BY COMPATIBILITY. C K = M IF IOP IS POSITIVE, C K = N IF IOP IS NEGATIVE. C T OCCUPIES K*(K+1)/2 STORAGE POSITIONS. C T MUST BE OF DOUBLE PRECISION C IOP - INPUT VARIABLE FOR SELECTION OF OPERATION C IOP = 1 - A IS REPLACED BY INVERSE(T)*A C IOP =-1 - A IS REPLACED BY A*INVERSE(T) C IOP = 2 - A IS REPLACED BY INVERSE(TRANSPOSE(T))*A C IOP =-2 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)) C IOP = 3 - A IS REPLACED BY INVERSE(TRANSPOSE(T)*T)*A C IOP =-3 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)*T) C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS M AND N ARE NOT BOTH POSITIVE C AND/OR IOP IS ILLEGAL C IER = 0 MEANS OPERATION WAS SUCCESSFUL C IER = 1 MEANS TRIANGULAR MATRIX T IS SINGULAR C C REMARKS C SUBROUTINE DMTDS MAY BE USED TO CALCULATE THE SOLUTION OF C A SYSTEM OF EQUATIONS WITH SYMMETRIC POSITIVE DEFINITE C COEFFICIENT MATRIX. THE FIRST STEP TOWARDS THE SOLUTION C IS TRIANGULAR FACTORIZATION BY MEANS OF DMFSD, THE SECOND C STEP IS APPLICATION OF DMTDS. C SUBROUTINES DMFSD AND DMTDS MAY BE USED IN ORDER TO C CACULATE THE PRODUCT TRANSPOSE(A)*INVERSE(B)*A WITH GIVEN C SYMMETRIC POSITIVE DEFINITE B AND GIVEN A IN THREE STEPS C 1) TRIANGULAR FACTORIZATION OF B (B=TRANSPOSE(T)*T) C 2) MULTIPLICATION OF A ON THE LEFT BY INVERSE(TRANSPOSE(T)) C A IS REPLACED BY C=INVERSE(TRANSPOSE(T))*A C 3) CALCULATION OF THE RESULT FORMING TRANSPOSE(C)*C C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C CALCULATION OF X = INVERSE(T)*A IS DONE USING BACKWARD C SUBSTITUTION TO OBTAIN X FROM T*X = A. C CALCULATION OF Y = INVERSE(TRANSPOSE(T))*A IS DONE USING C FORWARD SUBSTITUTION TO OBTAIN Y FROM TRANSPOSE(T)*Y = A. C CALCULATION OF Z = INVERSE(TRANSPOSE(T)*T)*A IS DONE C SOLVING FIRST TRANSPOSE(T)*Y = A AND THEN T*Z = Y, IE. C USING THE ABOVE TWO STEPS IN REVERSE ORDER C C .................................................................. C SUBROUTINE DMTDS(A,M,N,T,IOP,IER) C C DIMENSION A(1),T(1) DOUBLE PRECISION DSUM,A,T C C TEST OF DIMENSION IF(M)2,2,1 1 IF(N)2,2,4 C C ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS 2 IER=-1 RETURN C C ERROR RETURN IN CASE OF SINGULAR MATRIX T 3 IER=1 RETURN C C INITIALIZE DIVISION PROCESS 4 MN=M*N MM=M*(M+1)/2 MM1=M-1 IER=0 ICS=M IRS=1 IMEND=M C C TEST SPECIFIED OPERATION IF(IOP)5,2,6 5 MM=N*(N+1)/2 MM1=N-1 IRS=M ICS=1 IMEND=MN-M+1 MN=M 6 IOPE=MOD(IOP+3,3) IF(IABS(IOP)-3)7,7,2 7 IF(IOPE-1)8,18,8 C C INITIALIZE SOLUTION OF TRANSPOSE(T)*X = A 8 MEND=1 LLD=IRS MSTA=1 MDEL=1 MX=1 LD=1 LX=0 C C TEST FOR NONZERO DIAGONAL TERM IN T 9 IF(T(MSTA))10,3,10 10 DO 11 I=MEND,MN,ICS 11 A(I)=A(I)/T(MSTA) C C IS M EQUAL 1 IF(MM1)2,15,12 12 DO 14 J=1,MM1 MSTA=MSTA+MDEL MDEL=MDEL+MX DO 14 I=MEND,MN,ICS DSUM=0.D0 L=MSTA LDX=LD LL=I DO 13 K=1,J DSUM=DSUM-T(L)*A(LL) LL=LL+LLD L=L+LDX 13 LDX=LDX+LX IF(T(L))14,3,14 14 A(LL)=(DSUM+A(LL))/T(L) C C TEST END OF OPERATION 15 IF(IER)16,17,16 16 IER=0 RETURN 17 IF(IOPE)18,18,16 C C INITIALIZE SOLUTION OF T*X = A 18 IER=1 MEND=IMEND MN=M*N LLD=-IRS MSTA=MM MDEL=-1 MX=0 LD=-MM1 LX=1 GOTO 9 END C C .................................................................. C C SUBROUTINE DPECN C C PURPOSE C ECONOMIZE A POLYNOMIAL FOR SYMMETRIC RANGE C C USAGE C CALL DPECN(P,N,BOUND,EPS,TOL,WORK) C C DESCRIPTION OF PARAMETERS C P - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN C POLYNOMIAL C ON RETURN P CONTAINS THE ECONOMIZED POLYNOMIAL C N - DIMENSION OF COEFFICIENT VECTOR P C ON RETURN N CONTAINS DIMENSION OF ECONOMIZED C POLYNOMIAL C BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF RANGE C EPS - SINGLE PRECISION INITIAL ERROR BOUND C ON RETURN EPS CONTAINS AN ERROR BOUND FOR THE C ECONOMIZED POLYNOMIAL C TOL - SINGLE PRECISION TOLERANCE FOR ERROR C FINAL VALUE OF EPS MUST BE LESS THAN TOL C WORK - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N C (STARTING VALUE OF N RATHER THAN FINAL VALUE) C C REMARKS C THE OPERATION IS BYPASSED IN CASE OF N LESS THAN 1. C IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY C FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL C WITH ARGUMENT X IN POWERS OF T = (X-(XR-XL)/2). C THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SUBROUTINE DPECN TAKES AN (N-1)ST DEGREE POLYNOMIAL C APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE C EPS OVER THE INTERVAL (-BOUND,BOUND) AND REDUCES IT IF C POSSIBLE TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN C THE GIVEN TOLERANCE TOL. C THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE FINAL C VECTOR. THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL C ERROR BOUND. C N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL. C THE COEFFICIENT VECTOR OF THE N-TH CHEBYSHEV POLYNOMIAL C IS CALCULATED FROM THE RECURSION FORMULA C A(K-1)=-A(K+1)*K*L*L*(K-1)/((N+K-2)*(N-K+2)) C REFERENCE C K. A. BRONS, ALGORITHM 38, TELESCOPE 2, CACM VOL. 4, 1961, C NO. 3, PP. 151-152. C C .................................................................. C SUBROUTINE DPECN(P,N,BOUND,EPS,TOL,WORK) C DIMENSION P(1),WORK(1) DOUBLE PRECISION P,WORK C FL=BOUND*BOUND C C TEST OF DIMENSION C 1 IF(N-1)2,3,6 2 RETURN C 3 IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(SNGL(P(1))) 5 RETURN C C CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL C 6 NEND=N-2 WORK(N)=-P(N) DO 7 J=1,NEND,2 K=N-J FN=(NEND-1+K)*(NEND+3-K) FK=K*(K-1) 7 WORK(K-1)=-WORK(K+1)*DBLE(FK*FL/FN) C C TEST FOR FEASIBILITY OF REDUCTION C IF(K-2)8,8,9 8 FN=DABS(WORK(1)) GOTO 10 9 FN=N-1 FN=ABS(SNGL(WORK(2))/FN) 10 IF(EPS+FN-TOL)11,11,5 C C REDUCE POLYNOMIAL C 11 EPS=EPS+FN N=N-1 DO 12 J=K,N,2 12 P(J-1)=P(J-1)+WORK(J-1) GOTO 1 END C C .................................................................. C C SUBROUTINE DPECS C C PURPOSE C ECONOMIZATION OF A POLYNOMIAL FOR UNSYMMETRIC RANGE C C USAGE C CALL DPECS(P,N,BOUND,EPS,TOL,WORK) C C DESCRIPTION OF PARAMETERS C P - DOUBLE PRECISION COEFFICIENT VECTOR OF GIVEN C POLYNOMIAL C N - DIMENSION OF COEFFICIENT VECTOR P C BOUND - SINGLE PRECISION RIGHT HAND BOUNDARY OF INTERVAL C EPS - SINGLE PRECISION INITIAL ERROR BOUND C TOL - SINGLE PRECISION TOLERANCE FOR ERROR C WORK - DOUBLE PRECISION WORKING STORAGE OF DIMENSION N C C REMARKS C THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE C ECONOMIZED VECTOR. C THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL C ERROR BOUND. C N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL. C IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY C FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL C WITH ARGUMENT X IN POWERS OF T = (X-XL). C THIS IS ACCOMPLISHED THROUGH SUBROUTINE DPCLD. C OPERATION IS BYPASSED IN CASE OF N LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SUBROUTINE DPECS TAKES AN (N-1)ST DEGREE POLYNOMIAL C APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE C EPS OVER THE INTERVAL (0,BOUND) AND REDUCES IT IF POSSIBLE C TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN TOLERANCE C TOL. C THE COEFFICIENT VECTOR OF THE N-TH SHIFTED CHEBYSHEV C POLYNOMIAL IS CALCULATED FROM THE RECURSION FORMULA C A(K) = -A(K+1)*K*L*(2*K-1)/(2*(N+K-1)*(N-K+1)). C REFERENCE C K. A. BRONS, ALGORITHM 37, TELESCOPE 1, CACM VOL. 4, 1961, C NO. 3, PP. 151. C C .................................................................. C SUBROUTINE DPECS(P,N,BOUND,EPS,TOL,WORK) C DIMENSION P(1),WORK(1) DOUBLE PRECISION P,WORK C FL=BOUND*0.5 C C TEST OF DIMENSION C 1 IF(N-1)2,3,6 2 RETURN C 3 IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(SNGL(P(1))) 5 RETURN C C CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL C 6 NEND=N-1 WORK(N)=-P(N) DO 7 J=1,NEND K=N-J FN=(NEND-1+K)*(N-K) FK=K*(K+K-1) 7 WORK(K)=-WORK(K+1)*DBLE(FK)*DBLE(FL)/DBLE(FN) C C TEST FOR FEASIBILITY OF REDUCTION C FN=DABS(WORK(1)) IF(EPS+FN-TOL)8,8,5 C C REDUCE POLYNOMIAL C 8 EPS=EPS+FN N=NEND DO 9 J=1,NEND 9 P(J)=P(J)+WORK(J) GOTO 1 END C C .................................................................. C C SUBROUTINE DPQFB C C PURPOSE C TO FIND AN APPROXIMATION Q(X)=Q1+Q2*X+X*X TO A QUADRATIC C FACTOR OF A GIVEN POLYNOMIAL P(X) WITH REAL COEFFICIENTS. C C USAGE C CALL DPQFB(C,IC,Q,LIM,IER) C C DESCRIPTION OF PARAMETERS C C - DOUBLE PRECISION INPUT VECTOR CONTAINING THE C COEFFICIENTS OF P(X) - C(1) IS THE CONSTANT TERM C (DIMENSION IC) C IC - DIMENSION OF C C Q - DOUBLE PRECISION VECTOR OF DIMENSION 4 - ON INPUT Q(1) C AND Q(2) CONTAIN INITIAL GUESSES FOR Q1 AND Q2 - ON C RETURN Q(1) AND Q(2) CONTAIN THE REFINED COEFFICIENTS C Q1 AND Q2 OF Q(X), WHILE Q(3) AND Q(4) CONTAIN THE C COEFFICIENTS A AND B OF A+B*X, WHICH IS THE REMAINDER C OF THE QUOTIENT OF P(X) BY Q(X) C LIM - INPUT VALUE SPECIFYING THE MAXIMUM NUMBER OF C ITERATIONS TO BE PERFORMED C IER - RESULTING ERROR PARAMETER (SEE REMARKS) C IER= 0 - NO ERROR C IER= 1 - NO CONVERGENCE WITHIN LIM ITERATIONS C IER=-1 - THE POLYNOMIAL P(X) IS CONSTANT OR UNDEFINED C - OR OVERFLOW OCCURRED IN NORMALIZING P(X) C IER=-2 - THE POLYNOMIAL P(X) IS OF DEGREE 1 C IER=-3 - NO FURTHER REFINEMENT OF THE APPROXIMATION TO C A QUADRATIC FACTOR IS FEASIBLE, DUE TO EITHER C DIVISION BY 0, OVERFLOW OR AN INITIAL GUESS C THAT IS NOT SUFFICIENTLY CLOSE TO A FACTOR OF C P(X) C C REMARKS C (1) IF IER=-1 THERE IS NO COMPUTATION OTHER THAN THE C POSSIBLE NORMALIZATION OF C. C (2) IF IER=-2 THERE IS NO COMPUTATION OTHER THAN THE C NORMALIZATION OF C. C (3) IF IER =-3 IT IS SUGGESTED THAT A NEW INITIAL GUESS BE C MADE FOR A QUADRATIC FACTOR. Q, HOWEVER, WILL CONTAIN C THE VALUES ASSOCIATED WITH THE ITERATION THAT YIELDED C THE SMALLEST NORM OF THE MODIFIED LINEAR REMAINDER. C (4) IF IER=1, THEN, ALTHOUGH THE NUMBER OF ITERATIONS LIM C WAS TOO SMALL TO INDICATE CONVERGENCE, NO OTHER PROB- C LEMS HAVE BEEN DETECTED, AND Q WILL CONTAIN THE VALUES C ASSOCIATED WITH THE ITERATION THAT YIELDED THE SMALLEST C NORM OF THE MODIFIED LINEAR REMAINDER. C (5) FOR COMPLETE DETAIL SEE THE DOCUMENTATION FOR C SUBROUTINES PQFB AND DPQFB. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C COMPUTATION IS BASED ON BAIRSTOW'S ITERATIVE METHOD. (SEE C WILKINSON, J.H., THE EVALUATION OF THE ZEROS OF ILL-CON- C DITIONED POLYNOMIALS (PART ONE AND TWO), NUMERISCHE MATHE- C MATIK, VOL.1 (1959), PP. 150-180, OR HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 472-476.) C C .................................................................. C SUBROUTINE DPQFB(C,IC,Q,LIM,IER) C C DIMENSION C(1),Q(1) DOUBLE PRECISION A,B,AA,BB,CA,CB,CC,CD,A1,B1,C1,H,HH,Q1,Q2,QQ1, 1 QQ2,QQQ1,QQQ2,DQ1,DQ2,EPS,EPS1,C,Q C C TEST ON LEADING ZERO COEFFICIENTS IER=0 J=IC+1 1 J=J-1 IF(J-1)40,40,2 2 IF(C(J))3,1,3 C C NORMALIZATION OF REMAINING COEFFICIENTS 3 A=C(J) IF(A-1.D0)4,6,4 4 DO 5 I=1,J C(I)=C(I)/A CALL OVERFL(N) IF(N-2)40,5,5 5 CONTINUE C C TEST ON NECESSITY OF BAIRSTOW ITERATION 6 IF(J-3)41,38,7 C C PREPARE BAIRSTOW ITERATION 7 EPS=1.D-14 EPS1=1.D-6 L=0 LL=0 Q1=Q(1) Q2=Q(2) QQ1=0.D0 QQ2=0.D0 AA=C(1) BB=C(2) CB=DABS(AA) CA=DABS(BB) IF(CB-CA)8,9,10 8 CC=CB+CB CB=CB/CA CA=1.D0 GO TO 11 9 CC=CA+CA CA=1.D0 CB=1.D0 GO TO 11 10 CC=CA+CA CA=CA/CB CB=1.D0 11 CD=CC*.1D0 C C START BAIRSTOW ITERATION C PREPARE NESTED MULTIPLICATION 12 A=0.D0 B=A A1=A B1=A I=J QQQ1=Q1 QQQ2=Q2 DQ1=HH DQ2=H C C START NESTED MULTIPLICATION 13 H=-Q1*B-Q2*A+C(I) CALL OVERFL(N) IF(N-2)42,14,14 14 B=A A=H I=I-1 IF(I-1)18,15,16 15 H=0.D0 16 H=-Q1*B1-Q2*A1+H CALL OVERFL(N) IF(N-2)42,17,17 17 C1=B1 B1=A1 A1=H GO TO 13 C END OF NESTED MULTIPLICATION C C TEST ON SATISFACTORY ACCURACY 18 H=CA*DABS(A)+CB*DABS(B) IF(LL)19,19,39 19 L=L+1 IF(DABS(A)-EPS*DABS(C(1)))20,20,21 20 IF(DABS(B)-EPS*DABS(C(2)))39,39,21 C C TEST ON LINEAR REMAINDER OF MINIMUM NORM 21 IF(H-CC)22,22,23 22 AA=A BB=B CC=H QQ1=Q1 QQ2=Q2 C C TEST ON LAST ITERATION STEP 23 IF(L-LIM)28,28,24 C C TEST ON RESTART OF BAIRSTOW ITERATION WITH ZERO INITIAL GUESS 24 IF(H-CD)43,43,25 25 IF(Q(1))27,26,27 26 IF(Q(2))27,42,27 27 Q(1)=0.D0 Q(2)=0.D0 GO TO 7 C C PERFORM ITERATION STEP 28 HH=DMAX1(DABS(A1),DABS(B1),DABS(C1)) IF(HH)42,42,29 29 A1=A1/HH B1=B1/HH C1=C1/HH H=A1*C1-B1*B1 IF(H)30,42,30 30 A=A/HH B=B/HH HH=(B*A1-A*B1)/H H=(A*C1-B*B1)/H Q1=Q1+HH Q2=Q2+H C END OF ITERATION STEP C C TEST ON SATISFACTORY RELATIVE ERROR OF ITERATED VALUES IF(DABS(HH)-EPS*DABS(Q1))31,31,33 31 IF(DABS(H)-EPS*DABS(Q2))32,32,33 32 LL=1 GO TO 12 C C TEST ON DECREASING RELATIVE ERRORS 33 IF(L-1)12,12,34 34 IF(DABS(HH)-EPS1*DABS(Q1))35,35,12 35 IF(DABS(H)-EPS1*DABS(Q2))36,36,12 36 IF(DABS(QQQ1*HH)-DABS(Q1*DQ1))37,44,44 37 IF(DABS(QQQ2*H)-DABS(Q2*DQ2))12,44,44 C END OF BAIRSTOW ITERATION C C EXIT IN CASE OF QUADRATIC POLYNOMIAL 38 Q(1)=C(1) Q(2)=C(2) Q(3)=0.D0 Q(4)=0.D0 RETURN C C EXIT IN CASE OF SUFFICIENT ACCURACY 39 Q(1)=Q1 Q(2)=Q2 Q(3)=A Q(4)=B RETURN C C ERROR EXIT IN CASE OF ZERO OR CONSTANT POLYNOMIAL 40 IER=-1 RETURN C C ERROR EXIT IN CASE OF LINEAR POLYNOMIAL 41 IER=-2 RETURN C C ERROR EXIT IN CASE OF NONREFINED QUADRATIC FACTOR 42 IER=-3 GO TO 44 C C ERROR EXIT IN CASE OF UNSATISFACTORY ACCURACY 43 IER=1 44 Q(1)=QQ1 Q(2)=QQ2 Q(3)=AA Q(4)=BB RETURN END C C .................................................................. C C SUBROUTINE DPRBM C C PURPOSE C TO CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN C POLYNOMIAL WITH REAL COEFFICIENTS. C C USAGE C CALL DPRBM (C,IC,RR,RC,POL,IR,IER) C C DESCRIPTION OF PARAMETERS C C - DOUBLE PRECISION INPUT VECTOR CONTAINING THE C COEFFICIENTS OF THE GIVEN POLYNOMIAL. COEFFICIENTS C ARE ORDERED FROM LOW TO HIGH. ON RETURN COEFFI- C CIENTS ARE DIVIDED BY THE LAST NONZERO TERM. C IC - DIMENSION OF VECTORS C, RR, RC, AND POL. C RR - RESULTANT DOUBLE PRECISION VECTOR OF REAL PARTS C OF THE ROOTS. C RC - RESULTANT DOUBLE PRECISION VECTOR OF COMPLEX PARTS C OF THE ROOTS. C POL - RESULTANT DOUBLE PRECISION VECTOR OF COEFFICIENTS C OF THE POLYNOMIAL WITH CALCULATED ROOTS. C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH (SEE C REMARK 4). C IR - OUTPUT VALUE SPECIFYING THE NUMBER OF CALCULATED C ROOTS. NORMALLY IR IS EQUAL TO IC-1. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - SUBROUTINE DPQFB RECORDS POOR CONVERGENCE C AT SOME QUADRATIC FACTORIZATION WITHIN C 100 ITERATION STEPS, C IER=2 - POLYNOMIAL IS DEGENERATE, I.E. ZERO OR C CONSTANT, C OR OVERFLOW IN NORMALIZATION OF GIVEN C POLYNOMIAL, C IER=3 - THE SUBROUTINE IS BYPASSED DUE TO C SUCCESSIVE ZERO DIVISORS OR OVERFLOWS C IN QUADRATIC FACTORIZATION OR DUE TO C COMPLETELY UNSATISFACTORY ACCURACY, C IER=-1 - CALCULATED COEFFICIENT VECTOR HAS LESS C THAN SIX CORRECT SIGNIFICANT DIGITS. C THIS REVEALS POOR ACCURACY OF CALCULATED C ROOTS. C C REMARKS C (1) REAL PARTS OF THE ROOTS ARE STORED IN RR(1) UP TO RR(IR) C AND CORRESPONDING COMPLEX PARTS IN RC(1) UP TO RC(IR). C (2) ERROR MESSAGE IER=1 INDICATES POOR CONVERGENCE WITHIN C 100 ITERATION STEPS AT SOME QUADRATIC FACTORIZATION C PERFORMED BY SUBROUTINE DPQFB. C (3) NO ACTION BESIDES ERROR MESSAGE IER=2 IN CASE OF A ZERO C OR CONSTANT POLYNOMIAL. THE SAME ERROR MESSAGE IS GIVEN C IN CASE OF AN OVERFLOW IN NORMALIZATION OF GIVEN C POLYNOMIAL. C (4) ERROR MESSAGE IER=3 INDICATES SUCCESSIVE ZERO DIVISORS C OR OVERFLOWS OR COMPLETELY UNSATISFACTORY ACCURACY AT C ANY QUADRATIC FACTORIZATION PERFORMED BY C SUBROUTINE DPQFB. IN THIS CASE CALCULATION IS BYPASSED. C IR RECORDS THE NUMBER OF CALCULATED ROOTS. C POL(1),...,POL(J-IR) ARE THE COEFFICIENTS OF THE C REMAINING POLYNOMIAL, WHERE J IS THE ACTUAL NUMBER OF C COEFFICIENTS IN VECTOR C (NORMALLY J=IC). C (5) IF CALCULATED COEFFICIENT VECTOR HAS LESS THAN SIX C CORRECT SIGNIFICANT DIGITS THOUGH ALL QUADRATIC C FACTORIZATIONS SHOWED SATISFACTORY ACCURACY, THE ERROR C MESSAGE IER=-1 IS GIVEN. C (6) THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED C COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE C BEEN CALCULATED. IN THIS CASE THE NUMBER OF ROOTS IR IS C EQUAL TO THE ACTUAL DEGREE OF THE POLYNOMIAL (NORMALLY C IR=IC-1). THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT C VECTOR IS RECORDED IN RR(IR+1). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SUBROUTINE DPQFB QUADRATIC FACTORIZATION OF A POLYNOMIAL C BY BAIRSTOW ITERATION. C C METHOD C THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF C SUCCESSIVE QUADRATIC FACTORIZATION PERFORMED BY BAIRSTOW C ITERATION. X**2 IS USED AS INITIAL GUESS FOR THE FIRST C QUADRATIC FACTOR, AND FURTHER EACH CALCULATED QUADRATIC C FACTOR IS USED AS INITIAL GUESS FOR THE NEXT ONE. AFTER C COMPUTATION OF ALL ROOTS THE COEFFICIENT VECTOR IS C CALCULATED AND COMPARED WITH THE GIVEN ONE. C FOR REFERENCE, SEE J. H. WILKINSON, THE EVALUATION OF THE C ZEROS OF ILL-CONDITIONED POLYNOMIALS (PART ONE AND TWO), C NUMERISCHE MATHEMATIK, VOL.1 (1959), PP.150-180. C C .................................................................. C SUBROUTINE DPRBM(C,IC,RR,RC,POL,IR,IER) C C DIMENSION C(1),RR(1),RC(1),POL(1),Q(4) DOUBLE PRECISION C,RR,RC,POL,Q,EPS,A,B,H,Q1,Q2 C C TEST ON LEADING ZERO COEFFICIENTS EPS=1.D-6 LIM=100 IR=IC+1 1 IR=IR-1 IF(IR-1)42,42,2 2 IF(C(IR))3,1,3 C C WORK UP ZERO ROOTS AND NORMALIZE REMAINING POLYNOMIAL 3 IER=0 J=IR L=0 A=C(IR) DO 8 I=1,IR IF(L)4,4,7 4 IF(C(I))6,5,6 5 RR(I)=0.D0 RC(I)=0.D0 POL(J)=0.D0 J=J-1 GO TO 8 6 L=1 IST=I J=0 7 J=J+1 C(I)=C(I)/A POL(J)=C(I) CALL OVERFL(N) IF(N-2)42,8,8 8 CONTINUE C C START BAIRSTOW ITERATION Q1=0.D0 Q2=0.D0 9 IF(J-2)33,10,14 C C DEGREE OF RESTPOLYNOMIAL IS EQUAL TO ONE 10 A=POL(1) RR(IST)=-A RC(IST)=0.D0 IR=IR-1 Q2=0.D0 IF(IR-1)13,13,11 11 DO 12 I=2,IR Q1=Q2 Q2=POL(I+1) 12 POL(I)=A*Q2+Q1 13 POL(IR+1)=A+Q2 GO TO 34 C THIS IS BRANCH TO COMPARISON OF COEFFICIENT VECTORS C AND POL C C DEGREE OF RESTPOLYNOMIAL IS GREATER THAN ONE 14 DO 22 L=1,10 N=1 15 Q(1)=Q1 Q(2)=Q2 CALL DPQFB(POL,J,Q,LIM,I) IF(I)16,24,23 16 IF(Q1)18,17,18 17 IF(Q2)18,21,18 18 GO TO (19,20,19,21),N 19 Q1=-Q1 N=N+1 GO TO 15 20 Q2=-Q2 N=N+1 GO TO 15 21 Q1=1.D0+Q1 22 Q2=1.D0-Q2 C C ERROR EXIT DUE TO UNSATISFACTORY RESULTS OF FACTORIZATION IER=3 IR=IR-J RETURN C C WORK UP RESULTS OF QUADRATIC FACTORIZATION 23 IER=1 24 Q1=Q(1) Q2=Q(2) C C PERFORM DIVISION OF FACTORIZED POLYNOMIAL BY QUADRATIC FACTOR B=0.D0 A=0.D0 I=J 25 H=-Q1*B-Q2*A+POL(I) POL(I)=B B=A A=H I=I-1 IF(I-2)26,26,25 26 POL(2)=B POL(1)=A C C MULTIPLY POLYNOMIAL WITH CALCULATED ROOTS BY QUADRATIC FACTOR L=IR-1 IF(J-L)27,27,29 27 DO 28 I=J,L 28 POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1 29 POL(L)=POL(L)+POL(L+1)*Q2+Q1 POL(IR)=POL(IR)+Q2 C C CALCULATE ROOT-PAIR FROM QUADRATIC FACTOR X*X+Q2*X+Q1 H=-.5D0*Q2 A=H*H-Q1 B=DSQRT(DABS(A)) IF(A)30,30,31 30 RR(IST)=H RC(IST)=B IST=IST+1 RR(IST)=H RC(IST)=-B GO TO 32 31 B=H+DSIGN(B,H) RR(IST)=Q1/B RC(IST)=0.D0 IST=IST+1 RR(IST)=B RC(IST)=0.D0 32 IST=IST+1 J=J-2 GO TO 9 C C SHIFT BACK ELEMENTS OF POL BY 1 AND COMPARE VECTORS POL AND C 33 IR=IR-1 34 A=0.D0 DO 38 I=1,IR Q1=C(I) Q2=POL(I+1) POL(I)=Q2 IF(Q1)35,36,35 35 Q2=(Q1-Q2)/Q1 36 Q2=DABS(Q2) IF(Q2-A)38,38,37 37 A=Q2 38 CONTINUE I=IR+1 POL(I)=1.D0 RR(I)=A RC(I)=0.D0 IF(IER)39,39,41 39 IF(A-EPS)41,41,40 C C WARNING DUE TO POOR ACCURACY OF CALCULATED COEFFICIENT VECTOR 40 IER=-1 41 RETURN C C ERROR EXIT DUE TO DEGENERATE POLYNOMIAL OR OVERFLOW IN C NORMALIZATION 42 IER=2 IR=0 RETURN END C C .................................................................. C C SUBROUTINE DPRQD C C PURPOSE C CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN POLYNOMIAL C WITH REAL COEFFICIENTS. C C USAGE C CALL DPRQD(C,IC,Q,E,POL,IR,IER) C C DESCRIPTION OF PARAMETERS C C - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C THE GIVEN COEFFICIENT VECTOR GETS DIVIDED BY THE C LAST NONZERO TERM C DOUBLE PRECISION ARRAY C IC - DIMENSION OF VECTOR C C Q - WORKING STORAGE OF DIMENSION IC C ON RETURN Q CONTAINS REAL PARTS OF ROOTS C DOUBLE PRECISION ARRAY C E - WORKING STORAGE OF DIMENSION IC C ON RETURN E CONTAINS COMPLEX PARTS OF ROOTS C DOUBLE PRECISION ARRAY C POL - WORKING STORAGE OF DIMENSION IC C ON RETURN POL CONTAINS THE COEFFICIENTS OF THE C POLYNOMIAL WITH CALCULATED ROOTS C THIS RESULTING COEFFICIENT VECTOR HAS DIMENSION IR+1 C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION ARRAY C IR - NUMBER OF CALCULATED ROOTS C NORMALLY IR IS EQUAL TO DIMENSION IC MINUS ONE C IER - RESULTING ERROR PARAMETER. SEE REMARKS C C REMARKS C THE REAL PART OF THE ROOTS IS STORED IN Q(1) UP TO Q(IR) C CORRESPONDING COMPLEX PARTS ARE STORED IN E(1) UP TO E(IR). C IER = 0 MEANS NO ERRORS C IER = 1 MEANS NO CONVERGENCE WITH FEASIBLE TOLERANCE C IER = 2 MEANS POLYNOMIAL IS DEGENERATE (CONSTANT OR ZERO) C IER = 3 MEANS SUBROUTINE WAS ABANDONED DUE TO ZERO DIVISOR C IER = 4 MEANS THERE EXISTS NO S-FRACTION C IER =-1 MEANS CALCULATED COEFFICIENT VECTOR REVEALS POOR C ACCURACY OF THE CALCULATED ROOTS. C THE CALCULATED COEFFICIENT VECTOR HAS LESS THAN C 6 CORRECT DIGITS. C THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED C COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE BEEN C CALCULATED. C THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT VECTOR IS C RECORDED IN Q(IR+1). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF C THE QUOTIENT-DIFFERENCE ALGORITHM WITH DISPLACEMENT. C REFERENCE C H.RUTISHAUSER, DER QUOTIENTEN-DIFFERENZEN-ALGORITHMUS, C BIRKHAEUSER, BASEL/STUTTGART, 1957. C C .................................................................. C SUBROUTINE DPRQD(C,IC,Q,E,POL,IR,IER) C C DIMENSIONED DUMMY VARIABLES DIMENSION E(1),Q(1),C(1),POL(1) DOUBLE PRECISION Q,E,O,P,T,EXPT,ESAV,U,V,W,C,POL,EPS C C NORMALIZATION OF GIVEN POLYNOMIAL C TEST OF DIMENSION C IR CONTAINS INDEX OF HIGHEST COEFFICIENT IR=IC IER=0 EPS=1.D-16 TOL=1.E-6 LIMIT=10*IC KOUNT=0 1 IF(IR-1)79,79,2 C C DROP TRAILING ZERO COEFFICIENTS 2 IF(C(IR))4,3,4 3 IR=IR-1 GOTO 1 C C REARRANGEMENT OF GIVEN POLYNOMIAL C EXTRACTION OF ZERO ROOTS 4 O=1.0D0/C(IR) IEND=IR-1 ISTA=1 NSAV=IR+1 JBEG=1 C C Q(J)=1. C Q(J+I)=C(IR-I)/C(IR) C Q(IR)=C(J)/C(IR) C WHERE J IS THE INDEX OF THE LOWEST NONZERO COEFFICIENT DO 9 I=1,IR J=NSAV-I IF(C(I))7,5,7 5 GOTO(6,8),JBEG 6 NSAV=NSAV+1 Q(ISTA)=0.D0 E(ISTA)=0.D0 ISTA=ISTA+1 GOTO 9 7 JBEG=2 8 Q(J)=C(I)*O C(I)=Q(J) 9 CONTINUE C C INITIALIZATION ESAV=0.D0 Q(ISTA)=0.D0 10 NSAV=IR C C COMPUTATION OF DERIVATIVE EXPT=IR-ISTA E(ISTA)=EXPT DO 11 I=ISTA,IEND EXPT=EXPT-1.0D0 POL(I+1)=EPS*DABS(Q(I+1))+EPS 11 E(I+1)=Q(I+1)*EXPT C C TEST OF REMAINING DIMENSION IF(ISTA-IEND)12,20,60 12 JEND=IEND-1 C C COMPUTATION OF S-FRACTION DO 19 I=ISTA,JEND IF(I-ISTA)13,16,13 13 IF(DABS(E(I))-POL(I+1))14,14,16 C C THE GIVEN POLYNOMIAL HAS MULTIPLE ROOTS, THE COEFFICIENTS OF C THE COMMON FACTOR ARE STORED FROM Q(NSAV) UP TO Q(IR) 14 NSAV=I DO 15 K=I,JEND IF(DABS(E(K))-POL(K+1))15,15,80 15 CONTINUE GOTO 21 C C EUCLIDEAN ALGORITHM 16 DO 19 K=I,IEND E(K+1)=E(K+1)/E(I) Q(K+1)=E(K+1)-Q(K+1) IF(K-I)18,17,18 C C TEST FOR SMALL DIVISOR 17 IF(DABS(Q(I+1))-POL(I+1))80,80,19 18 Q(K+1)=Q(K+1)/Q(I+1) POL(K+1)=POL(K+1)/DABS(Q(I+1)) E(K)=Q(K+1)-E(K) 19 CONTINUE 20 Q(IR)=-Q(IR) C C THE DISPLACEMENT EXPT IS SET TO 0 AUTOMATICALLY. C E(ISTA)=0.,Q(ISTA+1),...,E(NSAV-1),Q(NSAV),E(NSAV)=0., C FORM A DIAGONAL OF THE QD-ARRAY. C INITIALIZATION OF BOUNDARY VALUES 21 E(ISTA)=0.D0 NRAN=NSAV-1 22 E(NRAN+1)=0.D0 C C TEST FOR LINEAR OR CONSTANT FACTOR C NRAN-ISTA IS DEGREE-1 IF(NRAN-ISTA)24,23,31 C C LINEAR FACTOR 23 Q(ISTA+1)=Q(ISTA+1)+EXPT E(ISTA+1)=0.D0 C C TEST FOR UNFACTORED COMMON DIVISOR 24 E(ISTA)=ESAV IF(IR-NSAV)60,60,25 C C INITIALIZE QD-ALGORITHM FOR COMMON DIVISOR 25 ISTA=NSAV ESAV=E(ISTA) GOTO 10 C C COMPUTATION OF ROOT PAIR 26 P=P+EXPT C C TEST FOR REALITY IF(O)27,28,28 C C COMPLEX ROOT PAIR 27 Q(NRAN)=P Q(NRAN+1)=P E(NRAN)=T E(NRAN+1)=-T GOTO 29 C C REAL ROOT PAIR 28 Q(NRAN)=P-T Q(NRAN+1)=P+T E(NRAN)=0.D0 C C REDUCTION OF DEGREE BY 2 (DEFLATION) 29 NRAN=NRAN-2 GOTO 22 C C COMPUTATION OF REAL ROOT 30 Q(NRAN+1)=EXPT+P C C REDUCTION OF DEGREE BY 1 (DEFLATION) NRAN=NRAN-1 GOTO 22 C C START QD-ITERATION 31 JBEG=ISTA+1 JEND=NRAN-1 TEPS=EPS TDELT=1.E-2 32 KOUNT=KOUNT+1 P=Q(NRAN+1) R=ABS(SNGL(E(NRAN))) C C TEST FOR CONVERGENCE IF(R-TEPS)30,30,33 33 S=ABS(SNGL(E(JEND))) C C IS THERE A REAL ROOT NEXT IF(S-R)38,38,34 C C IS DISPLACEMENT SMALL ENOUGH 34 IF(R-TDELT)36,35,35 35 P=0.D0 36 O=P DO 37 J=JBEG,NRAN Q(J)=Q(J)+E(J)-E(J-1)-O C C TEST FOR SMALL DIVISOR IF(DABS(Q(J))-POL(J))81,81,37 37 E(J)=Q(J+1)*E(J)/Q(J) Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O GOTO 54 C C CALCULATE DISPLACEMENT FOR DOUBLE ROOTS C QUADRATIC EQUATION FOR DOUBLE ROOTS C X**2-(Q(NRAN)+Q(NRAN+1)+E(NRAN))*X+Q(NRAN)*Q(NRAN+1)=0 38 P=0.5D0*(Q(NRAN)+E(NRAN)+Q(NRAN+1)) O=P*P-Q(NRAN)*Q(NRAN+1) T=DSQRT(DABS(O)) C C TEST FOR CONVERGENCE IF(S-TEPS)26,26,39 C C ARE THERE COMPLEX ROOTS 39 IF(O)43,40,40 40 IF(P)42,41,41 41 T=-T 42 P=P+T R=S GOTO 34 C C MODIFICATION FOR COMPLEX ROOTS C IS DISPLACEMENT SMALL ENOUGH 43 IF(S-TDELT)44,35,35 C C INITIALIZATION 44 O=Q(JBEG)+E(JBEG)-P C C TEST FOR SMALL DIVISOR IF(DABS(O)-POL(JBEG))81,81,45 45 T=(T/O)**2 U=E(JBEG)*Q(JBEG+1)/(O*(1.0D0+T)) V=O+U C C THREEFOLD LOOP FOR COMPLEX DISPLACEMENT KOUNT=KOUNT+2 DO 53 J=JBEG,NRAN O=Q(J+1)+E(J+1)-U-P C C TEST FOR SMALL DIVISOR IF(DABS(V)-POL(J))46,46,49 46 IF(J-NRAN)81,47,81 47 EXPT=EXPT+P IF(ABS(SNGL(E(JEND)))-TOL)48,48,81 48 P=0.5D0*(V+O-E(JEND)) O=P*P-(V-U)*(O-U*T-O*W*(1.D0+T)/Q(JEND)) T=DSQRT(DABS(O)) GOTO 26 C C TEST FOR SMALL DIVISOR 49 IF(DABS(O)-POL(J+1))46,46,50 50 W=U*O/V T=T*(V/O)**2 Q(J)=V+W-E(J-1) U=0.D0 IF(J-NRAN)51,52,52 51 U=Q(J+2)*E(J+1)/(O*(1.D0+T)) 52 V=O+U-W C C TEST FOR SMALL DIVISOR IF(DABS(Q(J))-POL(J))81,81,53 53 E(J)=W*V*(1.0D0+T)/Q(J) Q(NRAN+1)=V-E(NRAN) 54 EXPT=EXPT+P TEPS=TEPS*1.1 TDELT=TDELT*1.1 IF(KOUNT-LIMIT)32,55,55 C C NO CONVERGENCE WITH FEASIBLE TOLERANCE C ERROR RETURN IN CASE OF UNSATISFACTORY CONVERGENCE 55 IER=1 C C REARRANGE CALCULATED ROOTS 56 IEND=NSAV-NRAN-1 E(ISTA)=ESAV IF(IEND)59,59,57 57 DO 58 I=1,IEND J=ISTA+I K=NRAN+1+I E(J)=E(K) 58 Q(J)=Q(K) 59 IR=ISTA+IEND C C NORMAL RETURN 60 IR=IR-1 IF(IR)78,78,61 C C REARRANGE CALCULATED ROOTS 61 DO 62 I=1,IR Q(I)=Q(I+1) 62 E(I)=E(I+1) C C CALCULATE COEFFICIENT VECTOR FROM ROOTS POL(IR+1)=1.D0 IEND=IR-1 JBEG=1 DO 69 J=1,IR ISTA=IR+1-J O=0.D0 P=Q(ISTA) T=E(ISTA) IF(T)65,63,65 C C MULTIPLY WITH LINEAR FACTOR 63 DO 64 I=ISTA,IR POL(I)=O-P*POL(I+1) 64 O=POL(I+1) GOTO 69 65 GOTO(66,67),JBEG 66 JBEG=2 POL(ISTA)=0.D0 GOTO 69 C C MULTIPLY WITH QUADRATIC FACTOR 67 JBEG=1 U=P*P+T*T P=P+P DO 68 I=ISTA,IEND POL(I)=O-P*POL(I+1)+U*POL(I+2) 68 O=POL(I+1) POL(IR)=O-P 69 CONTINUE IF(IER)78,70,78 C C COMPARISON OF COEFFICIENT VECTORS, IE. TEST OF ACCURACY 70 P=0.D0 DO 75 I=1,IR IF(C(I))72,71,72 71 O=DABS(POL(I)) GOTO 73 72 O=DABS((POL(I)-C(I))/C(I)) 73 IF(P-O)74,75,75 74 P=O 75 CONTINUE IF(SNGL(P)-TOL)77,76,76 76 IER=-1 77 Q(IR+1)=P E(IR+1)=0.D0 78 RETURN C C ERROR RETURNS C ERROR RETURN FOR POLYNOMIALS OF DEGREE LESS THAN 1 79 IER=2 IR=0 RETURN C C ERROR RETURN IF THERE EXISTS NO S-FRACTION 80 IER=4 IR=ISTA GOTO 60 C C ERROR RETURN IN CASE OF INSTABLE QD-ALGORITHM 81 IER=3 GOTO 56 END C C .................................................................. C C SUBROUTINE DQA12 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA12 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 12-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA12(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.36191360360615602D2 Y=.33287369929782177D-15*FCT(X) X=.27661108779846090D2 Y=Y+.13169240486156340D-11*FCT(X) X=.21396755936166109D2 Y=Y+.60925085399751278D-9*FCT(X) X=.16432195087675313D2 Y=Y+.8037942349882859D-7*FCT(X) X=.12390447963809471D2 Y=Y+.43164914098046673D-5*FCT(X) X=.9075434230961203D1 Y=Y+.11377383272808760D-3*FCT(X) X=.63699753880306349D1 Y=Y+.16473849653768349D-2*FCT(X) X=.41984156448784132D1 Y=Y+.14096711620145342D-1*FCT(X) X=.25098480972321280D1 Y=Y+.7489094100646149D-1*FCT(X) X=.12695899401039615D1 Y=Y+.25547924356911832D0*FCT(X) X=.45450668156378028D0 Y=Y+.57235907069288604D0*FCT(X) X=.50361889117293951D-1 Y=Y+.8538623277373985D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQA16 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA16 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 16-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA16(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.50777223877537080D2 Y=.14621352854768325D-21*FCT(X) X=.41081666525491202D2 Y=Y+.18463473073036584D-17*FCT(X) X=.33781970488226166D2 Y=Y+.23946880341856973D-14*FCT(X) X=.27831438211328676D2 Y=Y+.8430020422652895D-12*FCT(X) X=.22821300693525208D2 Y=Y+.11866582926793277D-9*FCT(X) X=.18537743178606694D2 Y=Y+.8197664329541793D-8*FCT(X) X=.14851431341801250D2 Y=Y+.31483355850911881D-6*FCT(X) X=.11677033673975957D2 Y=Y+.7301170259124752D-5*FCT(X) X=.8955001337723390D1 Y=Y+.10833168123639965D-3*FCT(X) X=.66422151797414440D1 Y=Y+.10725367310559441D-2*FCT(X) X=.47067267076675872D1 Y=Y+.7309780653308856D-2*FCT(X) X=.31246010507021443D1 Y=Y+.35106857663146861D-1*FCT(X) X=.18779315076960743D1 Y=Y+.12091626191182523D0*FCT(X) X=.9535531553908655D0 Y=Y+.30253946815328497D0*FCT(X) X=.34220015601094768D0 Y=Y+.55491628460505980D0*FCT(X) X=.37962914575313455D-1 Y=Y+.7504767051856048D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQA24 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA24 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 24-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA24(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.8055628081995041D2 Y=.15871102921547994D-34*FCT(X) X=.69068601975304369D2 Y=Y+.11969225386627757D-29*FCT(X) X=.60206666963057223D2 Y=Y+.7370072160301340D-26*FCT(X) X=.52795432527283630D2 Y=Y+.11129154937804570D-22*FCT(X) X=.46376979557540133D2 Y=Y+.63767746470102769D-20*FCT(X) X=.40711598185543107D2 Y=Y+.17460319202373353D-17*FCT(X) X=.35653703516328212D2 Y=Y+.26303192453168170D-15*FCT(X) X=.31106464709046565D2 Y=Y+.23951797309583587D-13*FCT(X) X=.27001406056472356D2 Y=Y+.14093865163091778D-11*FCT(X) X=.23287932824879917D2 Y=Y+.56305930756763382D-10*FCT(X) X=.19927425875242462D2 Y=Y+.15860934990330765D-8*FCT(X) X=.16889671928527108D2 Y=Y+.32450282717915397D-7*FCT(X) X=.14150586187285759D2 Y=Y+.49373179873395010D-6*FCT(X) X=.11690695926056073D2 Y=Y+.56945173834696962D-5*FCT(X) X=.9494095330026488D1 Y=Y+.50571980554969778D-4*FCT(X) X=.7547704680023454D1 Y=Y+.35030086360234566D-3*FCT(X) X=.58407332713236080D1 Y=Y+.19127846396388306D-2*FCT(X) X=.43642830769353062D1 Y=Y+.8306009823955105D-2*FCT(X) X=.31110524551477130D1 Y=Y+.28889923149962199D-1*FCT(X) X=.20751129098523806D1 Y=Y+.8095935396920770D-1*FCT(X) X=.12517406323627464D1 Y=Y+.18364459415857036D0*FCT(X) X=.63729027873266879D0 Y=Y+.33840894389128221D0*FCT(X) X=.22910231649262433D0 Y=Y+.50792308532951820D0*FCT(X) X=.25437996585689359D-1 Y=Y+.62200206075592616D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQA32 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA32 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 32-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA32(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.11079926894707576D3 Y=.11071413071713886D-27*FCT(X) X=.9791671642606276D2 Y=Y+.33594959802163184D-22*FCT(X) X=.8785611994313352D22 Y=Y+.68422760225114810D-18*FCT(X) X=.7933908652882320D2 Y=Y+.31147812492595276D-14*FCT(X) X=.71868499359551422D2 Y=Y+.50993217982259985D-11*FCT(X) X=.65184426376135782D2 Y=Y+.38582071909299337D-8*FCT(X) X=.59129027934391951D2 Y=Y+.15723595577851821D-5*FCT(X) X=.53597231826148512D2 Y=Y+.38234137666012857D-3*FCT(X) X=.48514583867416048D2 Y=Y+.59657255685597023D-1*FCT(X) X=.43825886369903902D2 Y=Y+.63045091330075628D1*FCT(X) X=.39488797123368127D2 Y=Y+.47037694213516382D3*FCT(X) X=.35469961396173283D2 Y=Y+.25601867826448761D5*FCT(X) X=.31742543790616606D2 Y=Y+.10437247453181695D7*FCT(X) X=.28284583194970531D2 Y=Y+.32566814614194407D8*FCT(X) X=.25077856544198053D2 Y=Y+.7918355533895448D9*FCT(X) X=.22107070382206007D2 Y=Y+.15230434500290903D11*FCT(X) X=.19359271087268714D2 Y=Y+.23472334846430987D12*FCT(X) X=.16823405362953694D2 Y=Y+.29302506329522187D13*FCT(X) X=.14489986690780274D2 Y=Y+.29910658734544941D14*FCT(X) X=.12350838217714770D2 Y=Y+.25166805020623692D15*FCT(X) X=.10398891905552624D2 Y=Y+.17576998461700718D16*FCT(X) X=.8628029857405929D1 Y=Y+.10251858271572549D17*FCT(X) X=.70329577982838936D1 Y=Y+.50196739702612497D17*FCT(X) X=.56091034574961513D1 Y=Y+.20726581990151553D18*FCT(X) X=.43525345293301410D1 Y=Y+.7245173957068918D18*FCT(X) X=.32598922564569419D1 Y=Y+.21512081019758274D19*FCT(X) X=.23283376682103970D1 Y=Y+.54406257907377837D19*FCT(X) X=.15555082314789380D1 Y=Y+.11747996392819887D20*FCT(X) X=.9394832145007343D0 Y=Y+.21699669861237368D20*FCT(X) X=.47875647727748885D0 Y=Y+.34337168469816740D20*FCT(X) X=.17221572414539558D0 Y=Y+.46598957212535609D20*FCT(X) X=.19127510968446856D-1 Y=Y+.54275484988260796D20*FCT(X) Y=Y*1.D-20 RETURN END C C .................................................................. C C SUBROUTINE DQA4 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA4 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA4(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.8588635689012034D1 Y=.39920814442273524D-3*FCT(X) X=.39269635013582872D1 Y=Y+.34155966014826951D-1*FCT(X) X=.13390972881263614D1 Y=Y+.41560465162978376D0*FCT(X) X=.14530352150331709D0 Y=Y+.13222940251164826D1*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQA8 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQA8 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.15-16. C C .................................................................. C SUBROUTINE DQA8(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.21984272840962651D2 Y=.53096149480223645D-9*FCT(X) X=.14972627088426393D2 Y=Y+.46419616897304213D-6*FCT(X) X=.10093323675221343D2 Y=Y+.54237201850757630D-4*FCT(X) X=.64831454286271704D1 Y=Y+.18645680172483611D-2*FCT(X) X=.38094763614849071D1 Y=Y+.25760623071019947D-1*FCT(X) X=.19051136350314284D1 Y=Y+.16762008279797166D0*FCT(X) X=.67724908764928915D0 Y=Y+.56129491705706735D0*FCT(X) X=.7479188259681827D-1 Y=Y+.10158589580332275D1*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQATR C C C PURPOSE C TO COMPUTE AN APPROXIMATION FOR INTEGRAL(FCT(X), SUMMED C OVER X FROM XL TO XU). C C USAGE C CALL DQATR (XL,XU,EPS,NDIM,FCT,Y,IER,AUX) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C EPS - SINGLE PRECISION UPPER BOUND OF THE ABSOLUTE ERROR. C NDIM - THE DIMENSION OF THE AUXILIARY STORAGE ARRAY AUX. C NDIM-1 IS THE MAXIMAL NUMBER OF BISECTIONS OF C THE INTERVAL (XL,XU). C FCT - THE NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - RESULTING DOUBLE PRECISION APPROXIMATION FOR THE C INTEGRAL VALUE. C IER - A RESULTING ERROR PARAMETER. C AUX - AUXILIARY DOUBLE PRECISION STORAGE ARRAY WITH C DIMENSION NDIM. C C REMARKS C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED ACCURACY. C NO ERROR. C IER=1 - IT IS IMPOSSIBLE TO REACH THE REQUIRED ACCURACY C BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE NDIM C IS LESS THAN 5, OR THE REQUIRED ACCURACY COULD NOT C BE REACHED WITHIN NDIM-1 STEPS. NDIM SHOULD BE C INCREASED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE CODED BY THE USER. ITS DOUBLE PRECISION ARGUMENT X C SHOULD NOT BE DESTROYED. C C METHOD C EVALUATION OF Y IS DONE BY MEANS OF TRAPEZOIDAL RULE IN C CONNECTION WITH ROMBERGS PRINCIPLE. ON RETURN Y CONTAINS C THE BEST POSSIBLE APPROXIMATION OF THE INTEGRAL VALUE AND C VECTOR AUX THE UPWARD DIAGONAL OF ROMBERG SCHEME. C COMPONENTS AUX(I) (I=1,2,...,IEND, WITH IEND LESS THAN OR C EQUAL TO NDIM) BECOME APPROXIMATIONS TO INTEGRAL VALUE WITH C DECREASING ACCURACY BY MULTIPLICATION WITH (XU-XL). C FOR REFERENCE, SEE C (1) FILIPPI, DAS VERFAHREN VON ROMBERG-STIEFEL-BAUER ALS C SPEZIALFALL DES ALLGEMEINEN PRINZIPS VON RICHARDSON, C MATHEMATIK-TECHNIK-WIRTSCHAFT, VOL.11, ISS.2 (1964), C PP.49-54. C (2) BAUER, ALGORITHM 60, CACM, VOL.4, ISS.6 (1961), PP.255. C C .................................................................. C SUBROUTINE DQATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX) C C DIMENSION AUX(1) DOUBLE PRECISION AUX,XL,XU,X,Y,H,HH,HD,P,Q,SM,FCT C C PREPARATIONS OF ROMBERG-LOOP AUX(1)=.5D0*(FCT(XL)+FCT(XU)) H=XU-XL IF(NDIM-1)8,8,1 1 IF(H)2,10,2 C C NDIM IS GREATER THAN 1 AND H IS NOT EQUAL TO 0. 2 HH=H E=EPS/DABS(H) DELT2=0. P=1.D0 JJ=1 DO 7 I=2,NDIM Y=AUX(1) DELT1=DELT2 HD=HH HH=.5D0*HH P=.5D0*P X=XL+HH SM=0.D0 DO 3 J=1,JJ SM=SM+FCT(X) 3 X=X+HD AUX(I)=.5D0*AUX(I-1)+P*SM C A NEW APPROXIMATION OF INTEGRAL VALUE IS COMPUTED BY MEANS OF C TRAPEZOIDAL RULE. C C START OF ROMBERGS EXTRAPOLATION METHOD. Q=1.D0 JI=I-1 DO 4 J=1,JI II=I-J Q=Q+Q Q=Q+Q 4 AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.D0) C END OF ROMBERG-STEP C DELT2=DABS(Y-AUX(1)) IF(I-5)7,5,5 5 IF(DELT2-E)10,10,6 6 IF(DELT2-DELT1)7,11,11 7 JJ=JJ+JJ 8 IER=2 9 Y=H*AUX(1) RETURN 10 IER=0 GO TO 9 11 IER=1 Y=H*Y RETURN END C C .................................................................. C C SUBROUTINE DQG12 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG12 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 12-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 23 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG12(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.49078031712335963D0*B Y=.23587668193255914D-1*(FCT(A+C)+FCT(A-C)) C=.45205862818523743D0*B Y=Y+.53469662997659215D-1*(FCT(A+C)+FCT(A-C)) C=.38495133709715234D0*B Y=Y+.8003916427167311D-1*(FCT(A+C)+FCT(A-C)) C=.29365897714330872D0*B Y=Y+.10158371336153296D0*(FCT(A+C)+FCT(A-C)) C=.18391574949909010D0*B Y=Y+.11674626826917740D0*(FCT(A+C)+FCT(A-C)) C=.62616704255734458D-1*B Y=B*(Y+.12457352290670139D0*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQG16 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG16 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 16-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 31 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG16(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.49470046749582497D0*B Y=.13576229705877047D-1*(FCT(A+C)+FCT(A-C)) C=.47228751153661629D0*B Y=Y+.31126761969323946D-1*(FCT(A+C)+FCT(A-C)) C=.43281560119391587D0*B Y=Y+.47579255841246392D-1*(FCT(A+C)+FCT(A-C)) C=.37770220417750152D0*B Y=Y+.62314485627766936D-1*(FCT(A+C)+FCT(A-C)) C=.30893812220132187D0*B Y=Y+.7479799440828837D-1*(FCT(A+C)+FCT(A-C)) C=.22900838882861369D0*B Y=Y+.8457825969750127D-1*(FCT(A+C)+FCT(A-C)) C=.14080177538962946D0*B Y=Y+.9130170752246179D-1*(FCT(A+C)+FCT(A-C)) C=.47506254918818720D-1*B Y=B*(Y+.9472530522753425D-1*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQG24 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG24 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 24-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 47 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG24(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.49759360999851068D0*B Y=.61706148999935998D-2*(FCT(A+C)+FCT(A-C)) C=.48736427798565475D0*B Y=Y+.14265694314466832D-1*(FCT(A+C)+FCT(A-C)) C=.46913727600136638D0*B Y=Y+.22138719408709903D-1*(FCT(A+C)+FCT(A-C)) C=.44320776350220052D0*B Y=Y+.29649292457718390D-1*(FCT(A+C)+FCT(A-C)) C=.41000099298695146D0*B Y=Y+.36673240705540153D-1*(FCT(A+C)+FCT(A-C)) C=.37006209578927718D0*B Y=Y+.43095080765976638D-1*(FCT(A+C)+FCT(A-C)) C=.32404682596848778D0*B Y=Y+.48809326052056944D-1*(FCT(A+C)+FCT(A-C)) C=.27271073569441977D0*B Y=Y+.53722135057982817D-1*(FCT(A+C)+FCT(A-C)) C=.21689675381302257D0*B Y=Y+.57752834026862801D-1*(FCT(A+C)+FCT(A-C)) C=.15752133984808169D0*B Y=Y+.60835236463901696D-1*(FCT(A+C)+FCT(A-C)) C=.9555943373680815D-1*B Y=Y+.62918728173414148D-1*(FCT(A+C)+FCT(A-C)) C=.32028446431302813D-1*B Y=B*(Y+.63969097673376078D-1*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQG32 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG32 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 32-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 63 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG32(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.49863193092474078D0*B Y=.35093050047350483D-2*(FCT(A+C)+FCT(A-C)) C=.49280575577263417D0*B Y=Y+.8137197365452835D-2*(FCT(A+C)+FCT(A-C)) C=.48238112779375322D0*B Y=Y+.12696032654631030D-1*(FCT(A+C)+FCT(A-C)) C=.46745303796886984D0*B Y=Y+.17136931456510717D-1*(FCT(A+C)+FCT(A-C)) C=.44816057788302606D0*B Y=Y+.21417949011113340D-1*(FCT(A+C)+FCT(A-C)) C=.42468380686628499D0*B Y=Y+.25499029631188088D-1*(FCT(A+C)+FCT(A-C)) C=.39724189798397120D0*B Y=Y+.29342046739267774D-1*(FCT(A+C)+FCT(A-C)) C=.36609105937014484D0*B Y=Y+.32911111388180923D-1*(FCT(A+C)+FCT(A-C)) C=.33152213346510760D0*B Y=Y+.36172897054424253D-1*(FCT(A+C)+FCT(A-C)) C=.29385787862038116D0*B Y=Y+.39096947893535153D-1*(FCT(A+C)+FCT(A-C)) C=.25344995446611470D0*B Y=Y+.41655962113473378D-1*(FCT(A+C)+FCT(A-C)) C=.21067563806531767D0*B Y=Y+.43826046502201906D-1*(FCT(A+C)+FCT(A-C)) C=.16593430114106382D0*B Y=Y+.45586939347881942D-1*(FCT(A+C)+FCT(A-C)) C=.11964368112606854D0*B Y=Y+.46922199540402283D-1*(FCT(A+C)+FCT(A-C)) C=.7223598079139825D-1*B Y=Y+.47819360039637430D-1*(FCT(A+C)+FCT(A-C)) C=.24153832843869158D-1*B Y=B*(Y+.48270044257363900D-1*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQG4 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG4 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 7 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG4(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.43056815579702629D0*B Y=.17392742256872693D0*(FCT(A+C)+FCT(A-C)) C=.16999052179242813D0*B Y=B*(Y+.32607257743127307D0*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQG8 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL DQG8 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - DOUBLE PRECISION LOWER BOUND OF THE INTERVAL. C XU - DOUBLE PRECISION UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 15 C EXACTLY. FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-340. C C .................................................................. C SUBROUTINE DQG8(XL,XU,FCT,Y) C C DOUBLE PRECISION XL,XU,Y,A,B,C,FCT C A=.5D0*(XU+XL) B=XU-XL C=.48014492824876812D0*B Y=.50614268145188130D-1*(FCT(A+C)+FCT(A-C)) C=.39833323870681337D0*B Y=Y+.11119051722668724D0*(FCT(A+C)+FCT(A-C)) C=.26276620495816449D0*B Y=Y+.15685332293894364D0*(FCT(A+C)+FCT(A-C)) C=.9171732124782490D-1*B Y=B*(Y+.18134189168918099D0*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE DQH16 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH16 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 31. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH16(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.46887389393058184D1 Z=-X Y=.26548074740111822D-9*(FCT(X)+FCT(Z)) X=.38694479048601227D1 Z=-X Y=Y+.23209808448652107D-6*(FCT(X)+FCT(Z)) X=.31769991619799560D1 Z=-X Y=Y+.27118600925378815D-4*(FCT(X)+FCT(Z)) X=.25462021578474814D1 Z=-X Y=Y+.9322840086241805D-3*(FCT(X)+FCT(Z)) X=.19517879909162540D1 Z=-X Y=Y+.12880311535509974D-1*(FCT(X)+FCT(Z)) X=.13802585391988808D1 Z=-X Y=Y+.8381004139898583D-1*(FCT(X)+FCT(Z)) X=.8229514491446559D0 Z=-X Y=Y+.28064745852853368D0*(FCT(X)+FCT(Z)) X=.27348104613815245D0 Z=-X Y=Y+.50792947901661374D0*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE DQH24 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH24 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 47. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH24(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.60159255614257397D1 Z=-X Y=.16643684964891089D-15*(FCT(X)+FCT(Z)) X=.52593829276680444D1 Z=-X Y=Y+.65846202430781701D-12*(FCT(X)+FCT(Z)) X=.46256627564237873D1 Z=-X Y=Y+.30462542699875639D-9*(FCT(X)+FCT(Z)) X=.40536644024481495D1 Z=-X Y=Y+.40189711749414297D-7*(FCT(X)+FCT(Z)) X=.35200068130345247D1 Z=-X Y=Y+.21582457049023336D-5*(FCT(X)+FCT(Z)) X=.30125461375655648D1 Z=-X Y=Y+.56886916364043798D-4*(FCT(X)+FCT(Z)) X=.25238810170114270D1 Z=-X Y=Y+.8236924826884175D-3*(FCT(X)+FCT(Z)) X=.20490035736616989D1 Z=-X Y=Y+.70483558100726710D-2*(FCT(X)+FCT(Z)) X=.15842500109616941D1 Z=-X Y=Y+.37445470503230746D-1*(FCT(X)+FCT(Z)) X=.11267608176112451D1 Z=-X Y=Y+.12773962178455916D0*(FCT(X)+FCT(Z)) X=.67417110703721224D0 Z=-X Y=Y+.28617953534644302D0*(FCT(X)+FCT(Z)) X=.22441454747251559D0 Z=-X Y=Y+.42693116386869925D0*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE DQH32 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH32 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 63. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH32(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.71258139098307276D1 Z=-X Y=.7310676427384162D-22*(FCT(X)+FCT(Z)) X=.64094981492696604D1 Z=-X Y=Y+.9231736536518292D-18*(FCT(X)+FCT(Z)) X=.58122259495159138D1 Z=-X Y=Y+.11973440170928487D-14*(FCT(X)+FCT(Z)) X=.52755509865158801D1 Z=-X Y=Y+.42150102113264476D-12*(FCT(X)+FCT(Z)) X=.47771645035025964D1 Z=-X Y=Y+.59332914633966386D-10*(FCT(X)+FCT(Z)) X=.43055479533511984D1 Z=-X Y=Y+.40988321647708966D-8*(FCT(X)+FCT(Z)) X=.38537554854714446D1 Z=-X Y=Y+.15741677925455940D-6*(FCT(X)+FCT(Z)) X=.34171674928185707D1 Z=-X Y=Y+.36505851295623761D-5*(FCT(X)+FCT(Z)) X=.29924908250023742D1 Z=-X Y=Y+.54165840618199826D-4*(FCT(X)+FCT(Z)) X=.25772495377323175D1 Z=-X Y=Y+.53626836552797205D-3*(FCT(X)+FCT(Z)) X=.21694991836061122D1 Z=-X Y=Y+.36548903266544281D-2*(FCT(X)+FCT(Z)) X=.17676541094632016D1 Z=-X Y=Y+.17553428831573430D-1*(FCT(X)+FCT(Z)) X=.13703764109528718D1 Z=-X Y=Y+.60458130955912614D-1*(FCT(X)+FCT(Z)) X=.9765004635896828D0 Z=-X Y=Y+.15126973407664248D0*(FCT(X)+FCT(Z)) X=.58497876543593245D0 Z=-X Y=Y+.27745814230252990D0*(FCT(X)+FCT(Z)) X=.19484074156939933D0 Z=-X Y=Y+.37523835259280239D0*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE DQH48 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH48 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 48-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 95. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH48(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.8975315081931687D1 Z=-X Y=.7935551460773997D-35*(FCT(X)+FCT(Z)) X=.8310752190704784D1 Z=-X Y=Y+.59846126933138784D-30*(FCT(X)+FCT(Z)) X=.7759295519765775D1 Z=-X Y=Y+.36850360801506699D-26*(FCT(X)+FCT(Z)) X=.7266046554164350D1 Z=-X Y=Y+.55645774689022848D-23*(FCT(X)+FCT(Z)) X=.68100645780741414D1 Z=-X Y=Y+.31883873235051384D-20*(FCT(X)+FCT(Z)) X=.63805640961864106D1 Z=-X Y=Y+.8730159601186677D-18*(FCT(X)+FCT(Z)) X=.59710722250135454D1 Z=-X Y=Y+.13151596226584085D-15*(FCT(X)+FCT(Z)) X=.55773169812237286D1 Z=-X Y=Y+.11975898654791794D-13*(FCT(X)+FCT(Z)) X=.51962877187923645D1 Z=-X Y=Y+.70469325815458891D-12*(FCT(X)+FCT(Z)) X=.48257572281332095D1 Z=-X Y=Y+.28152965378381691D-10*(FCT(X)+FCT(Z)) X=.44640145469344589D1 Z=-X Y=Y+.7930467495165382D-9*(FCT(X)+FCT(Z)) X=.41097046035605902D1 Z=-X Y=Y+.16225141358957698D-7*(FCT(X)+FCT(Z)) X=.37617264902283578D1 Z=-X Y=Y+.24686589936697505D-6*(FCT(X)+FCT(Z)) X=.34191659693638846D1 Z=-X Y=Y+.28472586917348481D-5*(FCT(X)+FCT(Z)) X=.30812489886451058D1 Z=-X Y=Y+.25285990277484889D-4*(FCT(X)+FCT(Z)) X=.27473086248223832D1 Z=-X Y=Y+.17515043180117283D-3*(FCT(X)+FCT(Z)) X=.24167609048732165D1 Z=-X Y=Y+.9563923198194153D-3*(FCT(X)+FCT(Z)) X=.20890866609442764D1 Z=-X Y=Y+.41530049119775525D-2*(FCT(X)+FCT(Z)) X=.17638175798953000D1 Z=-X Y=Y+.14444961574981099D-1*(FCT(X)+FCT(Z)) X=.14405252201375652D1 Z=-X Y=Y+.40479676984603849D-1*(FCT(X)+FCT(Z)) X=.11188121524021566D1 Z=-X Y=Y+.9182229707928518D-1*(FCT(X)+FCT(Z)) X=.7983046277785622D0 Z=-X Y=Y+.16920447194564111D0*(FCT(X)+FCT(Z)) X=.47864633759449610D0 Z=-X Y=Y+.25396154266475910D0*(FCT(X)+FCT(Z)) X=.15949293584886247D0 Z=-X Y=Y+.31100103037796308D0*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE DQH64 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH64 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 64-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 127. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH64(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.10526123167960546D2 Z=-X Y=.55357065358569428D-28*(FCT(X)+FCT(Z)) X=.9895287586829539D1 Z=-X Y=Y+.16797479901081592D-22*(FCT(X)+FCT(Z)) X=.9373159549646721D21 Z=-X Y=Y+.34211380112557405D-18*(FCT(X)+FCT(Z)) X=.8907249099964770D1 Z=-X Y=Y+.15573906246297638D-14*(FCT(X)+FCT(Z)) X=.8477529083379863D1 Z=-X Y=Y+.25496608991129993D-11*(FCT(X)+FCT(Z)) X=.8073687285010225D1 Z=-X Y=Y+.19291035954649669D-8*(FCT(X)+FCT(Z)) X=.7689540164040497D1 Z=-X Y=Y+.7861797788925910D-6*(FCT(X)+FCT(Z)) X=.7321013032780949D1 Z=-X Y=Y+.19117068833006428D-3*(FCT(X)+FCT(Z)) X=.69652411205511075D1 Z=-X Y=Y+.29828627842798512D-1*(FCT(X)+FCT(Z)) X=.66201122626360274D1 Z=-X Y=Y+.31522545665037814D1*(FCT(X)+FCT(Z)) X=.62840112287748282D1 Z=-X Y=Y+.23518847106758191D3*(FCT(X)+FCT(Z)) X=.59556663267994860D1 Z=-X Y=Y+.12800933913224380D5*(FCT(X)+FCT(Z)) X=.56340521643499721D1 Z=-X Y=Y+.52186237265908475D6*(FCT(X)+FCT(Z)) X=.53183252246332709D1 Z=-X Y=Y+.16283407307097204D8*(FCT(X)+FCT(Z)) X=.50077796021987682D1 Z=-X Y=Y+.39591777669477239D9*(FCT(X)+FCT(Z)) X=.47018156474074998D1 Z=-X Y=Y+.7615217250145451D10*(FCT(X)+FCT(Z)) X=.43999171682281376D1 Z=-X Y=Y+.11736167423215493D12*(FCT(X)+FCT(Z)) X=.41016344745666567D1 Z=-X Y=Y+.14651253164761094D13*(FCT(X)+FCT(Z)) X=.38065715139453605D1 Z=-X Y=Y+.14955329367272471D14*(FCT(X)+FCT(Z)) X=.35143759357409062D1 Z=-X Y=Y+.12583402510311846D15*(FCT(X)+FCT(Z)) X=.32247312919920357D1 Z=-X Y=Y+.8788499230850359D15*(FCT(X)+FCT(Z)) X=.29373508230046218D1 Z=-X Y=Y+.51259291357862747D16*(FCT(X)+FCT(Z)) X=.26519724354306350D1 Z=-X Y=Y+.25098369851306249D17*(FCT(X)+FCT(Z)) X=.23683545886324014D1 Z=-X Y=Y+.10363290995075777D18*(FCT(X)+FCT(Z)) X=.20862728798817620D1 Z=-X Y=Y+.36225869785344588D18*(FCT(X)+FCT(Z)) X=.18055171714655449D1 Z=-X Y=Y+.10756040509879137D19*(FCT(X)+FCT(Z)) X=.15258891402098637D1 Z=-X Y=Y+.27203128953688918D19*(FCT(X)+FCT(Z)) X=.12472001569431179D1 Z=-X Y=Y+.58739981964099435D19*(FCT(X)+FCT(Z)) X=.9692694230711780D0 Z=-X Y=Y+.10849834930618684D20*(FCT(X)+FCT(Z)) X=.69192230581004458D0 Z=-X Y=Y+.17168584234908370D20*(FCT(X)+FCT(Z)) X=.41498882412107868D0 Z=-X Y=Y+.23299478606267805D20*(FCT(X)+FCT(Z)) X=.13830224498700972D0 Z=-X Y=Y+.27137742494130398D20*(FCT(X)+FCT(Z)) Y=Y*1.D-20 RETURN END C C .................................................................. C C SUBROUTINE DQH8 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL DQH8 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 15. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.213-214. C C .................................................................. C SUBROUTINE DQH8(FCT,Y) C C DOUBLE PRECISION X,Y,Z,FCT C X=.29306374202572440D1 Z=-X Y=.19960407221136762D-3*(FCT(X)+FCT(Z)) X=.19816567566958429D1 Z=-X Y=Y+.17077983007413475D-1*(FCT(X)+FCT(Z)) X=.11571937124467802D1 Z=-X Y=Y+.20780232581489188D0*(FCT(X)+FCT(Z)) X=.38118699020732212D0 Z=-X Y=Y+.66114701255824129D0*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE DQHFE C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION AND DERIVATIVE VALUES. C C USAGE C CALL DQHFE (H,Y,DERY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C DERY - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH Y OR DERY. C NDIM - THE DIMENSION OF VECTORS Y,DERY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE DQHFE(H,Y,DERY,Z,NDIM) C C DIMENSION Y(1),DERY(1),Z(1) DOUBLE PRECISION Y,DERY,Z,H,HH,HS,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H HS=.16666666666666667D0*H C C INTEGRATION LOOP DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DQHFG C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C GENERAL TABLE OF ARGUMENT, FUNCTION, AND DERIVATIVE VALUES. C C USAGE C CALL DQHFG (X,Y,DERY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C DERY - DOUBLE PRECISION INPUT VECTOR OF DERIVATIVE VALUES. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH X, Y OR DERY. C NDIM - THE DIMENSION OF VECTORS X,Y,DERY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE DQHFG(X,Y,DERY,Z,NDIM) C C DIMENSION X(1),Y(1),DERY(1),Z(1) DOUBLE PRECISION X,Y,DERY,Z,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 C C INTEGRATION LOOP 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5D0*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.33333333333333333D0*SUM2* 1(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DQHSE C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION, FIRST DERIVATIVE, C AND SECOND DERIVATIVE VALUES. C C USAGE C CALL DQHSE (H,Y,FDY,SDY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C FDY - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE. C SDY - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH Y, FDY OR SDY. C NDIM - THE DIMENSION OF VECTORS Y,FDY,SDY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE DQHSE(H,Y,FDY,SDY,Z,NDIM) C C DIMENSION Y(1),FDY(1),SDY(1),Z(1) DOUBLE PRECISION Y,FDY,SDY,Z,H,HH,HF,HT,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H HF=.2D0*H HT=.08333333333333333D0*H C C INTEGRATION LOOP DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+ 1 HT*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DQHSG C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C GENERAL TABLE OF ARGUMENT, FUNCTION, FIRST DERIVATIVE, C AND SECOND DERIVATIVE VALUES. C C USAGE C CALL DQHSG (X,Y,FDY,SDY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C FDY - DOUBLE PRECISION INPUT VECTOR OF FIRST DERIVATIVE. C SDY - DOUBLE PRECISION INPUT VECTOR OF SECOND DERIVATIVE. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH X, Y, FDY OR SDY. C NDIM - THE DIMENSION OF VECTORS X,Y,FDY,SDY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE DQHSG(X,Y,FDY,SDY,Z,NDIM) C C DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1) DOUBLE PRECISION X,Y,FDY,SDY,Z,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 C C INTEGRATION LOOP 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5D0*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4D0*SUM2*((FDY(I-1)-FDY(I))+ 1 .16666666666666667D0*SUM2*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DQL12 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL12 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 12-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 23. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL12(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.37099121044466920D2 Y=.8148077467426242D-15*FCT(X) X=.28487967250984000D2 Y=Y+.30616016350350208D-11*FCT(X) X=.22151090379397006D2 Y=Y+.13423910305150041D-8*FCT(X) X=.17116855187462256D2 Y=Y+.16684938765409103D-6*FCT(X) X=.13006054993306348D2 Y=Y+.8365055856819799D-5*FCT(X) X=.9621316842456867D1 Y=Y+.20323159266299939D-3*FCT(X) X=.68445254531151773D1 Y=Y+.26639735418653159D-2*FCT(X) X=.45992276394183485D1 Y=Y+.20102381154634097D-1*FCT(X) X=.28337513377435072D1 Y=Y+.9044922221168093D-1*FCT(X) X=.15126102697764188D1 Y=Y+.24408201131987756D0*FCT(X) X=.61175748451513067D0 Y=Y+.37775927587313798D0*FCT(X) X=.11572211735802068D0 Y=Y+.26473137105544319D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQL16 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL16 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 16-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 31. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL16(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.51701160339543318D2 Y=.41614623703728552D-21*FCT(X) X=.41940452647688333D2 Y=Y+.50504737000355128D-17*FCT(X) X=.34583398702286626D2 Y=Y+.62979670025178678D-14*FCT(X) X=.28578729742882140D2 Y=Y+.21270790332241030D-11*FCT(X) X=.23515905693991909D2 Y=Y+.28623502429738816D-9*FCT(X) X=.19180156856753135D2 Y=Y+.18810248410796732D-7*FCT(X) X=.15441527368781617D2 Y=Y+.68283193308711996D-6*FCT(X) X=.12214223368866159D2 Y=Y+.14844586873981299D-4*FCT(X) X=.9438314336391939D1 Y=Y+.20427191530827846D-3*FCT(X) X=.70703385350482341D1 Y=Y+.18490709435263109D-2*FCT(X) X=.50780186145497679D1 Y=Y+.11299900080339453D-1*FCT(X) X=.34370866338932066D1 Y=Y+.47328928694125219D-1*FCT(X) X=.21292836450983806D1 Y=Y+.13629693429637754D0*FCT(X) X=.11410577748312269D1 Y=Y+.26579577764421415D0*FCT(X) X=.46269632891508083D0 Y=Y+.33105785495088417D0*FCT(X) X=.8764941047892784D-1 Y=Y+.20615171495780099D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQL24 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL24 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 24-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 47. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL24(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.8149827923394889D2 Y=.55753457883283568D-34*FCT(X) X=.69962240035105030D2 Y=Y+.40883015936806578D-29*FCT(X) X=.61058531447218762D2 Y=Y+.24518188458784027D-25*FCT(X) X=.53608574544695070D2 Y=Y+.36057658645529590D-22*FCT(X) X=.47153106445156323D2 Y=Y+.20105174645555035D-19*FCT(X) X=.41451720484870767D2 Y=Y+.53501888130100376D-17*FCT(X) X=.36358405801651622D2 Y=Y+.7819800382459448D-15*FCT(X) X=.31776041352374723D2 Y=Y+.68941810529580857D-13*FCT(X) X=.27635937174332717D2 Y=Y+.39177365150584514D-11*FCT(X) X=.23887329848169733D2 Y=Y+.15070082262925849D-9*FCT(X) X=.20491460082616425D2 Y=Y+.40728589875499997D-8*FCT(X) X=.17417992646508979D2 Y=Y+.7960812959133630D-7*FCT(X) X=.14642732289596674D2 Y=Y+.11513158127372799D-5*FCT(X) X=.12146102711729766D2 Y=Y+.12544721977993333D-4*FCT(X) X=.9912098015077706D1 Y=Y+.10446121465927518D-3*FCT(X) X=.7927539247172152D1 Y=Y+.67216256409354789D-3*FCT(X) X=.61815351187367654D1 Y=Y+.33693490584783036D-2*FCT(X) X=.46650837034671708D1 Y=Y+.13226019405120157D-1*FCT(X) X=.33707742642089977D1 Y=Y+.40732478151408646D-1*FCT(X) X=.22925620586321903D1 Y=Y+.9816627262991889D-1*FCT(X) X=.14255975908036131D1 Y=Y+.18332268897777802D0*FCT(X) X=.7660969055459366D0 Y=Y+.25880670727286980D0*FCT(X) X=.31123914619848373D0 Y=Y+.25877410751742390D0*FCT(X) X=.59019852181507977D-1 Y=Y+.14281197333478185D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQL32 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL32 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 32-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 63. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL32(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.11175139809793770D3 Y=.45105361938989742D-27*FCT(X) X=.9882954286828397D2 Y=Y+.13386169421062563D-21*FCT(X) X=.8873534041789240D2 Y=Y+.26715112192401370D-17*FCT(X) X=.8018744697791352D2 Y=Y+.11922487600982224D-13*FCT(X) X=.7268762809066271D2 Y=Y+.19133754944542243D-10*FCT(X) X=.65975377287935053D2 Y=Y+.14185605454630369D-7*FCT(X) X=.59892509162134018D2 Y=Y+.56612941303973594D-5*FCT(X) X=.54333721333396907D2 Y=Y+.13469825866373952D-2*FCT(X) X=.49224394987308639D2 Y=Y+.20544296737880454D0*FCT(X) X=.44509207995754938D2 Y=Y+.21197922901636186D2*FCT(X) X=.40145719771539442D2 Y=Y+.15421338333938234D4*FCT(X) X=.36100494805751974D2 Y=Y+.8171823443420719D5*FCT(X) X=.32346629153964737D2 Y=Y+.32378016577292665D7*FCT(X) X=.28862101816323475D2 Y=Y+.9799379288727094D8*FCT(X) X=.25628636022459248D2 Y=Y+.23058994918913361D10*FCT(X) X=.22630889013196774D2 Y=Y+.42813829710409289D11*FCT(X) X=.19855860940336055D2 Y=Y+.63506022266258067D12*FCT(X) X=.17292454336715315D2 Y=Y+.7604567879120781D13*FCT(X) X=.14931139755522557D2 Y=Y+.7416404578667552D14*FCT(X) X=.12763697986742725D2 Y=Y+.59345416128686329D15*FCT(X) X=.10783018632539972D2 Y=Y+.39203419679879472D16*FCT(X) X=.8982940924212596D1 Y=Y+.21486491880136419D17*FCT(X) X=.7358126733186241D1 Y=Y+.9808033066149551D17*FCT(X) X=.59039585041742439D1 Y=Y+.37388162946115248D18*FCT(X) X=.46164567697497674D1 Y=Y+.11918214834838557D19*FCT(X) X=.34922132730219945D1 Y=Y+.31760912509175070D19*FCT(X) X=.25283367064257949D1 Y=Y+.70578623865717442D19*FCT(X) X=.17224087764446454D1 Y=Y+.12998378628607176D20*FCT(X) X=.10724487538178176D1 Y=Y+.19590333597288104D20*FCT(X) X=.57688462930188643D0 Y=Y+.23521322966984801D20*FCT(X) X=.23452610951961854D0 Y=Y+.21044310793881323D20*FCT(X) X=.44489365833267018D-1 Y=Y+.10921834195238497D20*FCT(X) Y=Y*1.D-20 RETURN END C C .................................................................. C C SUBROUTINE DQL4 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL4 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL4(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.9395070912301133D1 Y=.53929470556132745D-3*FCT(X) X=.45366202969211280D1 Y=Y+.38887908515005384D-1*FCT(X) X=.17457611011583466D1 Y=Y+.35741869243779969D0*FCT(X) X=.32254768961939231D0 Y=Y+.60315410434163360D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQL8 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL DQL8 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C Y - THE RESULTING DOUBLE PRECISION INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15. C FOR REFERENCE, SEE C SHAO/CHEN/FRANK, TABLES OF ZEROS AND GAUSSIAN WEIGHTS OF C CERTAIN ASSOCIATED LAGUERRE POLYNOMIALS AND THE RELATED C GENERALIZED HERMITE POLYNOMIALS, IBM TECHNICAL REPORT C TR00.1100 (MARCH 1964), PP.24-25. C C .................................................................. C SUBROUTINE DQL8(FCT,Y) C C DOUBLE PRECISION X,Y,FCT C X=.22863131736889264D2 Y=.10480011748715104D-8*FCT(X) X=.15740678641278005D2 Y=Y+.8485746716272532D-6*FCT(X) X=.10758516010180995D2 Y=Y+.9076508773358213D-4*FCT(X) X=.70459054023934657D1 Y=Y+.27945362352256725D-2*FCT(X) X=.42667001702876588D1 Y=Y+.33343492261215652D-1*FCT(X) X=.22510866298661307D1 Y=Y+.17579498663717181D0*FCT(X) X=.9037017767993799D0 Y=Y+.41878678081434296D0*FCT(X) X=.17027963230510100D0 Y=Y+.36918858934163753D0*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE DQSF C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION VALUES. C C USAGE C CALL DQSF (H,Y,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH Y. C NDIM - THE DIMENSION OF VECTORS Y AND Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 3. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A C COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF C ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3 C TRUNCATION ERROR OF Z(2) IS OF ORDER H**4. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.214-221. C C .................................................................. C SUBROUTINE DQSF(H,Y,Z,NDIM) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,H,HT,SUM1,SUM2,AUX,AUX1,AUX2 C HT=.33333333333333333D0*H IF(NDIM-5)7,8,1 C C NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP 1 SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(3)+AUX1+Y(5)) AUX2=HT*(Y(1)+3.875D0*(Y(2)+Y(5))+2.625D0*(Y(3)+Y(4))+Y(6)) SUM2=Y(5)+Y(5) SUM2=SUM2+SUM2 SUM2=AUX2-HT*(Y(4)+SUM2+Y(6)) Z(1)=0.D0 AUX=Y(3)+Y(3) AUX=AUX+AUX Z(2)=SUM2-HT*(Y(2)+AUX+Y(4)) Z(3)=SUM1 Z(4)=SUM2 IF(NDIM-6)5,5,2 C C INTEGRATION LOOP 2 DO 4 I=7,NDIM,2 SUM1=AUX1 SUM2=AUX2 AUX1=Y(I-1)+Y(I-1) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I)) Z(I-2)=SUM1 IF(I-NDIM)3,6,6 3 AUX2=Y(I)+Y(I) AUX2=AUX2+AUX2 AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1)) 4 Z(I-1)=SUM2 5 Z(NDIM-1)=AUX1 Z(NDIM)=AUX2 RETURN 6 Z(NDIM-1)=SUM2 Z(NDIM)=AUX1 RETURN C END OF INTEGRATION LOOP C 7 IF(NDIM-3)12,11,8 C C NDIM IS EQUAL TO 4 OR 5 8 SUM2=1.125D0*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4)) SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) Z(1)=0.D0 AUX1=Y(3)+Y(3) AUX1=AUX1+AUX1 Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4)) IF(NDIM-5)10,9,9 9 AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5)) 10 Z(3)=SUM1 Z(4)=SUM2 RETURN C C NDIM IS EQUAL TO 3 11 SUM1=HT*(1.25D0*Y(1)+Y(2)+Y(2)-.25D0*Y(3)) SUM2=Y(2)+Y(2) SUM2=SUM2+SUM2 Z(3)=HT*(Y(1)+SUM2+Y(3)) Z(1)=0.D0 Z(2)=SUM1 12 RETURN END C C .................................................................. C C SUBROUTINE DQTFE C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION VALUES. C C USAGE C CALL DQTFE (H,Y,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - DOUBLE PRECISION INCREMENT OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH Y. C NDIM - THE DIMENSION OF VECTORS Y AND Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA). C FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75. C C .................................................................. C SUBROUTINE DQTFE(H,Y,Z,NDIM) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,H,HH,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H C C INTEGRATION LOOP DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DQTFG C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C GENERAL TABLE OF ARGUMENT AND FUNCTION VALUES. C C USAGE C CALL DQTFG (X,Y,Z,NDIM) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION INPUT VECTOR OF ARGUMENT VALUES. C Y - DOUBLE PRECISION INPUT VECTOR OF FUNCTION VALUES. C Z - RESULTING DOUBLE PRECISION VECTOR OF INTEGRAL C VALUES. Z MAY BE IDENTICAL WITH X OR Y. C NDIM - THE DIMENSION OF VECTORS X,Y,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF TRAPEZOIDAL RULE (SECOND ORDER FORMULA). C FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.75. C C .................................................................. C SUBROUTINE DQTFG(X,Y,Z,NDIM) C C DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,SUM1,SUM2 C SUM2=0.D0 IF(NDIM-1)4,3,1 C C INTEGRATION LOOP 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+.5D0*(X(I)-X(I-1))*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE DRHARM C C PURPOSE C FINDS THE FOURIER COEFFICIENTS OF ONE DIMENSIONAL DOUBLE C PRECISION REAL DATA C C USAGE C CALL DRHARM(A,M,INV,S,IFERR) C C DESCRIPTION OF PARAMETERS C A - A DOUBLE PRECISION VECTOR C AS INPUT, CONTAINS ONE DIMENSIONAL REAL DATA. A IS C 2*N+4 CORE LOCATIONS, WHERE N = 2**M. 2*N REAL C NUMBERS ARE PUT INTO THE FIRST 2*N CORE LOCATIONS C OF A C AS OUTPUT, A CONTAINS THE FOURIER COEFFICIENTS C A0/2,B0=0,A1,B1,A2,B2,...,AN/2,BN=0 RESPECTIVELY IN C THE FIRST 2N+2 CORE LOCATIONS OF A C M - AN INTEGER WHICH DETERMINES THE SIZE OF THE VECTOR C A. THE SIZE OF A IS 2*(2**M) + 4 C INV - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION OF C DIMENSION ONE EIGHTH THE NUMBER OF REAL INPUT, VIZ., C (1/8)*2*(2**M) C S - A DOUBLE PRECISION VECTOR WORK AREA FOR SINE TABLES C WITH DIMENSION THE SAME AS INV C IFERR - A RETURNED VALUE OF 1 MEANS THAT M IS LESS THAN 3 OR C GREATER THAN 20. OTHERWISE IFERR IS SET = 0 C C REMARKS C THIS SUBROUTINE GIVES THE FOURIER COEFFICIENTS OF 2*(2**M) C REAL POINTS. SEE SUBROUTINE DHARM FOR THREE DIMENSIONAL, C DOUBLE PRECISION, COMPLEX FOURIER TRANSFORMS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DHARM C C METHOD C THE FOURIER COEFFICIENTS A0,B0=0,A1,B1,...,AN,BN=0 ARE C OBTAINED FOR INPUT XJ, J=0,1,2,...,2N-1 FOR THE FOLLOWING C EQUATION (PI = 3.14159...) C C N-1 J C XJ=(1/2)A0+SUM (AK*COS(PI*J*K/N)+BK*SIN(PI*J*K/N))+(1/2)AN(-1) C K=1 C C SEE REFERENCE UNDER SUBROUTINE DHARM C C .................................................................. C SUBROUTINE DRHARM(A,M,INV,S,IFERR) DIMENSION A(1),L(3),INV(1),S(1) DOUBLE PRECISION A,SI,AP1IM,FN,CO,CIRE,AP2IM,S,SS,DEL,CIIM,AP1RE, 1 CNIRE,SC,SIS,AP2RE,CNIIM IFSET=1 L(1)=M L(2)=0 L(3)=0 NTOT=2**M NTOT2 = 2*NTOT FN = NTOT DO 3 I = 2,NTOT2,2 3 A(I) = -A(I) DO 6 I = 1,NTOT2 6 A(I) = A(I)/FN CALL DHARM(A,L,INV,S,IFSET,IFERR) C C MOVE LAST HALF OF A(J)S DOWN ONE SLOT AND ADD A(N) AT BOTTOM TO C GIVE ARRAY FOR A1PRIME AND A2PRIME CALCULATION C 21 DO 52 I=1,NTOT,2 J0=NTOT2+2-I A(J0)=A(J0-2) 52 A(J0+1)=A(J0-1) A(NTOT2+3)=A(1) A(NTOT2+4)=A(2) C C CALCULATE A1PRIMES AND STORE IN FIRST N SLOTS C CALCULATE A2PRIMES AND STORE IN SECOND N SLOTS IN REVERSE ORDER K0=NTOT+1 DO 104 I=1,K0,2 K1=NTOT2-I+4 AP1RE=.5*(A(I)+A(K1)) AP2RE=-.5*(A(I+1)+A(K1+1)) AP1IM=.5*(-A(I+1)+A(K1+1)) AP2IM=-.5*(A(I)-A(K1)) A(I)=AP1RE A(I+1)=AP1IM A(K1)=AP2RE 104 A(K1+1)=AP2IM NTO = NTOT/2 110 NT=NTO+1 DEL=3.141592653589793/DFLOAT(NTOT) SS=DSIN(DEL) SC=DCOS(DEL) SI=0.0 CO=1.0 C C COMPUTE C(J)S FOR J=0 THRU J=N 114 DO 116 I=1,NT K6=NTOT2-2*I+5 AP2RE=A(K6)*CO+A(K6+1)*SI AP2IM=-A(K6)*SI+A(K6+1)*CO CIRE=.5*(A(2*I-1)+AP2RE) CIIM=.5*(A(2*I)+AP2IM) CNIRE=.5*(A(2*I-1)-AP2RE) CNIIM=.5*(A(2*I)-AP2IM) A(2*I-1)=CIRE A(2*I)=CIIM A(K6)=CNIRE A(K6+1)=-CNIIM SIS=SI SI=SI*SC+CO*SS 116 CO=CO*SC-SIS*SS C C SHIFT C(J)S FOR J=N/2+1 TO J=N UP ONE SLOT DO 117 I=1,NTOT,2 K8=NTOT+4+I A(K8-2)=A(K8) 117 A(K8-1)=A(K8+1) DO 500 I=3,NTOT2,2 A(I) = 2. * A(I) 500 A(I + 1) = -2. * A(I + 1) RETURN END C C .................................................................. C C SUBROUTINE DRKGS C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL DRKGS (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - DOUBLE PRECISION INPUT AND OUTPUT VECTOR WITH C DIMENSION GREATER THAN OR EQUAL TO 5, WHICH C SPECIFIES THE PARAMETERS OF THE INTERVAL AND OF C ACCURACY AND WHICH SERVES FOR COMMUNICATION BETWEEN C OUTPUT SUBROUTINE (FURNISHED BY THE USER) AND C SUBROUTINE DRKGS. EXCEPT PRMT(5) THE COMPONENTS C ARE NOT DESTROYED BY SUBROUTINE DRKGS AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE DRKGS INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE DRKGS AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE DRKGS DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING DRKGS) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - DOUBLE PRECISION INPUT VECTOR OF INITIAL VALUES C (DESTROYED). LATERON Y IS THE RESULTING VECTOR OF C DEPENDENT VARIABLES COMPUTED AT INTERMEDIATE C POINTS X. C DERY - DOUBLE PRECISION INPUT VECTOR OF ERROR WEIGHTS C (DESTROYED). THE SUM OF ITS COMPONENTS MUST BE C EQUAL TO 1. LATERON DERY IS THE VECTOR OF C DERIVATIVES, WHICH BELONG TO FUNCTION VALUES Y AT C INTERMEDIATE POINTS X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE DRKGS RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. ERROR C MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. THIS C SUBROUTINE COMPUTES THE RIGHT HAND SIDES DERY OF C THE SYSTEM TO GIVEN VALUES X AND Y. ITS PARAMETER C LIST MUST BE X,Y,DERY. SUBROUTINE FCT SHOULD C NOT DESTROY X AND Y. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE DRKGS IS TERMINATED. C AUX - DOUBLE PRECISION AUXILIARY STORAGE ARRAY WITH 8 C ROWS AND NDIM COLUMNS. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF FOURTH ORDER RUNGE-KUTTA C FORMULAE IN THE MODIFICATION DUE TO GILL. ACCURACY IS C TESTED COMPARING THE RESULTS OF THE PROCEDURE WITH SINGLE C AND DOUBLE INCREMENT. C SUBROUTINE DRKGS AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. IF MORE THAN C 10 BISECTIONS OF THE INCREMENT ARE NECESSARY TO GET C SATISFACTORY ACCURACY, THE SUBROUTINE RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE FURNISHED BY THE USER. C FOR REFERENCE, SEE C RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL COMPUTERS, C WILEY, NEW YORK/LONDON, 1960, PP.110-120. C C .................................................................. C SUBROUTINE DRKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C C DIMENSION Y(1),DERY(1),AUX(8,1),A(4),B(4),C(4),PRMT(1) DOUBLE PRECISION PRMT,Y,DERY,AUX,A,B,C,X,XEND,H,AJ,BJ,CJ,R1,R2, 1DELT DO 1 I=1,NDIM 1 AUX(8,I)=.066666666666666667D0*DERY(I) X=PRMT(1) XEND=PRMT(2) H=PRMT(3) PRMT(5)=0.D0 CALL FCT(X,Y,DERY) C C ERROR TEST IF(H*(XEND-X))38,37,2 C C PREPARATIONS FOR RUNGE-KUTTA METHOD 2 A(1)=.5D0 A(2)=.29289321881345248D0 A(3)=1.7071067811865475D0 A(4)=.16666666666666667D0 B(1)=2.D0 B(2)=1.D0 B(3)=1.D0 B(4)=2.D0 C(1)=.5D0 C(2)=.29289321881345248D0 C(3)=1.7071067811865475D0 C(4)=.5D0 C C PREPARATIONS OF FIRST RUNGE-KUTTA STEP DO 3 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=0.D0 3 AUX(6,I)=0.D0 IREC=0 H=H+H IHLF=-1 ISTEP=0 IEND=0 C C C START OF A RUNGE-KUTTA STEP 4 IF((X+H-XEND)*H)7,6,5 5 H=XEND-X 6 IEND=1 C C RECORDING OF INITIAL VALUES OF THIS STEP 7 CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT) IF(PRMT(5))40,8,40 8 ITEST=0 9 ISTEP=ISTEP+1 C C C START OF INNERMOST RUNGE-KUTTA LOOP J=1 10 AJ=A(J) BJ=B(J) CJ=C(J) DO 11 I=1,NDIM R1=H*DERY(I) R2=AJ*(R1-BJ*AUX(6,I)) Y(I)=Y(I)+R2 R2=R2+R2+R2 11 AUX(6,I)=AUX(6,I)+R2-CJ*R1 IF(J-4)12,15,15 12 J=J+1 IF(J-3)13,14,13 13 X=X+.5D0*H 14 CALL FCT(X,Y,DERY) GOTO 10 C END OF INNERMOST RUNGE-KUTTA LOOP C C C TEST OF ACCURACY 15 IF(ITEST)16,16,20 C C IN CASE ITEST=0 THERE IS NO POSSIBILITY FOR TESTING OF ACCURACY 16 DO 17 I=1,NDIM 17 AUX(4,I)=Y(I) ITEST=1 ISTEP=ISTEP+ISTEP-2 18 IHLF=IHLF+1 X=X-H H=.5D0*H DO 19 I=1,NDIM Y(I)=AUX(1,I) DERY(I)=AUX(2,I) 19 AUX(6,I)=AUX(3,I) GOTO 9 C C IN CASE ITEST=1 TESTING OF ACCURACY IS POSSIBLE 20 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)21,23,21 21 CALL FCT(X,Y,DERY) DO 22 I=1,NDIM AUX(5,I)=Y(I) 22 AUX(7,I)=DERY(I) GOTO 9 C C COMPUTATION OF TEST VALUE DELT 23 DELT=0.D0 DO 24 I=1,NDIM 24 DELT=DELT+AUX(8,I)*DABS(AUX(4,I)-Y(I)) IF(DELT-PRMT(4))28,28,25 C C ERROR IS TOO GREAT 25 IF(IHLF-10)26,36,36 26 DO 27 I=1,NDIM 27 AUX(4,I)=AUX(5,I) ISTEP=ISTEP+ISTEP-4 X=X-H IEND=0 GOTO 18 C C RESULT VALUES ARE GOOD 28 CALL FCT(X,Y,DERY) DO 29 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=AUX(6,I) Y(I)=AUX(5,I) 29 DERY(I)=AUX(7,I) CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))40,30,40 30 DO 31 I=1,NDIM Y(I)=AUX(1,I) 31 DERY(I)=AUX(2,I) IREC=IHLF IF(IEND)32,32,39 C C INCREMENT GETS DOUBLED 32 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H IF(IHLF)4,33,33 33 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)4,34,4 34 IF(DELT-.02D0*PRMT(4))35,35,4 35 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H GOTO 4 C C C RETURNS TO CALLING PROGRAM 36 IHLF=11 CALL FCT(X,Y,DERY) GOTO 39 37 IHLF=12 GOTO 39 38 IHLF=13 39 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) 40 RETURN END C C .................................................................. C C SUBROUTINE DRTMI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM FCT(X)=0 C BY MEANS OF MUELLER-S ITERATION METHOD. C C USAGE C CALL DRTMI (X,F,FCT,XLI,XRI,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION RESULTANT ROOT OF EQUATION C FCT(X)=0. C F - DOUBLE PRECISION RESULTANT FUNCTION VALUE C AT ROOT X. C FCT - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C XLI - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE C INITIAL LEFT BOUND OF THE ROOT X. C XRI - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE C INITIAL RIGHT BOUND OF THE ROOT X. C EPS - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE C UPPER BOUND OF THE ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS C FOLLOWED BY IEND SUCCESSIVE STEPS OF C BISECTION, C IER=2 - BASIC ASSUMPTION FCT(XLI)*FCT(XRI) LESS C THAN OR EQUAL TO ZERO IS NOT SATISFIED. C C REMARKS C THE PROCEDURE ASSUMES THAT FUNCTION VALUES AT INITIAL C BOUNDS XLI AND XRI HAVE NOT THE SAME SIGN. IF THIS BASIC C ASSUMPTION IS NOT SATISFIED BY INPUT VALUES XLI AND XRI, THE C PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C SOLUTION OF EQUATION FCT(X)=0 IS DONE BY MEANS OF MUELLER-S C ITERATION METHOD OF SUCCESSIVE BISECTIONS AND INVERSE C PARABOLIC INTERPOLATION, WHICH STARTS AT THE INITIAL BOUNDS C XLI AND XRI. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF C FCT(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP C REQUIRES TWO EVALUATIONS OF FCT(X). FOR TEST ON SATISFACTORY C ACCURACY SEE FORMULAE (3,4) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE G. K. KRISTIANSEN, ZERO OF ARBITRARY C FUNCTION, BIT, VOL. 3 (1963), PP.205-206. C C .................................................................. C SUBROUTINE DRTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER) C C DOUBLE PRECISION X,F,FCT,XLI,XRI,XL,XR,FL,FR,TOL,TOLF,A,DX,XM,FM C C PREPARE ITERATION IER=0 XL=XLI XR=XRI X=XL TOL=X F=FCT(TOL) IF(F)1,16,1 1 FL=F X=XR TOL=X F=FCT(TOL) IF(F)2,16,2 2 FR=F IF(DSIGN(1.D0,FL)+DSIGN(1.D0,FR))25,3,25 C C BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED. C GENERATE TOLERANCE FOR FUNCTION VALUES. 3 I=0 TOLF=100.*EPS C C C START ITERATION LOOP 4 I=I+1 C C START BISECTION LOOP DO 13 K=1,IEND X=.5D0*(XL+XR) TOL=X F=FCT(TOL) IF(F)5,16,5 5 IF(DSIGN(1.D0,F)+DSIGN(1.D0,FR))7,6,7 C C INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR 6 TOL=XL XL=XR XR=TOL TOL=FL FL=FR FR=TOL 7 TOL=F-FL A=F*TOL A=A+A IF(A-FR*(FR-FL))8,9,9 8 IF(I-IEND)17,17,9 9 XR=X FR=F C C TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP TOL=EPS A=DABS(XR) IF(A-1.D0)11,11,10 10 TOL=TOL*A 11 IF(DABS(XR-XL)-TOL)12,12,13 12 IF(DABS(FR-FL)-TOLF)14,14,13 13 CONTINUE C END OF BISECTION LOOP C C NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND C SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION C VALUES AT RIGHT BOUNDS. ERROR RETURN. IER=1 14 IF(DABS(FR)-DABS(FL))16,16,15 15 X=XL F=FL 16 RETURN C C COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION 17 A=FR-F DX=(X-XL)*FL*(1.D0+F*(A-TOL)/(A*(FR-FL)))/TOL XM=X FM=F X=XL-DX TOL=X F=FCT(TOL) IF(F)18,16,18 C C TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP 18 TOL=EPS A=DABS(X) IF(A-1.D0)20,20,19 19 TOL=TOL*A 20 IF(DABS(DX)-TOL)21,21,22 21 IF(DABS(F)-TOLF)16,16,22 C C PREPARATION OF NEXT BISECTION LOOP 22 IF(DSIGN(1.D0,F)+DSIGN(1.D0,FL))24,23,24 23 XR=X FR=F GO TO 4 24 XL=X FL=F XR=XM FR=FM GO TO 4 C END OF ITERATION LOOP C C C ERROR RETURN IN CASE OF WRONG INPUT DATA 25 IER=2 RETURN END C C .................................................................. C C SUBROUTINE DRTNI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM F(X)=0 C BY MEANS OF NEWTON-S ITERATION METHOD. C C USAGE C CALL DRTNI (X,F,DERF,FCT,XST,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION RESULTANT ROOT OF EQUATION F(X)=0. C F - DOUBLE PRECISION RESULTANT FUNCTION VALUE AT C ROOT X. C DERF - DOUBLE PRECISION RESULTANT VALUE OF DERIVATIVE C AT ROOT X. C FCT - NAME OF THE EXTERNAL SUBROUTINE USED. IT COMPUTES C TO GIVEN ARGUMENT X FUNCTION VALUE F AND DERIVATIVE C DERF. ITS PARAMETER LIST MUST BE X,F,DERF, WHERE C ALL PARAMETERS ARE DOUBLE PRECISION. C XST - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE C INITIAL GUESS OF THE ROOT X. C EPS - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE C UPPER BOUND OF THE ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS, C IER=2 - AT ANY ITERATION STEP DERIVATIVE DERF WAS C EQUAL TO ZERO. C C REMARKS C THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2 C IF AT ANY ITERATION STEP DERIVATIVE OF F(X) IS EQUAL TO 0. C POSSIBLY THE PROCEDURE WOULD BE SUCCESSFUL IF IT IS STARTED C ONCE MORE WITH ANOTHER INITIAL GUESS XST. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FCT(X,F,DERF) MUST BE FURNISHED C BY THE USER. C C METHOD C SOLUTION OF EQUATION F(X)=0 IS DONE BY MEANS OF NEWTON-S C ITERATION METHOD, WHICH STARTS AT THE INITIAL GUESS XST OF C A ROOT X. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF C F(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP C REQUIRES ONE EVALUATION OF F(X) AND ONE EVALUATION OF THE C DERIVATIVE OF F(X). FOR TEST ON SATISFACTORY ACCURACY SEE C FORMULAE (2) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE R. ZURMUEHL, PRAKTISCHE MATHEMATIK FUER C INGENIEURE UND PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/ C HEIDELBERG, 1963, PP.12-17. C C .................................................................. C SUBROUTINE DRTNI(X,F,DERF,FCT,XST,EPS,IEND,IER) C C DOUBLE PRECISION X,F,DERF,XST,TOL,TOLF,DX,A C C PREPARE ITERATION IER=0 X=XST TOL=X CALL FCT(TOL,F,DERF) TOLF=100.*EPS C C C START ITERATION LOOP DO 6 I=1,IEND IF(F)1,7,1 C C EQUATION IS NOT SATISFIED BY X 1 IF(DERF)2,8,2 C C ITERATION IS POSSIBLE 2 DX=F/DERF X=X-DX TOL=X CALL FCT(TOL,F,DERF) C C TEST ON SATISFACTORY ACCURACY TOL=EPS A=DABS(X) IF(A-1.D0)4,4,3 3 TOL=TOL*A 4 IF(DABS(DX)-TOL)5,5,6 5 IF(DABS(F)-TOLF)7,7,6 6 CONTINUE C END OF ITERATION LOOP C C C NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN. IER=1 7 RETURN C C ERROR RETURN IN CASE OF ZERO DIVISOR 8 IER=2 RETURN END C C .................................................................. C C SUBROUTINE DRTWI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM X=FCT(X) C BY MEANS OF WEGSTEIN-S ITERATION METHOD. C C USAGE C CALL DRTWI (X,VAL,FCT,XST,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION RESULTANT ROOT OF EQUATION C X=FCT(X). C VAL - DOUBLE PRECISION RESULTANT VALUE OF X-FCT(X) C AT ROOT X. C FCT - NAME OF THE EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. C XST - DOUBLE PRECISION INPUT VALUE WHICH SPECIFIES THE C INITIAL GUESS OF THE ROOT X. C EPS - SINGLE PRECISION INPUT VALUE WHICH SPECIFIES THE C UPPER BOUND OF THE ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS, C IER=2 - AT ANY ITERATION STEP THE DENOMINATOR OF C ITERATION FORMULA WAS EQUAL TO ZERO. C C REMARKS C THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2 C IF AT ANY ITERATION STEP THE DENOMINATOR OF ITERATION C FORMULA WAS EQUAL TO ZERO. THAT MEANS THAT THERE IS AT C LEAST ONE POINT IN THE RANGE IN WHICH ITERATION MOVES WITH C DERIVATIVE OF FCT(X) EQUAL TO 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL DOUBLE PRECISION FUNCTION SUBPROGRAM FCT(X) C MUST BE FURNISHED BY THE USER. C C METHOD C SOLUTION OF EQUATION X=FCT(X) IS DONE BY MEANS OF C WEGSTEIN-S ITERATION METHOD, WHICH STARTS AT THE INITIAL C GUESS XST OF A ROOT X. ONE ITERATION STEP REQUIRES ONE C EVALUATION OF FCT(X). FOR TEST ON SATISFACTORY ACCURACY SEE C FORMULAE (2) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE C (1) G. N. LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS, C ILIFFE, LONDON, 1960, PP.134-138, C (2) J. WEGSTEIN, ALGORITHM 2, CACM, VOL.3, ISS.2 (1960), C PP.74, C (3) H.C. THACHER, ALGORITHM 15, CACM, VOL.3, ISS.8 (1960), C PP.475, C (4) J.G. HERRIOT, ALGORITHM 26, CACM, VOL.3, ISS.11 (1960), C PP.603. C C .................................................................. C SUBROUTINE DRTWI(X,VAL,FCT,XST,EPS,IEND,IER) C C DOUBLE PRECISION X,VAL,FCT,XST,A,B,D,TOL C C PREPARE ITERATION IER=0 TOL=XST X=FCT(TOL) A=X-XST B=-A TOL=X VAL=X-FCT(TOL) C C C START ITERATION LOOP DO 6 I=1,IEND IF(VAL)1,7,1 C C EQUATION IS NOT SATISFIED BY X 1 B=B/VAL-1.D0 IF(B)2,8,2 C C ITERATION IS POSSIBLE 2 A=A/B X=X+A B=VAL TOL=X VAL=X-FCT(TOL) C C TEST ON SATISFACTORY ACCURACY TOL=EPS D=DABS(X) IF(D-1.D0)4,4,3 3 TOL=TOL*D 4 IF(DABS(A)-TOL)5,5,6 5 IF(DABS(VAL)-1.D1*TOL)7,7,6 6 CONTINUE C END OF ITERATION LOOP C C C NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN. IER=1 7 RETURN C C ERROR RETURN IN CASE OF ZERO DIVISOR 8 IER=2 RETURN END C C .................................................................. C C SUBROUTINE DSE13 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A C VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO C EQUIDISTANTLY SPACED ARGUMENT VALUES. C C USAGE C CALL DSE13(Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED C FUNCTION VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y C IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED C VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST- C SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE C POINTS (X(I+K),Y(I+K)) K = -1,0,1. (SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 295-302.) C C .................................................................. C SUBROUTINE DSE13(Y,Z,NDIM,IER) C DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C C C TEST OF DIMENSION IF(NDIM-3)3,1,1 C C PREPARE LOOP 1 B=.16666666666666667D0*(5.D0*Y(1)+Y(2)+Y(2)-Y(3)) C=.16666666666666667*(5.D0*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2)) C C START LOOP DO 2 I=3,NDIM A=B B=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-2)=A C END OF LOOP C C UPDATE LAST TWO COMPONENTS Z(NDIM-1)=B Z(NDIM)=C IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 3 3 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DSE15 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A C VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO C EQUIDISTANTLY SPACED ARGUMENT VALUES. C C USAGE C CALL DSE15(Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED C FUNCTION VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH C SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE C LEAST-SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 5 C SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE C HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS, C MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.) C C .................................................................. C SUBROUTINE DSE15(Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C C C TEST OF DIMENSION IF(NDIM-5)3,1,1 C C PREPARE LOOP 1 A=Y(1)+Y(1) C=Y(2)+Y(2) B=.2D0*(A+Y(1)+C+Y(3)-Y(5)) C=.1D0*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4)) C C START LOOP DO 2 I=5,NDIM A=B B=C C=.2D0*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-4)=A C END OF LOOP C C UPDATE LAST FOUR COMPONENTS A=Y(NDIM)+Y(NDIM) A=.1D0*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2) 1 +Y(NDIM-3)) Z(NDIM-3)=B Z(NDIM-2)=C Z(NDIM-1)=A Z(NDIM)=A+A-C IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 3 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DSE35 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A C VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO C EQUIDISTANTLY SPACED ARGUMENT VALUES. C C USAGE C CALL DSE35(Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED C FUNCTION VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH C SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE C LEAST-SQUARES POLYNOMIAL OF DEGREE 3 RELEVANT TO THE 5 C SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE C HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS, C MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.) C C .................................................................. C SUBROUTINE DSE35(Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C,D C C TEST OF DIMENSION IF(NDIM-5)4,1,1 C C PREPARE LOOP 1 B=Y(1) C=Y(2) C C START LOOP DO 3 I=5,NDIM A=B B=C C=Y(I-2) C C GENERATE FOURTH CENTRAL DIFFERENCE D=C-B-Y(I-1) D=D+D+C D=D+D+A+Y(I) C C CHECK FIRST TWO COMPONENTS IF(I-5)2,2,3 2 Z(1)=A-.014285714285714286D0*D Z(2)=B+.057142857142857143D0*D 3 Z(I-2)=C-.08571428571428571D0*D C END OF LOOP C C UPDATE LAST TWO COMPONENTS Z(NDIM-1)=Y(NDIM-1)+.057142857142857143D0*D Z(NDIM)=Y(NDIM)-.014285714285714286D0*D IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 4 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DSG13 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN C VECTORS OF ARGUMENT VALUES AND CORRESPONDING FUNCTION C VALUES. C C USAGE C CALL DSG13(X,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C X - GIVEN VECTOR OF DOUBLE PRECISION ARGUMENT VALUES C (DIMENSION NDIM) C Y - GIVEN VECTOR OF DOUBLE PRECISION FUNCTION VALUES C CORRESPONDING TO X (DIMENSION NDIM) C Z - RESULTING VECTOR OF DOUBLE PRECISION SMOOTHED C FUNCTION VALUES (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS X,Y,AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y. IF C X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED C VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST- C SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE C POINTS (X(I+K),Y(I+K)) K = -1,0,1.(SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP.258-311.) C C .................................................................. C SUBROUTINE DSG13(X,Y,Z,NDIM,IER) C C DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,XM,YM,T1,T2,T3,H C C TEST OF DIMENSION IF(NDIM-3)7,1,1 C C START LOOP 1 DO 6 I=3,NDIM XM=.33333333333333333D0*(X(I-2)+X(I-1)+X(I)) YM=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I)) T1=X(I-2)-XM T2=X(I-1)-XM T3=X(I)-XM XM=T1*T1+T2*T2+T3*T3 IF(XM)3,3,2 2 XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM C C CHECK FIRST POINT 3 IF(I-3)4,4,5 4 H=XM*T1+YM 5 Z(I-2)=H 6 H=XM*T2+YM C END OF LOOP C C UPDATE LAST TWO COMPONENTS Z(NDIM-1)=H Z(NDIM)=XM*T3+YM IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 3 7 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE DSINV C C PURPOSE C INVERT A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX C C USAGE C CALL DSINV(A,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C A - DOUBLE PRECISION UPPER TRIANGULAR PART OF GIVEN C SYMMETRIC POSITIVE DEFINITE N BY N COEFFICIENT C MATRIX. C ON RETURN A CONTAINS THE RESULTANT UPPER C TRIANGULAR MATRIX IN DOUBLE PRECISION. C N - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX. C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED C AS RELATIVE TOLERANCE FOR TEST ON LOSS OF C SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TER N OR BECAUSE SOME RADICAND IS NON- C POSITIVE (MATRIX A IS NOT POSITIVE C DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI- C FICANCE) C IER=K - WARNING WHICH INDICATES LOSS OF SIGNIFI- C CANCE. THE RADICAND FORMED AT FACTORIZA- C TION STEP K+1 WAS STILL POSITIVE BUT NO C LONGER GREATER THAN ABS(EPS*A(K+1,K+1)). C C REMARKS C THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE C STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS. C IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU- C LAR MATRIX IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL C CALCULATED RADICANDS ARE POSITIVE. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DMFSD C C METHOD C SOLUTION IS DONE USING FACTORIZATION BY SUBROUTINE DMFSD. C C .................................................................. C SUBROUTINE DSINV(A,N,EPS,IER) C C DIMENSION A(1) DOUBLE PRECISION A,DIN,WORK C C FACTORIZE GIVEN MATRIX BY MEANS OF SUBROUTINE DMFSD C A = TRANSPOSE(T) * T CALL DMFSD(A,N,EPS,IER) IF(IER) 9,1,1 C C INVERT UPPER TRIANGULAR MATRIX T C PREPARE INVERSION-LOOP 1 IPIV=N*(N+1)/2 IND=IPIV C C INITIALIZE INVERSION-LOOP DO 6 I=1,N DIN=1.D0/A(IPIV) A(IPIV)=DIN MIN=N KEND=I-1 LANF=N-KEND IF(KEND) 5,5,2 2 J=IND C C INITIALIZE ROW-LOOP DO 4 K=1,KEND WORK=0.D0 MIN=MIN-1 LHOR=IPIV LVER=J C C START INNER LOOP DO 3 L=LANF,MIN LVER=LVER+1 LHOR=LHOR+L 3 WORK=WORK+A(LVER)*A(LHOR) C END OF INNER LOOP C A(J)=-WORK*DIN 4 J=J-MIN C END OF ROW-LOOP C 5 IPIV=IPIV-MIN 6 IND=IND-1 C END OF INVERSION-LOOP C C CALCULATE INVERSE(A) BY MEANS OF INVERSE(T) C INVERSE(A) = INVERSE(T) * TRANSPOSE(INVERSE(T)) C INITIALIZE MULTIPLICATION-LOOP DO 8 I=1,N IPIV=IPIV+I J=IPIV C C INITIALIZE ROW-LOOP DO 8 K=I,N WORK=0.D0 LHOR=J C C START INNER LOOP DO 7 L=K,N LVER=LHOR+K-I WORK=WORK+A(LHOR)*A(LVER) 7 LHOR=LHOR+L C END OF INNER LOOP C A(J)=WORK 8 J=J+K C END OF ROW- AND MULTIPLICATION-LOOP C 9 RETURN END C C .................................................................. C C SUBROUTINE DTCNP C C PURPOSE C A SERIES EXPANSION IN CHEBYSHEV POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B. C C USAGE C CALL DTCNP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C DOUBLE PRECISION VECTOR C WORK - WORKING STORAGE OF DIMENSION 2*N C DOUBLE PRECISION ARRAY C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-(1+B)/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR CHEBYSHEV POLYNOMIALS T(N,X) C T(N+1,X)=2*X*T(N,X)-T(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE T(0,X)=1, T(1,X)=X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X = A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE DTCNP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0 C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+C(2)*B POL(2)=C(2)*A IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1.D0 WORK(2)=B WORK(3)=0.D0 WORK(4)=A XD=A+A X0=B+B C C CALCULATE COEFFICIENT VECTOR OF NEXT CHEBYSHEV POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0.D0 C DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0.D0 WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END C C .................................................................. C C SUBROUTINE DTCSP C C PURPOSE C A SERIES EXPANSION IN SHIFTED CHEBYSHEV POLYNOMIALS WITH C INDEPENDENT VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH C INDEPENDENT VARIABLE Z, WHERE X=A*Z+B. C C USAGE C CALL DTCSP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C POL AND C MAY BE IDENTICALLY LOCATED C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C WORK - WORKING STORAGE OF DIMENSION 2*N C DOUBLE PRECISION ARRAY C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (0,1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-B/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=1/(ZR-ZL) AND B=-ZL/(ZR-ZL). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION FOR C SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X) C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE DTCSP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0 C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 XD=A+A X0=B+B-1.D0 POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1.D0 WORK(2)=X0 WORK(3)=0.D0 WORK(4)=XD XD=XD+XD X0=X0+X0 C C CALCULATE COEFFICIENT VECTOR OF NEXT SHIFTED CHEBYSHEV C POLYNOMIAL AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0.D0 C DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0.D0 WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END C C .................................................................. C C SUBROUTINE DTEAS C C PURPOSE C CALCULATE THE LIMIT OF A GIVEN SEQUENCE BY MEANS OF THE C EPSILON-ALGORITHM. C C USAGE C CALL DTEAS(X,N,FIN,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - DOUBLE PRECISION VECTOR WHOSE COMPONENTS ARE TERMS C OF THE GIVEN SEQUENCE. ON RETURN THE COMPONENTS OF C VECTOR X ARE DESTROYED. C N - DIMENSION OF INPUT VECTOR X. C FIN - RESULTANT SCALAR IN DOUBLE PRECISION CONTAINING ON C RETURN THE LIMIT OF THE GIVEN SEQUENCE. C EPS - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE C UPPER BOUND OF THE RELATIVE (ABSOLUTE) ERROR IF THE C COMPONENTS OF X ARE ABSOLUTELY GREATER (LESS) THAN C ONE. C CALCULATION IS TERMINATED AS SOON AS THREE TIMES IN C SUCCESSION THE RELATIVE (ABSOLUTE) DIFFERENCE C BETWEEN NEIGHBOURING TERMS IS NOT GREATER THAN EPS. C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - REQUIRED ACCURACY NOT REACHED WITH C MAXIMAL NUMBER OF ITERATIONS C IER=-1 - INTEGER N IS LESS THAN TEN. C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE N LESS THAN TEN. C THE CHARACTER OF THE GIVEN INFINITE SEQUENCE MUST BE C RECOGNIZABLE BY THOSE N COMPONENTS OF THE INPUT VECTOR X. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE CONVERGENCE OF THE GIVEN SEQUENCE IS ACCELERATED BY C MEANS OF THE E(2)-TRANSFORMATION, USED IN AN ITERATIVE WAY. C FOR REFERENCE, SEE C ALGORITHM 215,SHANKS, CACM 1963, NO. 11, PP. 662. AND C P. WYNN, SINGULAR RULES FOR CERTAIN NON-LINEAR ALGORITHMS C BIT VOL. 3, 1963, PP. 175-195. C C .................................................................. C SUBROUTINE DTEAS(X,N,FIN,EPS,IER) C DIMENSION X(1) DOUBLE PRECISION X,FIN,W1,W2,W3,W4,W5,W6,W7,T C C TEST ON WRONG INPUT PARAMETER N C NEW=N IF(NEW-10)1,2,2 1 IER=-1 RETURN C C CALCULATE INITIAL VALUES FOR THE EPSILON ARRAY C 2 ISW1=0 ISW2=0 W1=1.D38 W7=X(4)-X(3) IF(W7)3,4,3 3 W1=1.D0/W7 C 4 W5=1.D38 W7=X(2)-X(1) IF(W7)5,6,5 5 W5=1.D0/W7 C 6 W4=X(3)-X(2) IF(W4)9,7,9 7 W4=1.D38 T=X(2) W2=X(3) 8 W3=1.D38 GO TO 17 C 9 W4=1.D0/W4 C T=1.D38 W7=W4-W5 IF(W7)10,11,10 10 T=X(2)+1.D0/W7 C 11 W2=W1-W4 IF(W2)15,12,15 12 W2=1.D38 IF(T-1.D38)13,14,14 13 ISW2=1 14 W3=W4 GO TO 17 C 15 W2=X(3)+1.D0/W2 W7=W2-T IF(W7)16,8,16 16 W3=W4+1.D0/W7 C 17 ISW1=ISW2 ISW2=0 IMIN=4 C C CALCULATE DIAGONALS OF THE EPSILON ARRAY IN A DO-LOOP C DO 40 I=5,NEW IAUS=I-IMIN W4=1.D38 W5=X(I-1) W7=X(I)-X(I-1) IF(W7)18,24,18 18 W4=1.D0/W7 C IF(W1-1.D38)19,25,25 19 W6=W4-W1 C C TEST FOR NECESSITY OF A SINGULAR RULE C IF(DABS(W6)-DABS(W4)*1.D-12)20,20,22 20 ISW2=1 IF(W6)22,21,22 21 W5=1.D38 W6=W1 IF(W2-1.D38)28,26,26 22 W5=X(I-1)+1.D0/W6 C C FIRST TEST FOR LOSS OF SIGNIFICANCE C IF(DABS(W5)-DABS(X(I-1))*1.D-10)23,24,24 23 IF(W5)36,24,36 C 24 W7=W5-W2 IF(W7)27,25,27 25 W6=1.D38 26 ISW2=0 X(IAUS)=W2 GO TO 37 27 W6=W1+1.D0/W7 28 IF(ISW1-1)33,29,29 C C CALCULATE X(IAUS) WITH HELP OF SINGULAR RULE C 29 IF(W2-1.D38)30,32,32 30 W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2) IF(1.D0+W7)31,38,31 31 X(IAUS)=W7*W2/(1.D0+W7) GO TO 39 C 32 X(IAUS)=W5+T-X(I-2) GO TO 39 C 33 W7=W6-W3 IF(W7)34,38,34 34 X(IAUS)=W2+1.D0/W7 C C SECOND TEST FOR LOSS OF SIGNIFICANCE C IF(DABS(X(IAUS))-DABS(W2)*1.D-10)35,37,37 35 IF(X(IAUS))36,37,36 C 36 NEW=IAUS-1 ISW2=0 GO TO 41 C 37 IF(W2-1.D38)39,38,38 38 X(IAUS)=1.D38 IMIN=I C 39 W1=W4 T=W2 W2=W5 W3=W6 ISW1=ISW2 40 ISW2=0 C NEW=NEW-IMIN C C TEST FOR ACCURACY C 41 IEND=NEW-1 DO 47 I=1,IEND HE1=DABS(X(I)-X(I+1)) HE2=DABS(X(I+1)) IF(HE1-EPS)44,44,42 42 IF(HE2-1.)46,46,43 43 IF(HE1-EPS*HE2)44,44,46 44 ISW2=ISW2+1 IF(3-ISW2)45,45,47 45 FIN=X(I) IER=0 RETURN C 46 ISW2=0 47 CONTINUE C IF(NEW-6)48,2,2 48 FIN=X(NEW) IER=1 RETURN END C C .................................................................. C C SUBROUTINE DTEUL C C PURPOSE C COMPUTE THE SUM OF FCT(K) FOR K FROM ONE UP TO INFINITY. C C USAGE C CALL DTEUL(FCT,SUM,MAX,EPS,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C FCT - NAME OF AN EXTERNAL DOUBLE PRECISION FUNCTION C SUBPROGRAM USED. IT COMPUTES THE K-TH TERM OF THE C SERIES TO ANY GIVEN INDEX K. C SUM - RESULTANT VALUE IN DOUBLE PRECISION CONTAINING ON C RETURN THE SUM OF THE GIVEN SERIES. C MAX - INPUT VALUE, WHICH SPECIFIES THE MAXIMAL NUMBER C OF TERMS OF THE SERIES THAT ARE RESPECTED. C EPS - SINGLE PRECISION INPUT VALUE, WHICH SPECIFIES THE C UPPER BOUND OF THE RELATIVE ERROR. C SUMMATION IS STOPPED AS SOON AS FIVE TIMES IN C SUCCESSION THE ABSOLUTE VALUE OF THE TERMS OF THE C TRANSFORMED SERIES ARE FOUND TO BE LESS THAN C EPS*(ABSOLUTE VALUE OF CURRENT SUM). C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - REQUIRED ACCURACY NOT REACHED WITH C MAXIMAL NUMBER OF TERMS C IER=-1 - THE INTEGER MAX IS LESS THAN ONE. C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE MAX LESS THAN ONE. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(K) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF A SUITABLY REFINED EULER C TRANSFORMATION. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW/HILL, NEW YORK/TORONTO/LONDON, 1956, PP.155-160, AND C P. NAUR, REPORT ON THE ALGORITHMIC LANGUAGE ALGOL 60, C CACM, VOL.3, ISS.5 (1960), PP.311. C C .................................................................. C SUBROUTINE DTEUL (FCT,SUM,MAX,EPS,IER) C DIMENSION Y(15) DOUBLE PRECISION FCT,SUM,Y,AMN,AMP C C TEST ON WRONG INPUT PARAMETER MAX C IF(MAX)1,1,2 1 IER=-1 GOTO 12 C C INITIALIZE EULER TRANSFORMATION C 2 IER=1 I=1 M=1 N=1 Y(1)=FCT(N) SUM=Y(1)*.5D0 C C START EULER-LOOP C 3 J=0 4 I=I+1 IF(I-MAX)5,5,12 5 N=I AMN=FCT(N) DO 6 K=1,M AMP=(AMN+Y(K))*.5D0 Y(K)=AMN 6 AMN=AMP C C CHECK EULER TRANSFORMATION C IF(DABS(AMN)-DABS(Y(M)))7,9,9 7 IF(M-15)8,9,9 8 M=M+1 Y(M)=AMN AMN=.5D0*AMN C C UPDATE SUM C 9 SUM=SUM+AMN IF(ABS(SNGL(AMN))-EPS*ABS(SNGL(SUM)))10,10,3 C C TEST END OF PROCEDURE C 10 J=J+1 IF(J-5)4,11,11 11 IER=0 12 RETURN END C C .................................................................. C C SUBROUTINE DTHEP C C PURPOSE C A SERIES EXPANSION IN HERMITE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL DTHEP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTOR POL AND C C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C DOUBLE PRECISION VECTOR C WORK - WORKING STORAGE OF DIMENSION 2*N C DOUBLE PRECISION ARRAY C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-C,C) IN X TO THE RANGE (ZL,ZR) IN Z WHERE C ZL=-(C+B)/A AND ZR=(C-B)/A. C FOR GIVEN ZL, ZR AND C WE HAVE A=2C/(ZR-ZL) AND C B=-C(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR HERMITE POLYNOMIALS H(N,X) C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE H(0,X)=1,H(1,X)=2*X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE DTHEP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,FI,XD,X0 C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 XD=A+A X0=B+B POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1.D0 WORK(2)=X0 WORK(3)=0.D0 WORK(4)=XD FI=2.D0 C C CALCULATE COEFFICIENT VECTOR OF NEXT HERMITE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0.D0 C DO 5 K=2,J H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=P*XD FI=FI+2.D0 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE DTLAP C C PURPOSE C A SERIES EXPANSION IN LAGUERRE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL DTLAP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C DOUBLE PRECISION VECTOR C WORK - WORKING STORAGE OF DIMENSION 2*N C DOUBLE PRECISION ARRAY C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (0,C) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-B/A AND ZR=(C-B)/A. C FOR GIVEN ZL, ZR AND C WE HAVE A=C/(ZR-ZL) AND C B=-C*ZL/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR LAGUERRE POLYNOMIALS L(N,X) C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE L(0,X)=1, L(1,X)=1-X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE DTLAP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,Q2,FI C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+C(2)-B*C(2) POL(2)=-C(2)*A IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1.D0 WORK(2)=1.D0-B WORK(3)=0.D0 WORK(4)=-A FI=1.D0 C C CALCULATE COEFFICIENT VECTOR OF NEXT LAGUERRE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N FI=FI+1.D0 Q=1.D0/FI Q1=Q-1.D0 Q2=1.D0-Q1-B*Q Q=Q*A P=0.D0 C DO 5 K=2,J H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1 P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=-Q*P 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE DTLEP C C PURPOSE C A SERIES EXPANSION IN LEGENDRE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL DTLEP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C DOUBLE PRECISION VARIABLE C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C DOUBLE PRECISION VECTOR C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C DOUBLE PRECISION VECTOR C WORK - WORKING STORAGE OF DIMENSION 2*N C DOUBLE PRECISION ARRAY C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-(1+B)/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR LEGENDRE POLYNOMIALS P(N,X) C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE P(0,X)=1, P(1,X)=X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE DTLEP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,FI C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+B*C(2) POL(2)=A*C(2) IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1.D0 WORK(2)=B WORK(3)=0.D0 WORK(4)=A FI=1.D0 C C CALCULATE COEFFICIENT VECTOR OF NEXT LEGENDRE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N FI=FI+1.D0 Q=1.D0/FI-1.D0 Q1=1.D0-Q P=0.D0 C DO 5 K=2,J H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=A*P*Q1 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE EIGEN C C PURPOSE C COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC C MATRIX C C USAGE C CALL EIGEN(A,R,N,MV) C C DESCRIPTION OF PARAMETERS C A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION. C RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF C MATRIX A IN DESCENDING ORDER. C R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE, C IN SAME SEQUENCE AS EIGENVALUES) C N - ORDER OF MATRICES A AND R C MV- INPUT CODE C 0 COMPUTE EIGENVALUES AND EIGENVECTORS C 1 COMPUTE EIGENVALUES ONLY (R NEED NOT BE C DIMENSIONED BUT MUST STILL APPEAR IN CALLING C SEQUENCE) C C REMARKS C ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1) C MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED C BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN 'MATHEMATICAL C METHODS FOR DIGITAL COMPUTERS', EDITED BY A. RALSTON AND C H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7 C C .................................................................. C SUBROUTINE EIGEN(A,R,N,MV) DIMENSION A(1),R(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX, C 1 COSX2,SINCS,RANGE C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS C 40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT. ABS IN STATEMENT C 62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD C BE CHANGED TO 1.0D-12. C C ............................................................... C C GENERATE IDENTITY MATRIX C 5 RANGE=1.0E-6 IF(MV-1) 10,25,10 10 IQ=-N DO 20 J=1,N IQ=IQ+N DO 20 I=1,N IJ=IQ+I R(IJ)=0.0 IF(I-J) 20,15,20 15 R(IJ)=1.0 20 CONTINUE C C COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX) C 25 ANORM=0.0 DO 35 I=1,N DO 35 J=I,N IF(I-J) 30,35,30 30 IA=I+(J*J-J)/2 ANORM=ANORM+A(IA)*A(IA) 35 CONTINUE IF(ANORM) 165,165,40 40 ANORM=1.414*SQRT(ANORM) ANRMX=ANORM*RANGE/FLOAT(N) C C INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR C IND=0 THR=ANORM 45 THR=THR/FLOAT(N) 50 L=1 55 M=L+1 C C COMPUTE SIN AND COS C 60 MQ=(M*M-M)/2 LQ=(L*L-L)/2 LM=L+MQ 62 IF( ABS(A(LM))-THR) 130,65,65 65 IND=1 LL=L+LQ MM=M+MQ X=0.5*(A(LL)-A(MM)) 68 Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X) IF(X) 70,75,75 70 Y=-Y 75 SINX=Y/ SQRT(2.0*(1.0+( SQRT(1.0-Y*Y)))) SINX2=SINX*SINX 78 COSX= SQRT(1.0-SINX2) COSX2=COSX*COSX SINCS =SINX*COSX C C ROTATE L AND M COLUMNS C ILQ=N*(L-1) IMQ=N*(M-1) DO 125 I=1,N IQ=(I*I-I)/2 IF(I-L) 80,115,80 80 IF(I-M) 85,115,90 85 IM=I+MQ GO TO 95 90 IM=M+IQ 95 IF(I-L) 100,105,105 100 IL=I+LQ GO TO 110 105 IL=L+IQ 110 X=A(IL)*COSX-A(IM)*SINX A(IM)=A(IL)*SINX+A(IM)*COSX A(IL)=X 115 IF(MV-1) 120,125,120 120 ILR=ILQ+I IMR=IMQ+I X=R(ILR)*COSX-R(IMR)*SINX R(IMR)=R(ILR)*SINX+R(IMR)*COSX R(ILR)=X 125 CONTINUE X=2.0*A(LM)*SINCS Y=A(LL)*COSX2+A(MM)*SINX2-X X=A(LL)*SINX2+A(MM)*COSX2+X A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2) A(LL)=Y A(MM)=X C C TESTS FOR COMPLETION C C TEST FOR M = LAST COLUMN C 130 IF(M-N) 135,140,135 135 M=M+1 GO TO 60 C C TEST FOR L = SECOND FROM LAST COLUMN C 140 IF(L-(N-1)) 145,150,145 145 L=L+1 GO TO 55 150 IF(IND-1) 160,155,160 155 IND=0 GO TO 50 C C COMPARE THRESHOLD WITH FINAL NORM C 160 IF(THR-ANRMX) 165,165,45 C C SORT EIGENVALUES AND EIGENVECTORS C 165 IQ=-N DO 185 I=1,N IQ=IQ+N LL=I+(I*I-I)/2 JQ=N*(I-2) DO 185 J=I,N JQ=JQ+N MM=J+(J*J-J)/2 IF(A(LL)-A(MM)) 170,185,185 170 X=A(LL) A(LL)=A(MM) A(MM)=X IF(MV-1) 175,185,175 175 DO 180 K=1,N ILR=IQ+K IMR=JQ+K X=R(ILR) R(ILR)=R(IMR) 180 R(IMR)=X 185 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE ELI1 C C PURPOSE C COMPUTES THE ELLIPTIC INTEGRAL OF FIRST KIND C C USAGE C CALL ELI1(RES,X,CK) C C DESCRIPTION OF PARAMETERS C RES - RESULT VALUE C X - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC C INTEGRAL OF FIRST KIND) C CK - COMPLEMENTARY MODULUS C C REMARKS C MODULUS K = SQRT(1.-CK*CK). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C RES=INTEGRAL(1/SQRT((1+T*T)*(1+(CK*T)**2)), SUMMED C OVER T FROM 0 TO X). C EQUIVALENT ARE THE DEFINITIONS C RES=INTEGRAL(1/(COS(T)*SQRT(1+(CK*TAN(T))**2)), SUMMED C OVER T FROM 0 TO ATAN(X)), C RES=INTEGRAL(1/SQRT(1-(K*SIN(T))**2), SUMMED OVER C T FROM 0 TO ATAN(X)). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIONS. C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE ELI1(RES,X,CK) C IF(X)2,1,2 1 RES=0. RETURN 2 IF(CK)4,3,4 3 RES=ALOG(ABS(X)+SQRT(1.+X*X)) GOTO 13 4 ANGLE=ABS(1./X) GEO=ABS(CK) ARI=1. PIM=0. 5 SQGEO=ARI*GEO AARI=ARI ARI=GEO+ARI ANGLE=-SQGEO/ANGLE+ANGLE SQGEO=SQRT(SQGEO) IF(ANGLE)7,6,7 C REPLACE 0 BY SMALL VALUE 6 ANGLE=SQGEO*1.E-8 7 TEST=AARI*1.E-4 IF(ABS(AARI-GEO)-TEST)10,10,8 8 GEO=SQGEO+SQGEO PIM=PIM+PIM IF(ANGLE)9,5,5 9 PIM=PIM+3.1415927 GOTO 5 10 IF(ANGLE)11,12,12 11 PIM=PIM+3.1415927 12 RES=(ATAN(ARI/ANGLE)+PIM)/ARI 13 IF(X)14,15,15 14 RES=-RES 15 RETURN END C C .................................................................. C C SUBROUTINE ELI2 C C PURPOSE C COMPUTES THE GENERALIZED ELLIPTIC INTEGRAL OF SECOND KIND C C USAGE C CALL ELI2(R,X,CK,A,B) C C DESCRIPTION OF PARAMETERS C R - RESULT VALUE C X - UPPER INTEGRATION BOUND (ARGUMENT OF ELLIPTIC C INTEGRAL OF SECOND KIND) C CK - COMPLEMENTARY MODULUS C A - CONSTANT TERM IN NUMERATOR C B - QUADRATIC TERM IN NUMERATOR C C REMARKS C MODULUS K = SQRT(1.-CK*CK). C SPECIAL CASES OF THE GENERALIZED ELLIPTIC INTEGRAL OF C SECOND KIND ARE C F(ATAN(X),K) OBTAINED WITH A=1., B=1. C E(ATAN(X),K) OBTAINED WITH A=1., B=CK*CK. C B(ATAN(X),K) OBTAINED WITH A=1., B=0. C D(ATAN(X),K) OBTAINED WITH A=0., B=1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C R=INTEGRAL((A+B*T*T)/(SQRT((1+T*T)*(1+(CK*T)**2))*(1+T*T)), C SUMMED OVER T FROM 0 TO X). C EQUIVALENT IS THE DEFINITION C R=INTEGRAL((A+(B-A)*(SIN(T))**2)/SQRT(1-(K*SIN(T))**2), C SUMMED OVER T FROM 0 TO ATAN(X)). C EVALUATION C LANDENS TRANSFORMATION IS USED FOR CALCULATION. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIONS C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE ELI2(R,X,CK,A,B) C TEST ARGUMENT IF(X)2,1,2 1 R=0. RETURN C TEST MODULUS 2 C=0. D=0.5 IF(CK)7,3,7 3 R=SQRT(1.+X*X) R=(A-B)*ABS(X)/R+B*ALOG(ABS(X)+R) C TEST SIGN OF ARGUMENT 4 R=R+C*(A-B) IF(X)5,6,6 5 R=-R 6 RETURN C INITIALIZATION 7 AN=(B+A)*0.5 AA=A R=B ANG=ABS(1./X) PIM=0. ISI=0 ARI=1. GEO=ABS(CK) C LANDEN TRANSFORMATION 8 R=AA*GEO+R SGEO=ARI*GEO AA=AN AARI=ARI C ARITHMETIC MEAN ARI=GEO+ARI C SUM OF SINE VALUES AN=(R/ARI+AA)*0.5 AANG=ABS(ANG) ANG=-SGEO/ANG+ANG PIMA=PIM IF(ANG)10,9,11 9 ANG=-1.E-8*AANG 10 PIM=PIM+3.1415927 ISI=ISI+1 11 AANG=ARI*ARI+ANG*ANG P=D/SQRT(AANG) IF(ISI-4)13,12,12 12 ISI=ISI-4 13 IF(ISI-2)15,14,14 14 P=-P 15 C=C+P D=D*(AARI-GEO)*0.5/ARI IF(ABS(AARI-GEO)-1.E-4*AARI)17,17,16 16 SGEO=SQRT(SGEO) C GEOMETRIC MEAN GEO=SGEO+SGEO PIM=PIM+PIMA ISI=ISI+ISI GOTO 8 C ACCURACY WAS SUFFICIENT 17 R=(ATAN(ARI/ANG)+PIM)*AN/ARI C=C+D*ANG/AANG GOTO 4 END C C .................................................................. C C SUBROUTINE EXPI C C PURPOSE C COMPUTES THE EXPONENTIAL INTEGRAL -EI(-X) C C USAGE C CALL EXPI(X,RES) C C DESCRIPTION OF PARAMETERS C X - ARGUMENT OF EXPONENTIAL INTEGRAL C RES - RESULT VALUE C AUX - RESULTANT AUXILIARY VALUE C C REMARKS C X GT 170 (X LT -174) MAY CAUSE UNDERFLOW (OVERFLOW) C WITH THE EXPONENTIAL FUNCTION C FOR X = 0 THE RESULT VALUE IS SET TO -1.7E38 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C RES=INTEGRAL(EXP(-T)/T, SUMMED OVER T FROM X TO INFINITY). C EVALUATION C THREE DIFFERENT RATIONAL APPROXIMATIONS ARE USED IN THE C RANGES 1 LE X, X LE -9 AND -9 LT X LE -3 RESPECTIVELY, C A POLYNOMIAL APPROXIMATION IS USED IN -3 LT X LT 1. C C .................................................................. C SUBROUTINE EXPI(X,RES,AUX) IF(X-1.)2,1,1 1 Y=1./X AUX=1.-Y*(((Y+3.377358E0)*Y+2.052156E0)*Y+2.709479E-1)/((((Y* 11.072553E0+5.716943E0)*Y+6.945239E0)*Y+2.593888E0)*Y+2.709496E-1) RES=AUX*Y*EXP(-X) RETURN 2 IF(X+3.)6,6,3 3 AUX=(((((((7.122452E-7*X-1.766345E-6)*X+2.928433E-5)*X-2.335379E-4 1)*X+1.664156E-3)*X-1.041576E-2)*X+5.555682E-2)*X-2.500001E-1)*X 2+9.999999E-1 RES=-1.7E38 0 IF(X)4,5,4 4 RES=X*AUX-ALOG(ABS(X))-5.772157E-1 5 RETURN 6 IF(X+9.)8,8,7 7 AUX=1.-((((5.176245E-2*X+3.061037E0)*X+3.243665E1)*X+2.244234E2)*X 1+2.486697E2)/((((X+3.995161E0)*X+3.893944E1)*X+2.263818E1)*X 2+1.807837E2) GOTO 9 8 Y=9./X AUX=1.-Y*(((Y+7.659824E-1)*Y-7.271015E-1)*Y-1.080693E0)/((((Y 1*2.518750E0+1.122927E1)*Y+5.921405E0)*Y-8.666702E0)*Y-9.724216E0) 9 RES=AUX*EXP(-X)/X RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR TRIPLE EXPONENTIAL SMOOTHING - EXPON C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD AND A TIME SERIES, C (2) CALL THE SUBROUTINE EXSMO TO SMOOTH THE TIME SERIES, C AND (3) PRINT THE RESULT. C C REMARKS C A SMOOTHING CONSTANT SPECIFIED IN THE PROBLEM PARAMETER C CARD MUST BE GREATER THAN ZERO BUT LESS THAN ONE IN ORDER C TO OBTAIN REASONABLE RESULTS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C EXSMO C C METHOD C REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION C OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963, C PP. 140 TO 144. C C .................................................................. cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC NUMBER OF DATA POINTS IN A GIVEN TIME SERIES.. cC cc DIMENSION X(1000),S(1000) cC cC .................................................................. cC c1 FORMAT(A4,A2,I4,F5.0,3F10.0) c2 FORMAT(12F6.0) c3 FORMAT(34H1TRIPLE EXPONENTIAL SMOOTHING.....,A4,A2//22H NUMBER OF c 1DATA POINTS,I6/19H SMOOTHING CONSTANT,F9.3/) c4 FORMAT(13H0COEFFICIENTS,9X,1HA,14X,1HB,14X,1HC) c5 FORMAT(9H0ORIGINAL,F19.5,2F15.5) c6 FORMAT(8H0UPDATED,F20.5,2F15.5/) c7 FORMAT(1H0,27X,13HSMOOTHED DATA/7X,10HINPUT DATA,12X,10H(FORECAST) c 1) c8 FORMAT(F17.5,8X,F15.5) cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR,PR1,NX,AL,A,B,C c IF (EOF) GOTO 999 cC PR......PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1.....PROBLEM NUMBER (CONTINUED) cC NX......NUMBER OF DATA POINTS IN TIME SERIES cC AL......SMOOTHING CONSTANT cC A,B,C...COEFFICIENTS OF THE PREDICTION EQUATION cC c WRITE (6,3) PR,PR1,NX,AL cC cC PRINT ORIGINAL COEFFICIENTS cC c WRITE (6,4) c WRITE (6,5) A,B,C cC cC READ TIME SERIES DATA cC c READ (5,2) (X(I),I=1,NX) cC c CALL EXSMO (X,NX,AL,A,B,C,S) cC cC PRINT UPDATED COEFFICIENTS cC c WRITE (6,6) A,B,C cC cC PRINT INPUT AND SMOOTHED DATA cC c WRITE (6,7) c DO 200 I=1,NX c200 WRITE (6,8) X(I),S(I) c GO TO 100 c999 STOP c END cC C .................................................................. C C SUBROUTINE EXSMO C C PURPOSE C TO FIND THE TRIPLE EXPONENTIAL SMOOTHED SERIES S OF THE C GIVEN SERIES X. C C USAGE C CALL EXSMO (X,NX,AL,A,B,C,S) C C DESCRIPTION OF PARAMETERS C X - INPUT VECTOR OF LENGTH NX CONTAINING TIME SERIES C DATA WHICH IS TO BE EXPONENTIALLY SMOOTHED. C NX - THE NUMBER OF ELEMENTS IN X. C AL - SMOOTHING CONSTANT, ALPHA. AL MUST BE GREATER THAN C ZERO AND LESS THAN ONE. C A,B,C - COEFFICIENTS OF THE PREDICTION EQUATION WHERE S IS C PREDICTED T PERIODS HENCE BY C A + B*T + C*T*T/2. C AS INPUT-- IF A=B=C=0, PROGRAM WILL PROVIDE INITIAL C VALUES. IF AT LEAST ONE OF A,B,C IS NOT ZERO, C PROGRAM WILL TAKE GIVEN VALUES AS INITIAL VALUES. C AS OUTPUT-- A,B,C CONTAIN LATEST, UPDATED COEFFI- C CIENTS OF PREDICTION. C S - OUTPUT VECTOR OF LENGTH NX CONTAINING TRIPLE C EXPONENTIALLY SMOOTHED TIME SERIES. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO R. G. BROWN, 'SMOOTHING, FORECASTING AND PREDICTION C OF DISCRETE TIME SERIES', PRENTICE-HALL, N.J., 1963, C PP. 140 TO 144. C C .................................................................. C SUBROUTINE EXSMO (X,NX,AL,A,B,C,S) DIMENSION X(1),S(1) C C IF A=B=C=0.0, GENERATE INITIAL VALUES OF A, B, AND C C IF(A) 140, 110, 140 110 IF(B) 140, 120, 140 120 IF(C) 140, 130, 140 130 C=X(1)-2.0*X(2)+X(3) B=X(2)-X(1)-1.5*C A=X(1)-B-0.5*C C 140 BE=1.0-AL BECUB=BE*BE*BE ALCUB=AL*AL*AL C C DO THE FOLLOWING FOR I=1 TO NX C DO 150 I=1,NX C C FIND S(I) FOR ONE PERIOD AHEAD C S(I)=A+B+0.5*C C C UPDATE COEFFICIENTS A, B, AND C C DIF=S(I)-X(I) A=X(I)+BECUB*DIF B=B+C-1.5*AL*AL*(2.0-AL)*DIF 150 C=C-ALCUB*DIF RETURN END C C ................................................................. C C SAMPLE MAIN PROGRAM FOR FACTOR ANALYSIS - FACTO C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD, (2) CALL FIVE SUBROU- C TINES TO PERFORM A PRINCIPAL COMPONENT SOLUTION AND THE C VARIMAX ROTATION OF A FACTOR MATRIX, AND (3) PRINT THE C RESULTS. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C CORRE (WHICH, IN TURN, CALLS THE SUBROUTINE NAMED DATA.) C EIGEN C TRACE C LOAD C VARMX C C METHOD C REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J. C DIXON, UCLA, 1964. C C .................................................................. C C THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE C NUMBER OF VARIABLES, M.. cC c DIMENSION B(35),D(35),S(35),T(35),XBAR(35) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*M.. cC c DIMENSION V(1225) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO cC (M+1)*M/2.. cC c DIMENSION R(630) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 51.. cC c DIMENSION TV(51) cC cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION XBAR,S,V,R,D,B,T,TV cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC ............................................................... cC c1 FORMAT(21H1FACTOR ANALYSIS.....A4,A2//3X,12HNO. OF CASES,4X,I6/3X, c 116HNO. OF VARIABLES,I6/) c2 FORMAT(6H0MEANS/(8F15.5)) c3 FORMAT(20H0STANDARD DEVIATIONS/(8F15.5)) c4 FORMAT(25H0CORRELATION COEFFICIENTS) c5 FORMAT(4H0ROWI3/(10F12.5)) c6 FORMAT(1H0/12H EIGENVALUES/(10F12.5)) c7 FORMAT(37H0CUMULATIVE PERCENTAGE OF EIGENVALUES/(10F12.5)) c8 FORMAT(1H0/13H EIGENVECTORS) c9 FORMAT(7H0VECTORI3/(10F12.5)) c10 FORMAT(1H0/16H FACTOR MATRIX (,I3,9H FACTORS)) c11 FORMAT(9H0VARIABLEI3/(10F12.5)) c12 FORMAT(1H0/10H ITERATION,7X,9HVARIANCES/8H CYCLE) c13 FORMAT(I6,F20.6) c14 FORMAT(1H0/24H ROTATED FACTOR MATRIX (I3,9H FACTORS)) c15 FORMAT(9H0VARIABLEI3/(10F12.5)) c16 FORMAT(1H0/23H CHECK ON COMMUNALITIES//9H VARIABLE,7X,8HORIGINAL, c 112X,5HFINAL,10X,10HDIFFERENCE) c17 FORMAT(I6,3F18.5) c18 FORMAT(A4,A2,I5,I2,F6.0) c19 FORMAT(5H0ONLY,I2,30H FACTOR RETAINED. NO ROTATION) cC DOUBLE PRECISION TMPFIL,FILE cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC FILE = TMPFIL('SSP') cC OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT', cC 1 DISPOSE='DELETE') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,18) PR,PR1,N,M,CON c IF (EOF) GOTO 999 cC PR.........PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1........PROBLEM NUMBER (CONTINUED) cC N..........NUMBER OF CASES cC M..........NUMBER OF VARIABLES cC CON........CONSTANT USED TO DECIDE HOW MANY EIGENVALUES cC TO RETAIN cC c WRITE (6,1) PR,PR1,N,M cC c IO=0 c X=0.0 cC c CALL CORRE (N,M,IO,X,XBAR,S,V,R,D,B,T) cC cC PRINT MEANS cC c WRITE (6,2) (XBAR(J),J=1,M) cC cC PRINT STANDARD DEVIATIONS cC c WRITE (6,3) (S(J),J=1,M) cC cC PRINT CORRELATION COEFFICIENTS cC c WRITE (6,4) c DO 120 I=1,M c DO 110 J=1,M c IF(I-J) 102, 104, 104 c102 L=I+(J*J-J)/2 c GO TO 110 c104 L=J+(I*I-I)/2 c110 D(J)=R(L) c120 WRITE (6,5) I,(D(J),J=1,M) cC c MV=0 c CALL EIGEN (R,V,M,MV) cC c CALL TRACE (M,R,CON,K,D) cC cC PRINT EIGENVALUES cC c DO 130 I=1,K c L=I+(I*I-I)/2 c130 S(I)=R(L) c WRITE (6,6) (S(J),J=1,K) cC cC PRINT CUMULATIVE PERCENTAGE OF EIGENVALUES cC c WRITE (6,7) (D(J),J=1,K) cC cC PRINT EIGENVECTORS cC c WRITE (6,8) c L=0 c DO 150 J=1,K c DO 140 I=1,M c L=L+1 c140 D(I)=V(L) c150 WRITE (6,9) J,(D(I),I=1,M) cC c CALL LOAD (M,K,R,V) cC cC PRINT FACTOR MATRIX cC c WRITE (6,10) K c DO 180 I=1,M c DO 170 J=1,K c L=M*(J-1)+I c170 D(J)=V(L) c180 WRITE (6,11) I,(D(J),J=1,K) cC c IF(K-1) 185, 185, 188 c185 WRITE (6,19) K c GO TO 100 cC c188 CALL VARMX (M,K,V,NC,TV,B,T,D,IER) c IF (IER .EQ. 1) WRITE (6,998) c998 FORMAT(/' **** WARNING ****'/ c 1 ' CONVERGENCE NOT REACHED AFTER 50 ITERATIONS'/) cC cC PRINT VARIANCES cC c NV=NC+1 c WRITE (6,12) c DO 190 I=1,NV c NC=I-1 c190 WRITE (6,13) NC,TV(I) cC cC PRINT ROTATED FACTOR MATRIX cC c WRITE (6,14) K c DO 220 I=1,M c DO 210 J=1,K c L=M*(J-1)+I c210 S(J)=V(L) c220 WRITE (6,15) I,(S(J),J=1,K) cC cC PRINT COMMUNALITIES cC c WRITE (6,16) c DO 230 I=1,M c230 WRITE (6,17) I,B(I),T(I),D(I) c GO TO 100 c999 STOP c END C C .................................................................. C C SUBROUTINE FACTR C C PURPOSE C FACTORIZATION OF THE MATRIX A INTO A PRODUCT OF A LOWER C TRIANGULAR MATRIX L AND AN UPPER TRIANGULAR MATRIX U. L HAS C UNIT DIAGONAL WHICH IS NOT STORED. C C USAGE C CALL FACTR(A,PER,N,IA,IER) C C DESCRIPTION OF PARAMETERS C A MATRIX A C PER ONE DIMENSIONAL ARRAY WHERE PERMUTATIONS OF ROWS OF C THE MATRIX ARE STORED C DIMENSION OF PER MUST BE GREATER THAN OR EQUAL TO N C N ORDER OF THE MATRIX A C IA SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY A C IN THE CALLING PROGRAM WHEN THE MATRIX IS IN DOUBLE C SUBSCRIPTED DATA STORAGE MODE. IA=N WHEN THE MATRIX C IS IN SSP VECTOR STORAGE MODE. C IER ERROR INDICATOR WHICH IS ZERO IF THERE IS NO ERROR, C AND IS THREE IF THE PROCEDURE FAILS. C C REMARKS C THE ORIGINAL MATRIX, A,IS REPLACED BY THE TRIANGULAR FACTORS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SUCCESSIVE COMPUTATION OF THE COLUMNS OF L AND THE C CORRESPONDING ROWS OF U. C C REFERENCES C J. H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM - C CLARENDON PRESS, OXFORD, 1965. H. J. BOWDLER, R. S. MARTIN, C G. PETERS, AND J. H. WILKINSON - 'SOLUTION OF REAL AND C COMPLEX SYSTEMS OF LINEAR EQUATIONS', NUMERISCHE MATHEMATIK, C VOL. 8, NO. 3, 1966, P. 217-234. C C .................................................................. C SUBROUTINE FACTR(A,PER,N,IA,IER) DIMENSION A(1),PER(1) DOUBLE PRECISION DP C C COMPUTATION OF WEIGHTS FOR EQUILIBRATION C DO 20 I=1,N X=0. IJ=I DO 10 J=1,N IF (ABS(A(IJ))-X)10,10,5 5 X=ABS(A(IJ)) 10 IJ=IJ+IA IF (X) 110,110,20 20 PER(I)=1./X I0=0 DO 100 I=1,N IM1=I-1 IP1=I+1 IPIVOT=I X=0. C C COMPUTATION OF THE ITH COLUMN OF L C DO 50 K=I,N KI=I0+K DP=A(KI) IF (I-1) 110,40,25 25 KJ=K DO 30 J=1,IM1 IJ=I0+J DP=DP-1.D0*A(KJ)*A(IJ) 30 KJ=KJ+IA A(KI)=DP C C SEARCH FOR EQUILIBRATED PIVOT C 40 IF (X-DABS(DP)*PER(K))45,50,50 45 IPIVOT=K X=DABS(DP)*PER(K) 50 CONTINUE IF (X)110,110,55 C C PERMUTATION OF ROWS IF REQUIRED C 55 IF (IPIVOT-I) 110,70,57 57 KI=IPIVOT IJ=I DO 60 J=1,N X=A(IJ) A(IJ)=A(KI) A(KI)=X KI=KI+IA 60 IJ=IJ+IA PER(IPIVOT)=PER(I) 70 PER(I)=IPIVOT IF (I-N) 72,100,100 72 IJ=I0+I X=A(IJ) C C COMPUTATION OF THE ITH ROW OF U C K0=I0+IA DO 90 K=IP1,N KI=I0+K A(KI)=A(KI)/X IF (I-1)110,90,75 75 IJ=I KI=K0+I DP=A(KI) DO 80 J=1,IM1 KJ=K0+J DP=DP-1.D0*A(IJ)*A(KJ) 80 IJ=IJ+IA A(KI)=DP 90 K0=K0+IA 100 I0=I0+IA IER=0 RETURN 110 IER=3 RETURN END C FUNCTION FCDF C GIVES PROBABILITIES FOR OBSERVED STATISTICS C C T P=P^2 C N = DF C M = INFINITY C C Z P=P^2 C N = INFINITY CF M = 1 C C CHI2 P=P/M C N = INFINITY C M = DF C C F P=P C M = DF1 C N = DF2 FUNCTION FCDF(FR,M,N) C FROM DECUSSCOPE C 13:2 PAGE 7 C MODIFIED 10/8/84 LP ADDED DOUBLE IMPLICIT DOUBLE PRECISION (A-J,P-Z) REAL FR KONSTANT PI=3.1415926535 FCDF=0 CON=1 FM=M FN=N IF((M-M/2*2).EQ.0)GOTO 80 IF((N-N/2*2).EQ.0)GOTO 60 IF(N.NE.1)GOTO 5 THETA=ATAN(SQRT(FN/(FM*FR))) J=M/2 GOTO 7 5 THETA=ATAN(SQRT(FM*FR/FN)) J=N/2 7 SINE=SIN(THETA) SINSQ=SINE*SINE COSQ=1.0-SINSQ COSN=SQRT(COSQ) IF((M.EQ.1).AND.(N.EQ.1))GOTO 50 DO 10 I=1,J FCDF=FCDF+CON TWI=2*I 10 CON=CON*TWI*COSQ/(TWI+1.0) 50 FCDF=1.0-2.0*(FCDF*SINE*COSN+THETA)/PI IF (N.EQ.1)RETURN FCDF=1.0-FCDF IF(M.EQ.1)RETURN FCTR=CON CON=1.0 PEP=0.0 FNM1=N-1 J=M/2 DO 20 I=1,J PEP=PEP+CON TWI=2*I 20 CON=CON*(FNM1+TWI)*SINSQ/(TWI+1.0) FCDF=FCDF-2.*FN*FCTR*SINE*COSN*PEP/PI RETURN 60 X=FN/(FN+FM*FR) J=N/2 FMS2=M-2 GOTO 85 80 X=FM*FR/(FN+FM*FR) J=M/2 FMS2=N-2 85 OWX=1.0-X DO 90 I=1,J FCDF=FCDF+CON TWI=2*I CON=CON*(FMS2+TWI)*X/TWI IF(CON.LT.1E-6)GOTO 91 90 CONTINUE 91 IF((M-M/2*2).NE.0)GOTO 100 FCDF=1.0-OWX**(FN/2.0)*FCDF RETURN 100 FCDF=OWX**(FM/2.0)*FCDF RETURN END C C .................................................................. C C SUBROUTINE FMCG C C PURPOSE C TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES C BY THE METHOD OF CONJUGATE GRADIENTS C C USAGE C CALL FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DESCRIPTION OF PARAMETERS C FUNCT - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO C BE MINIMIZED. IT MUST BE OF THE FORM C SUBROUTINE FUNCT(N,ARG,VAL,GRAD) C AND MUST SERVE THE FOLLOWING PURPOSE C FOR EACH N-DIMENSIONAL ARGUMENT VECTOR ARG, C FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED C AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY C N - NUMBER OF VARIABLES C X - VECTOR OF DIMENSION N CONTAINING THE INITIAL C ARGUMENT WHERE THE ITERATION STARTS. ON RETURN, C X HOLDS THE ARGUMENT CORRESPONDING TO THE C COMPUTED MINIMUM FUNCTION VALUE C F - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION C VALUE ON RETURN, I.E. F=F(X). C G - VECTOR OF DIMENSION N CONTAINING THE GRADIENT C VECTOR CORRESPONDING TO THE MINIMUM ON RETURN, C I.E. G=G(X). C EST - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE. C EPS - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR. C A REASONABLE CHOICE IS 10**(-6), I.E. C SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE C NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT C REPRESENTATION. C LIMIT - MAXIMUM NUMBER OF ITERATIONS. C IER - ERROR PARAMETER C IER = 0 MEANS CONVERGENCE WAS OBTAINED C IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS C IER =-1 MEANS ERRORS IN GRADIENT CALCULATION C IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES C IT IS LIKELY THAT THERE EXISTS NO MINIMUM. C H - WORKING STORAGE OF DIMENSION 2*N. C C REMARKS C I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT FUNCT C MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM. C II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED C DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN C A TOLERABLE RANGE OF ARGUMENT. C IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F C INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS C RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE C MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH C TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT C IS FOUND WHERE THE FUNCTION INCREASES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUNCT C C METHOD C THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE C R.FLETCHER AND C.M.REEVES, FUNCTION MINIMIZATION BY C CONJUGATE GRADIENTS, C COMPUTER JOURNAL VOL.7, ISS.2, 1964, PP.149-154. C C .................................................................. C SUBROUTINE FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DIMENSIONED DUMMY VARIABLES DIMENSION X(1),G(1),H(1) C C C COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT CALL FUNCT(N,X,F,G) C C RESET ITERATION COUNTER KOUNT=0 IER=0 N1=N+1 C C START ITERATION CYCLE FOR EVERY N+1 ITERATIONS 1 DO 43 II=1,N1 C C STEP ITERATION COUNTER AND SAVE FUNCTION VALUE KOUNT=KOUNT+1 OLDF=F C C COMPUTE SQUARE OF GRADIENT AND TERMINATE IF ZERO GNRM=0. DO 2 J=1,N 2 GNRM=GNRM+G(J)*G(J) IF(GNRM)46,46,3 C C EACH TIME THE ITERATION LOOP IS EXECUTED , THE FIRST STEP WILL C BE IN DIRECTION OF STEEPEST DESCENT 3 IF(II-1)4,4,6 4 DO 5 J=1,N 5 H(J)=-G(J) GO TO 8 C C FURTHER DIRECTION VECTORS H WILL BE CHOOSEN CORRESPONDING C TO THE CONJUGATE GRADIENT METHOD 6 AMBDA=GNRM/OLDG DO 7 J=1,N 7 H(J)=AMBDA*H(J)-G(J) C C COMPUTE TESTVALUE FOR DIRECTIONAL VECTOR AND DIRECTIONAL C DERIVATIVE 8 DY=0. HNRM=0. DO 9 J=1,N K=J+N C C SAVE ARGUMENT VECTOR H(K)=X(J) HNRM=HNRM+ABS(H(J)) 9 DY=DY+H(J)*G(J) C C CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H AND C SKIP LINEAR SEARCH ROUTINE IF NOT IF(DY)10,42,42 C C COMPUTE SCALE FACTOR USED IN LINEAR SEARCH SUBROUTINE 10 SNRM=1./HNRM C C SEARCH MINIMUM ALONG DIRECTION H C C SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE FY=F ALFA=2.*(EST-F)/DY AMBDA=SNRM C C USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN C SNRM. OTHERWISE TAKE SNRM AS STEPSIZE. IF(ALFA)13,13,11 11 IF(ALFA-AMBDA)12,13,13 12 AMBDA=ALFA 13 ALFA=0. C C SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT 14 FX=FY DX=DY C C STEP ARGUMENT ALONG H DO 15 I=1,N 15 X(I)=X(I)+AMBDA*H(I) C C COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT CALL FUNCT(N,X,F,G) FY=F C C COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT. TERMINATE C SEARCH, IF DY POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND DY=0. DO 16 I=1,N 16 DY=DY+G(I)*H(I) IF(DY)17,38,20 C C TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT C A MINIMUM HAS BEEN PASSED 17 IF(FY-FX)18,20,20 C C REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES 18 AMBDA=AMBDA+ALFA ALFA=AMBDA C C TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE IF(HNRM*AMBDA-1.E10)14,14,19 C C LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS 19 IER=2 C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS F=OLDF DO 100 J=1,N G(J)=H(J) K=N+J 100 X(J)=H(K) RETURN C END OF SEARCH LOOP C C INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH C ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION C POLYNOMIAL IS MINIMIZED C 20 T=0. 21 IF(AMBDA)22,38,22 22 Z=3.*(FX-FY)/AMBDA+DX+DY ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)23,27,27 C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS 23 DO 24 J=1,N K=N+J 24 X(J)=H(K) CALL FUNCT(N,X,F,G) C C TEST FOR REPEATED FAILURE OF ITERATION 25 IF(IER)47,26,47 26 IER=-1 GOTO 1 27 W=ALFA*SQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA)270,271,270 270 ALFA=(DY-Z+W)/ALFA GO TO 272 271 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 272 ALFA=ALFA*AMBDA DO 28 I=1,N 28 X(I)=X(I)+(T-ALFA)*H(I) C C TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS C THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE C THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT C THE INTERPOLATION. WHICH END-POINT IS CHOOSEN DEPENDS ON THE C VALUE OF THE FUNCTION AND ITS GRADIENT AT X C CALL FUNCT(N,X,F,G) IF(F-FX)29,29,30 29 IF(F-FY)38,38,30 C C COMPUTE DIRECTIONAL DERIVATIVE 30 DALFA=0. DO 31 I=1,N 31 DALFA=DALFA+G(I)*H(I) IF(DALFA)32,35,35 32 IF(F-FX)34,33,35 33 IF(DX-DALFA)34,38,34 34 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 21 35 IF(FY-F)37,36,37 36 IF(DY-DALFA)37,38,37 37 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 20 C C TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION C OTHERWISE SAVE GRADIENT NORM 38 IF(OLDF-F+EPS)19,25,39 39 OLDG=GNRM C C COMPUTE DIFFERENCE OF NEW AND OLD ARGUMENT VECTOR T=0. DO 40 J=1,N K=J+N H(K)=X(J)-H(K) 40 T=T+ABS(H(K)) C C TEST LENGTH OF DIFFERENCE VECTOR IF AT LEAST N+1 ITERATIONS C HAVE BEEN EXECUTED. TERMINATE, IF LENGTH IS LESS THAN EPS IF(KOUNT-N1)42,41,41 41 IF(T-EPS)45,45,42 C C TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED LIMIT 42 IF(KOUNT-LIMIT)43,44,44 43 IER=0 C END OF ITERATION CYCLE C C START NEXT ITERATION CYCLE GO TO 1 C C NO CONVERGENCE AFTER LIMIT ITERATIONS 44 IER=1 IF(GNRM-EPS)46,46,47 C C TEST FOR SUFFICIENTLY SMALL GRADIENT 45 IF(GNRM-EPS)46,46,25 46 IER=0 47 RETURN END C C .................................................................. C C SUBROUTINE FMFP C C PURPOSE C TO FIND A LOCAL MINIMUM OF A FUNCTION OF SEVERAL VARIABLES C BY THE METHOD OF FLETCHER AND POWELL C C USAGE C CALL FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DESCRIPTION OF PARAMETERS C FUNCT - USER-WRITTEN SUBROUTINE CONCERNING THE FUNCTION TO C BE MINIMIZED. IT MUST BE OF THE FORM C SUBROUTINE FUNCT(N,ARG,VAL,GRAD) C AND MUST SERVE THE FOLLOWING PURPOSE C FOR EACH N-DIMENSIONAL ARGUMENT VECTOR ARG, C FUNCTION VALUE AND GRADIENT VECTOR MUST BE COMPUTED C AND, ON RETURN, STORED IN VAL AND GRAD RESPECTIVELY C N - NUMBER OF VARIABLES C X - VECTOR OF DIMENSION N CONTAINING THE INITIAL C ARGUMENT WHERE THE ITERATION STARTS. ON RETURN, C X HOLDS THE ARGUMENT CORRESPONDING TO THE C COMPUTED MINIMUM FUNCTION VALUE C F - SINGLE VARIABLE CONTAINING THE MINIMUM FUNCTION C VALUE ON RETURN, I.E. F=F(X). C G - VECTOR OF DIMENSION N CONTAINING THE GRADIENT C VECTOR CORRESPONDING TO THE MINIMUM ON RETURN, C I.E. G=G(X). C EST - IS AN ESTIMATE OF THE MINIMUM FUNCTION VALUE. C EPS - TESTVALUE REPRESENTING THE EXPECTED ABSOLUTE ERROR. C A REASONABLE CHOICE IS 10**(-6), I.E. C SOMEWHAT GREATER THAN 10**(-D), WHERE D IS THE C NUMBER OF SIGNIFICANT DIGITS IN FLOATING POINT C REPRESENTATION. C LIMIT - MAXIMUM NUMBER OF ITERATIONS. C IER - ERROR PARAMETER C IER = 0 MEANS CONVERGENCE WAS OBTAINED C IER = 1 MEANS NO CONVERGENCE IN LIMIT ITERATIONS C IER =-1 MEANS ERRORS IN GRADIENT CALCULATION C IER = 2 MEANS LINEAR SEARCH TECHNIQUE INDICATES C IT IS LIKELY THAT THERE EXISTS NO MINIMUM. C H - WORKING STORAGE OF DIMENSION N*(N+7)/2. C C REMARKS C I) THE SUBROUTINE NAME REPLACING THE DUMMY ARGUMENT FUNCT C MUST BE DECLARED AS EXTERNAL IN THE CALLING PROGRAM. C II) IER IS SET TO 2 IF , STEPPING IN ONE OF THE COMPUTED C DIRECTIONS, THE FUNCTION WILL NEVER INCREASE WITHIN C A TOLERABLE RANGE OF ARGUMENT. C IER = 2 MAY OCCUR ALSO IF THE INTERVAL WHERE F C INCREASES IS SMALL AND THE INITIAL ARGUMENT WAS C RELATIVELY FAR AWAY FROM THE MINIMUM SUCH THAT THE C MINIMUM WAS OVERLEAPED. THIS IS DUE TO THE SEARCH C TECHNIQUE WHICH DOUBLES THE STEPSIZE UNTIL A POINT C IS FOUND WHERE THE FUNCTION INCREASES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUNCT C C METHOD C THE METHOD IS DESCRIBED IN THE FOLLOWING ARTICLE C R. FLETCHER AND M.J.D. POWELL, A RAPID DESCENT METHOD FOR C MINIMIZATION, C COMPUTER JOURNAL VOL.6, ISS. 2, 1963, PP.163-168. C C .................................................................. C SUBROUTINE FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) C C DIMENSIONED DUMMY VARIABLES DIMENSION H(1),X(1),G(1) C C COMPUTE FUNCTION VALUE AND GRADIENT VECTOR FOR INITIAL ARGUMENT CALL FUNCT(N,X,F,G) C C RESET ITERATION COUNTER AND GENERATE IDENTITY MATRIX IER=0 KOUNT=0 N2=N+N N3=N2+N N31=N3+1 1 K=N31 DO 4 J=1,N H(K)=1. NJ=N-J IF(NJ)5,5,2 2 DO 3 L=1,NJ KL=K+L 3 H(KL)=0. 4 K=KL+1 C C START ITERATION LOOP 5 KOUNT=KOUNT +1 C C SAVE FUNCTION VALUE, ARGUMENT VECTOR AND GRADIENT VECTOR OLDF=F DO 9 J=1,N K=N+J H(K)=G(J) K=K+N H(K)=X(J) C C DETERMINE DIRECTION VECTOR H K=J+N3 T=0. DO 8 L=1,N T=T-G(L)*H(K) IF(L-J)6,7,7 6 K=K+N-L GO TO 8 7 K=K+1 8 CONTINUE 9 H(J)=T C C CHECK WHETHER FUNCTION WILL DECREASE STEPPING ALONG H. DY=0. HNRM=0. GNRM=0. C C CALCULATE DIRECTIONAL DERIVATIVE AND TESTVALUES FOR DIRECTION C VECTOR H AND GRADIENT VECTOR G. DO 10 J=1,N HNRM=HNRM+ABS(H(J)) GNRM=GNRM+ABS(G(J)) 10 DY=DY+H(J)*G(J) C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTIONAL C DERIVATIVE APPEARS TO BE POSITIVE OR ZERO. IF(DY)11,51,51 C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DIRECTION C VECTOR H IS SMALL COMPARED TO GRADIENT VECTOR G. 11 IF(HNRM/GNRM-EPS)51,51,12 C C SEARCH MINIMUM ALONG DIRECTION H C C SEARCH ALONG H FOR POSITIVE DIRECTIONAL DERIVATIVE 12 FY=F ALFA=2.*(EST-F)/DY AMBDA=1. C C USE ESTIMATE FOR STEPSIZE ONLY IF IT IS POSITIVE AND LESS THAN C 1. OTHERWISE TAKE 1. AS STEPSIZE IF(ALFA)15,15,13 13 IF(ALFA-AMBDA)14,15,15 14 AMBDA=ALFA 15 ALFA=0. C C SAVE FUNCTION AND DERIVATIVE VALUES FOR OLD ARGUMENT 16 FX=FY DX=DY C C STEP ARGUMENT ALONG H DO 17 I=1,N 17 X(I)=X(I)+AMBDA*H(I) C C COMPUTE FUNCTION VALUE AND GRADIENT FOR NEW ARGUMENT CALL FUNCT(N,X,F,G) FY=F C C COMPUTE DIRECTIONAL DERIVATIVE DY FOR NEW ARGUMENT. TERMINATE C SEARCH, IF DY IS POSITIVE. IF DY IS ZERO THE MINIMUM IS FOUND DY=0. DO 18 I=1,N 18 DY=DY+G(I)*H(I) IF(DY)19,36,22 C C TERMINATE SEARCH ALSO IF THE FUNCTION VALUE INDICATES THAT C A MINIMUM HAS BEEN PASSED 19 IF(FY-FX)20,22,22 C C REPEAT SEARCH AND DOUBLE STEPSIZE FOR FURTHER SEARCHES 20 AMBDA=AMBDA+ALFA ALFA=AMBDA C END OF SEARCH LOOP C C TERMINATE IF THE CHANGE IN ARGUMENT GETS VERY LARGE IF(HNRM*AMBDA-1.E10)16,16,21 C C LINEAR SEARCH TECHNIQUE INDICATES THAT NO MINIMUM EXISTS 21 IER=2 RETURN C C INTERPOLATE CUBICALLY IN THE INTERVAL DEFINED BY THE SEARCH C ABOVE AND COMPUTE THE ARGUMENT X FOR WHICH THE INTERPOLATION C POLYNOMIAL IS MINIMIZED 22 T=0. 23 IF(AMBDA)24,36,24 24 Z=3.*(FX-FY)/AMBDA+DX+DY ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)51,25,25 25 W=ALFA*SQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA) 250,251,250 250 ALFA=(DY-Z+W)/ALFA GO TO 252 251 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 252 ALFA=ALFA*AMBDA DO 26 I=1,N 26 X(I)=X(I)+(T-ALFA)*H(I) C C TERMINATE, IF THE VALUE OF THE ACTUAL FUNCTION AT X IS LESS C THAN THE FUNCTION VALUES AT THE INTERVAL ENDS. OTHERWISE REDUCE C THE INTERVAL BY CHOOSING ONE END-POINT EQUAL TO X AND REPEAT C THE INTERPOLATION. WHICH END-POINT IS CHOOSEN DEPENDS ON THE C VALUE OF THE FUNCTION AND ITS GRADIENT AT X C CALL FUNCT(N,X,F,G) IF(F-FX)27,27,28 27 IF(F-FY)36,36,28 28 DALFA=0. DO 29 I=1,N 29 DALFA=DALFA+G(I)*H(I) IF(DALFA)30,33,33 30 IF(F-FX)32,31,33 31 IF(DX-DALFA)32,36,32 32 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 23 33 IF(FY-F)35,34,35 34 IF(DY-DALFA)35,36,35 35 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 22 C C TERMINATE, IF FUNCTION HAS NOT DECREASED DURING LAST ITERATION 36 IF(OLDF-F+EPS)51,38,38 C C COMPUTE DIFFERENCE VECTORS OF ARGUMENT AND GRADIENT FROM C TWO CONSECUTIVE ITERATIONS 38 DO 37 J=1,N K=N+J H(K)=G(J)-H(K) K=N+K 37 H(K)=X(J)-H(K) C C TEST LENGTH OF ARGUMENT DIFFERENCE VECTOR AND DIRECTION VECTOR C IF AT LEAST N ITERATIONS HAVE BEEN EXECUTED. TERMINATE, IF C BOTH ARE LESS THAN EPS IER=0 IF(KOUNT-N)42,39,39 39 T=0. Z=0. DO 40 J=1,N K=N+J W=H(K) K=K+N T=T+ABS(H(K)) 40 Z=Z+W*H(K) IF(HNRM-EPS)41,41,42 41 IF(T-EPS)56,56,42 C C TERMINATE, IF NUMBER OF ITERATIONS WOULD EXCEED LIMIT 42 IF(KOUNT-LIMIT)43,50,50 C C PREPARE UPDATING OF MATRIX H 43 ALFA=0. DO 47 J=1,N K=J+N3 W=0. DO 46 L=1,N KL=N+L W=W+H(KL)*H(K) IF(L-J)44,45,45 44 K=K+N-L GO TO 46 45 K=K+1 46 CONTINUE K=N+J ALFA=ALFA+W*H(K) 47 H(J)=W C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF RESULTS C ARE NOT SATISFACTORY IF(Z*ALFA)48,1,48 C C UPDATE MATRIX H 48 K=N31 DO 49 L=1,N KL=N2+L DO 49 J=L,N NJ=N2+J H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA 49 K=K+1 GO TO 5 C END OF ITERATION LOOP C C NO CONVERGENCE AFTER LIMIT ITERATIONS 50 IER=1 RETURN C C RESTORE OLD VALUES OF FUNCTION AND ARGUMENTS 51 DO 52 J=1,N K=N2+J 52 X(J)=H(K) CALL FUNCT(N,X,F,G) C C REPEAT SEARCH IN DIRECTION OF STEEPEST DESCENT IF DERIVATIVE C FAILS TO BE SUFFICIENTLY SMALL IF(GNRM-EPS)55,55,53 C C TEST FOR REPEATED FAILURE OF ITERATION 53 IF(IER)56,54,54 54 IER=-1 GOTO 1 55 IER=0 56 RETURN END C C .................................................................. C C SUBROUTINE FORIF C C PURPOSE C FOURIER ANALYSIS OF A GIVEN PERIODIC FUNCTION IN THE C RANGE 0-2PI C COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS C IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX) C WHERE K=1,2,...,M TO APPROXIMATE THE COMPUTED VALUES OF A C GIVEN FUNCTION SUBPROGRAM C C USAGE C CALL FORIF(FUN,N,M,A,B,IER) C C DESCRIPTION OF PARAMETERS C FUN-NAME OF FUNCTION SUBPROGRAM TO BE USED FOR COMPUTING C DATA POINTS C N -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN C OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1 C M -THE MAXIMUM ORDER OF THE HARMONICS TO BE FITTED C A -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF C LENGTH M+1 C A SUB 0, A SUB 1,..., A SUB M C B -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF C LENGTH M+1 C B SUB 0, B SUB 1,..., B SUB M C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 N NOT GREATER OR EQUAL TO M C IER=2 M LESS THAN 0 C C REMARKS C M MUST BE GREATER THAN OR EQUAL TO ZERO C N MUST BE GREATER THAN OR EQUAL TO M C THE FIRST ELEMENT IN VECTOR B IS ZERO IN ALL CASES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUN-NAME OF USER FUNCTION SUBPROGRAM USED FOR COMPUTING C DATA POINTS C CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT C CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO C FORIF C C METHOD C USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF, C 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY C AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF C INDEXING THROUGH THE PROCEDURE HAS BEEN MODIFIED TO C SIMPLIFY THE COMPUTATION. C C .................................................................. C SUBROUTINE FORIF(FUN,N,M,A,B,IER) DIMENSION A(1),B(1) C C CHECK FOR PARAMETER ERRORS C IER=0 20 IF(M) 30,40,40 30 IER=2 RETURN 40 IF(M-N) 60,60,50 50 IER=1 RETURN C C COMPUTE AND PRESET CONSTANTS C 60 AN=N COEF=2.0/(2.0*AN+1.0) CONST=3.141593*COEF S1=SIN(CONST) C1=COS(CONST) C=1.0 S=0.0 J=1 FUNZ=FUN(0.0) 70 U2=0.0 U1=0.0 AI=2*N C C FORM FOURIER COEFFICIENTS RECURSIVELY C 75 X=AI*CONST U0=FUN(X)+2.0*C*U1-U2 U2=U1 U1=U0 AI=AI-1.0 IF(AI) 80,80,75 80 A(J)=COEF*(FUNZ+C*U1-U2) B(J)=COEF*S*U1 IF(J-(M+1)) 90,100,100 90 Q=C1*C-S1*S S=C1*S+S1*C C=Q J=J+1 GO TO 70 100 A(1)=A(1)*0.5 RETURN END C C .................................................................. C C SUBROUTINE FORIT C C PURPOSE C FOURIER ANALYSIS OF A PERIODICALLY TABULATED FUNCTION. C COMPUTES THE COEFFICIENTS OF THE DESIRED NUMBER OF TERMS C IN THE FOURIER SERIES F(X)=A(0)+SUM(A(K)COS KX+B(K)SIN KX) C WHERE K=1,2,...,M TO APPROXIMATE A GIVEN SET OF C PERIODICALLY TABULATED VALUES OF A FUNCTION. C C USAGE C CALL FORIT(FNT,N,M,A,B,IER) C C DESCRIPTION OF PARAMETERS C FNT-VECTOR OF TABULATED FUNCTION VALUES OF LENGTH 2N+1 C N -DEFINES THE INTERVAL SUCH THAT 2N+1 POINTS ARE TAKEN C OVER THE INTERVAL (0,2PI). THE SPACING IS THUS 2PI/2N+1 C M -MAXIMUM ORDER OF HARMONICS TO BE FITTED C A -RESULTANT VECTOR OF FOURIER COSINE COEFFICIENTS OF C LENGTH M+1 C A SUB 0, A SUB 1,..., A SUB M C B -RESULTANT VECTOR OF FOURIER SINE COEFFICIENTS OF C LENGTH M+1 C B SUB 0, B SUB 1,..., B SUB M C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 N NOT GREATER OR EQUAL TO M C IER=2 M LESS THAN 0 C C REMARKS C M MUST BE GREATER THAN OR EQUAL TO ZERO C N MUST BE GREATER THAN OR EQUAL TO M C THE FIRST ELEMENT OF VECTOR B IS ZERO IN ALL CASES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C USES RECURSIVE TECHNIQUE DESCRIBED IN A. RALSTON, H. WILF, C 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', JOHN WILEY C AND SONS, NEW YORK, 1960, CHAPTER 24. THE METHOD OF INDEXING C THROUGH THE PROCEDURE HAS BEEN MODIFIED TO SIMPLIFY THE C COMPUTATION. C C .................................................................. C SUBROUTINE FORIT(FNT,N,M,A,B,IER) DIMENSION A(1),B(1),FNT(1) C C CHECK FOR PARAMETER ERRORS C IER=0 20 IF(M) 30,40,40 30 IER=2 RETURN 40 IF(M-N) 60,60,50 50 IER=1 RETURN C C COMPUTE AND PRESET CONSTANTS C 60 AN=N COEF=2.0/(2.0*AN+1.0) CONST=3.141593*COEF S1=SIN(CONST) C1=COS(CONST) C=1.0 S=0.0 J=1 FNTZ=FNT(1) 70 U2=0.0 U1=0.0 I=2*N+1 C C FORM FOURIER COEFFICIENTS RECURSIVELY C 75 U0=FNT(I)+2.0*C*U1-U2 U2=U1 U1=U0 I=I-1 IF(I-1) 80,80,75 80 A(J)=COEF*(FNTZ+C*U1-U2) B(J)=COEF*S*U1 IF(J-(M+1)) 90,100,100 90 Q=C1*C-S1*S S=C1*S+S1*C C=Q J=J+1 GO TO 70 100 A(1)=A(1)*0.5 RETURN END C C .................................................................. C C SUBROUTINE FRAT C C PURPOSE C FRAT IS USED FOR HANDLING OF DATA AND FUNDAMENTAL FUNCTIONS C WITH RATIONAL APPROXIMATION. IT IS A SUBSTANTIAL PART OF C RATIONAL APPROXIMATION AND HAS NO MEANING INDEPENDENTLY C C USAGE C CALL FRAT(I,N,M,P,DATI,WGT,IER) C C DESCRIPTION OF PARAMETERS C I - SUBSCRIPT OF CURRENT DATA POINT C N - NUMBER OF ALL DATA POINTS C M - NUMBER OF FUNDAMENTAL FUNCTIONS USED C P - ARRAY OF DIMENSION M+1 AT LEAST, WHICH CONTAINS C ON RETURN THE VALUES OF THE M FUNDAMENTAL C FUNCTIONS, FOLLOWED BY CURRENT FUNCTION VALUE C DATI - ARRAY CONTAINING GIVEN N ARGUMENTS, FOLLOWED C BY N FUNCTION VALUES AND FINALLY BY 1 RESPECTIVELY C N WEIGHT VALUES C WGT - RESULTANT WEIGHT FACTOR USED FOR I-TH TERM C IER - RESULTANT ERROR PARAMETER, COMBINED WITH INPUT C VALUES FOR CONTROL C IER(2) MEANS DIMENSION OF NUMERATOR C IER(3) MEANS DIMENSION OF DENOMINATOR C IER(1) IS USED AS RESULTANT ERROR PARAMETER, C IER(1) = 0 IN CASE OF NO ERRORS C IER(1) = 1 OTHERWISE (ZERO DENOMINATOR) C C REMARKS C VECTOR IER IS USED FOR COMMUNICATION BETWEEN ARAT AND FRAT C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C CNP C C METHOD C CF. MATHEMATICAL DESCRIPTION OF SUBROUTINE ARAT C C .................................................................. C SUBROUTINE FRAT(I,N,M,P,DATI,WGT,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION P(1),DATI(1),IER(1) C C INITIALIZATION IP=IER(2) IQ=IER(3) IQM1=IQ-1 IPQ=IP+IQ C C LOOK UP ARGUMENT, FUNCTION VALUE AND WEIGHT C LOOK UP NUMERATOR AND DENOMINATOR T=DATI(I) J=I+N F=DATI(J) FNUM=P(J) J=J+N WGT=1. IF(DATI(2*N+1))2,2,1 1 WGT=DATI(J) 2 FDEN=P(J) C C CALCULATE FUNCTION VALUE USED F=F*FDEN-FNUM C C CHECK FOR ZERO DENOMINATOR IF(FDEN)4,3,4 C C ERROR RETURN IN CASE OF ZERO DENOMINATOR 3 IER(1)=1 RETURN C C CALCULATE WEIGHT FACTORS USED 4 WGT=WGT/(FDEN*FDEN) FNUM=-FNUM/FDEN C C CALCULATE FUNDAMENTAL FUNCTIONS J=IQM1 IF(IP-IQ)6,6,5 5 J=IP-1 6 CALL CNP(P(IQ),T,J) C C STORE VALUES OF DENOMINATOR FUNDAMENTAL FUNCTIONS 7 IF(IQM1)10,10,8 8 DO 9 II=1,IQM1 J=II+IQ 9 P(II)=P(J)*FNUM C C STORE FUNCTION VALUE 10 P(IPQ)=F C C NORMAL RETURN IER(1)=0 RETURN END FUNCTION FUN(X,Y) C FUN=1./X RETURN END C C .................................................................. C C SUBROUTINE GAUSS C C PURPOSE C COMPUTES A NORMALLY DISTRIBUTED RANDOM NUMBER WITH A GIVEN C MEAN AND STANDARD DEVIATION C C USAGE C CALL GAUSS(IX,S,AM,V) C C DESCRIPTION OF PARAMETERS C IX -IX MUST CONTAIN AN ODD INTEGER NUMBER WITH NINE OR C LESS DIGITS ON THE FIRST ENTRY TO GAUSS. THEREAFTER C IT WILL CONTAIN A UNIFORMLY DISTRIBUTED INTEGER RANDOM C NUMBER GENERATED BY THE SUBROUTINE FOR USE ON THE NEXT C ENTRY TO THE SUBROUTINE. C S -THE DESIRED STANDARD DEVIATION OF THE NORMAL C DISTRIBUTION. C AM -THE DESIRED MEAN OF THE NORMAL DISTRIBUTION C V -THE VALUE OF THE COMPUTED NORMAL RANDOM VARIABLE C C REMARKS C THIS SUBROUTINE USES RANDU WHICH IS MACHINE SPECIFIC C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANDU C C METHOD C USES 12 UNIFORM RANDOM NUMBERS TO COMPUTE NORMAL RANDOM C NUMBERS BY CENTRAL LIMIT THEOREM. THE RESULT IS THEN C ADJUSTED TO MATCH THE GIVEN MEAN AND STANDARD DEVIATION. C THE UNIFORM RANDOM NUMBERS COMPUTED WITHIN THE SUBROUTINE C ARE FOUND BY THE POWER RESIDUE METHOD. C C .................................................................. C SUBROUTINE GAUSS(IX,S,AM,V) A=0.0 DO 50 I=1,12 CALL RANDU(IX,IY,Y) IX=IY 50 A=A+Y V=(A-6.0)*S+AM RETURN END C C .................................................................. C C SUBROUTINE GDATA C C PURPOSE C GENERATE INDEPENDENT VARIABLES UP TO THE M-TH POWER (THE C HIGHEST DEGREE POLYNOMIAL SPECIFIED) AND COMPUTE MEANS, C STANDARD DEVIATIONS, AND CORRELATION COEFFICIENTS. THIS C SUBROUTINE IS NORMALLY CALLED BEFORE SUBROUTINES ORDER, C MINV AND MULTR IN THE PERFORMANCE OF A POLYNOMIAL C REGRESSION. C C USAGE C CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS. C M - THE HIGHEST DEGREE POLYNOMIAL TO BE FITTED. C X - INPUT MATRIX (N BY M+1) . WHEN THE SUBROUTINE IS C CALLED, DATA FOR THE INDEPENDENT VARIABLE ARE C STORED IN THE FIRST COLUMN OF MATRIX X, AND DATA FOR C THE DEPENDENT VARIABLE ARE STORED IN THE LAST C COLUMN OF THE MATRIX. UPON RETURNING TO THE C CALLING ROUTINE, GENERATED POWERS OF THE INDEPENDENT C VARIABLE ARE STORED IN COLUMNS 2 THROUGH M. C XBAR - OUTPUT VECTOR OF LENGTH M+1 CONTAINING MEANS OF C INDEPENDENT AND DEPENDENT VARIABLES. C STD - OUTPUT VECTOR OF LENGTH M+1 CONTAINING STANDARD C DEVIATIONS OF INDEPENDENT AND DEPENDENT VARIABLES. C D - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE C SYMMETRIC MATRIX OF M+1 BY M+1) CONTAINING CORRELA- C TION COEFFICIENTS. (STORAGE MODE OF 1) C SUMSQ - OUTPUT VECTOR OF LENGTH M+1 CONTAINING SUMS OF C PRODUCTS OF DEVIATIONS FROM MEANS OF INDEPENDENT C AND DEPENDENT VARIABLES. C C REMARKS C N MUST BE GREATER THAN M+1. C IF M IS EQUAL TO 5 OR GREATER, SINGLE PRECISION MAY NOT BE C SUFFICIENT TO GIVE SATISFACTORY COMPUTATIONAL RESULTS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO B. OSTLE, 'STATISTICS IN RESEARCH', THE IOWA STATE C COLLEGE PRESS, 1954, CHAPTER 6. C C .................................................................. C SUBROUTINE GDATA (N,M,X,XBAR,STD,D,SUMSQ) DIMENSION X(1),XBAR(1),STD(1),D(1),SUMSQ(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION X,XBAR,STD,D,SUMSQ,T1,T2 C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT AND ABS IN C STATEMENT 180 MUST BE CHANGED TO DSQRT AND DABS. C C ............................................................... C C GENERATE INDEPENDENT VARIABLES C IF(M-1) 105, 105, 90 90 L1=0 DO 100 I=2,M L1=L1+N DO 100 J=1,N L=L1+J K=L-N 100 X(L)=X(K)*X(J) C C CALCULATE MEANS C 105 MM=M+1 DF=N L=0 DO 115 I=1,MM XBAR(I)=0.0 DO 110 J=1,N L=L+1 110 XBAR(I)=XBAR(I)+X(L) 115 XBAR(I)=XBAR(I)/DF C DO 130 I=1,MM 130 STD(I)=0.0 C C CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS C L=((MM+1)*MM)/2 DO 150 I=1,L 150 D(I)=0.0 DO 170 K=1,N L=0 DO 170 J=1,MM L2=N*(J-1)+K T2=X(L2)-XBAR(J) STD(J)=STD(J)+T2 DO 170 I=1,J L1=N*(I-1)+K T1=X(L1)-XBAR(I) L=L+1 170 D(L)=D(L)+T1*T2 L=0 DO 175 J=1,MM DO 175 I=1,J L=L+1 175 D(L)=D(L)-STD(I)*STD(J)/DF L=0 DO 180 I=1,MM L=L+I SUMSQ(I)=D(L) 180 STD(I)= SQRT( ABS(D(L))) C C CALCULATE CORRELATION COEFFICIENTS C L=0 DO 190 J=1,MM DO 190 I=1,J L=L+1 190 D(L)=D(L)/(STD(I)*STD(J)) C C CALCULATE STANDARD DEVIATIONS C DF=SQRT(DF-1.0) DO 200 I=1,MM 200 STD(I)=STD(I)/DF RETURN END C C .................................................................. C C SUBROUTINE GELB C C PURPOSE C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH A C COEFFICIENT MATRIX OF BAND STRUCTURE. C C USAGE C CALL GELB(R,A,M,N,MUD,MLD,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - M BY N RIGHT HAND SIDE MATRIX (DESTROYED). C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. C A - M BY M COEFFICIENT MATRIX WITH BAND STRUCTURE C (DESTROYED). C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C MUD - THE NUMBER OF UPPER CODIAGONALS (THAT MEANS C CODIAGONALS ABOVE MAIN DIAGONAL). C MLD - THE NUMBER OF LOWER CODIAGONALS (THAT MEANS C CODIAGONALS BELOW MAIN DIAGONAL). C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TERS M,MUD,MLD OR BECAUSE OF PIVOT ELEMENT C AT ANY ELIMINATION STEP EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST ELEMENT OF MATRIX A. C C REMARKS C BAND MATRIX A IS ASSUMED TO BE STORED ROWWISE IN THE FIRST C ME SUCCESSIVE STORAGE LOCATIONS OF TOTALLY NEEDED MA C STORAGE LOCATIONS, WHERE C MA=M*MC-ML*(ML+1)/2 AND ME=MA-MU*(MU+1)/2 WITH C MC=MIN(M,1+MUD+MLD), ML=MC-1-MLD, MU=MC-1-MUD. C RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE C IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN SOLUTION C MATRIX R IS STORED COLUMNWISE TOO. C INPUT PARAMETERS M, MUD, MLD SHOULD SATISFY THE FOLLOWING C RESTRICTIONS MUD NOT LESS THAN ZERO C MLD NOT LESS THAN ZERO C MUD+MLD NOT GREATER THAN 2*M-2. C NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE C RESTRICTIONS ARE NOT SATISFIED. C THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT C PARAMETERS ARE SATISFIED AND IF PIVOT ELEMENTS AT ALL C ELIMINATION STEPS ARE DIFFERENT FROM 0. HOWEVER WARNING C IER=K - IF GIVEN - INDICATES POSSIBLE LOSS OF SIGNIFICANCE. C IN CASE OF A WELL SCALED MATRIX A AND APPROPRIATE TOLERANCE C EPS, IER=K MAY BE INTERPRETED THAT MATRIX A HAS THE RANK K. C NO WARNING IS GIVEN IF MATRIX A HAS NO LOWER CODIAGONAL. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS ELIMINATION WITH C COLUMN PIVOTING ONLY, IN ORDER TO PRESERVE BAND STRUCTURE C IN REMAINING COEFFICIENT MATRICES. C C .................................................................. C SUBROUTINE GELB(R,A,M,N,MUD,MLD,EPS,IER) C C DIMENSION R(1),A(1) C C TEST ON WRONG INPUT PARAMETERS IF(MLD)47,1,1 1 IF(MUD)47,2,2 2 MC=1+MLD+MUD IF(MC+1-M-M)3,3,47 C C PREPARE INTEGER PARAMETERS C MC=NUMBER OF COLUMNS IN MATRIX A C MU=NUMBER OF ZEROS TO BE INSERTED IN FIRST ROW OF MATRIX A C ML=NUMBER OF MISSING ELEMENTS IN LAST ROW OF MATRIX A C MR=INDEX OF LAST ROW IN MATRIX A WITH MC ELEMENTS C MZ=TOTAL NUMBER OF ZEROS TO BE INSERTED IN MATRIX A C MA=TOTAL NUMBER OF STORAGE LOCATIONS NECESSARY FOR MATRIX A C NM=NUMBER OF ELEMENTS IN MATRIX R 3 IF(MC-M)5,5,4 4 MC=M 5 MU=MC-MUD-1 ML=MC-MLD-1 MR=M-ML MZ=(MU*(MU+1))/2 MA=M*MC-(ML*(ML+1))/2 NM=N*M C C MOVE ELEMENTS BACKWARD AND SEARCH FOR ABSOLUTELY GREATEST ELEMENT C (NOT NECESSARY IN CASE OF A MATRIX WITHOUT LOWER CODIAGONALS) IER=0 PIV=0. IF(MLD)14,14,6 6 JJ=MA J=MA-MZ KST=J DO 9 K=1,KST TB=A(J) A(JJ)=TB TB=ABS(TB) IF(TB-PIV)8,8,7 7 PIV=TB 8 J=J-1 9 JJ=JJ-1 C C INSERT ZEROS IN FIRST MU ROWS (NOT NECESSARY IN CASE MZ=0) IF(MZ)14,14,10 10 JJ=1 J=1+MZ IC=1+MUD DO 13 I=1,MU DO 12 K=1,MC A(JJ)=0. IF(K-IC)11,11,12 11 A(JJ)=A(J) J=J+1 12 JJ=JJ+1 13 IC=IC+1 C C GENERATE TEST VALUE FOR SINGULARITY 14 TOL=EPS*PIV C C C START DECOMPOSITION LOOP KST=1 IDST=MC IC=MC-1 DO 38 K=1,M IF(K-MR-1)16,16,15 15 IDST=IDST-1 16 ID=IDST ILR=K+MLD IF(ILR-M)18,18,17 17 ILR=M 18 II=KST C C PIVOT SEARCH IN FIRST COLUMN (ROW INDEXES FROM I=K UP TO I=ILR) PIV=0. DO 22 I=K,ILR TB=ABS(A(II)) IF(TB-PIV)20,20,19 19 PIV=TB J=I JJ=II 20 IF(I-MR)22,22,21 21 ID=ID-1 22 II=II+ID C C TEST ON SINGULARITY IF(PIV)47,47,23 23 IF(IER)26,24,26 24 IF(PIV-TOL)25,25,26 25 IER=K-1 26 PIV=1./A(JJ) C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R ID=J-K DO 27 I=K,NM,M II=I+ID TB=PIV*R(II) R(II)=R(I) 27 R(I)=TB C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN COEFFICIENT MATRIX A II=KST J=JJ+IC DO 28 I=JJ,J TB=PIV*A(I) A(I)=A(II) A(II)=TB 28 II=II+1 C C ELEMENT REDUCTION IF(K-ILR)29,34,34 29 ID=KST II=K+1 MU=KST+1 MZ=KST+IC DO 33 I=II,ILR C C IN MATRIX A ID=ID+MC JJ=I-MR-1 IF(JJ)31,31,30 30 ID=ID-JJ 31 PIV=-A(ID) J=ID+1 DO 32 JJ=MU,MZ A(J-1)=A(J)+PIV*A(JJ) 32 J=J+1 A(J-1)=0. C C IN MATRIX R J=K DO 33 JJ=I,NM,M R(JJ)=R(JJ)+PIV*R(J) 33 J=J+M 34 KST=KST+MC IF(ILR-MR)36,35,35 35 IC=IC-1 36 ID=K-MR IF(ID)38,38,37 37 KST=KST-ID 38 CONTINUE C END OF DECOMPOSITION LOOP C C C BACK SUBSTITUTION IF(MC-1)46,46,39 39 IC=2 KST=MA+ML-MC+2 II=M DO 45 I=2,M KST=KST-MC II=II-1 J=II-MR IF(J)41,41,40 40 KST=KST+J 41 DO 43 J=II,NM,M TB=R(J) MZ=KST+IC-2 ID=J DO 42 JJ=KST,MZ ID=ID+1 42 TB=TB-A(JJ)*R(ID) 43 R(J)=TB IF(IC-MC)44,45,45 44 IC=IC+1 45 CONTINUE 46 RETURN C C C ERROR RETURN 47 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE GELG C C PURPOSE C TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS. C C USAGE C CALL GELG(R,A,M,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - THE M BY N MATRIX OF RIGHT HAND SIDES. (DESTROYED) C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. C A - THE M BY M COEFFICIENT MATRIX. (DESTROYED) C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR C PIVOT ELEMENT AT ANY ELIMINATION STEP C EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST ELEMENT OF MATRIX A. C C REMARKS C INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE C IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN C SOLUTION MATRIX R IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS C GIVEN IN CASE M=1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH C COMPLETE PIVOTING. C C .................................................................. C SUBROUTINE GELG(R,A,M,N,EPS,IER) C C DIMENSION A(1),R(1) IF(M)23,23,1 C C SEARCH FOR GREATEST ELEMENT IN MATRIX A 1 IER=0 PIV=0. MM=M*M NM=N*M DO 3 L=1,MM TB=ABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L 3 CONTINUE TOL=EPS*PIV C A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I). C C C START ELIMINATION LOOP LST=1 DO 17 K=1,M C C TEST ON SINGULARITY IF(PIV)23,23,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 PIVI=1./A(I) J=(I-1)/M I=I-J*M-K J=J+1-K C I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R DO 8 L=K,NM,M LL=L+I TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB C C IS ELIMINATION TERMINATED IF(K-M)9,18,18 C C COLUMN INTERCHANGE IN MATRIX A 9 LEND=LST+M-K IF(J)12,12,10 10 II=J*M DO 11 L=LST,LEND TB=A(L) LL=L+II A(L)=A(LL) 11 A(LL)=TB C C ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A 12 DO 13 L=LST,MM,M LL=L+I TB=PIVI*A(LL) A(LL)=A(L) 13 A(L)=TB C C SAVE COLUMN INTERCHANGE INFORMATION A(LST)=J C C ELEMENT REDUCTION AND NEXT PIVOT SEARCH PIV=0. LST=LST+1 J=0 DO 16 II=LST,LEND PIVI=-A(II) IST=II+M J=J+1 DO 15 L=IST,MM,M LL=L-J A(L)=A(L)+PIVI*A(LL) TB=ABS(A(L)) IF(TB-PIV)15,15,14 14 PIV=TB I=L 15 CONTINUE DO 16 L=K,NM,M LL=L+J 16 R(LL)=R(LL)+PIVI*R(L) 17 LST=LST+M C END OF ELIMINATION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE 18 IF(M-1)23,22,19 19 IST=MM+M LST=M+1 DO 21 I=2,M II=LST-I IST=IST-LST L=IST-M L=A(L)+.5 DO 21 J=II,NM,M TB=R(J) LL=J DO 20 K=IST,MM,M LL=LL+1 20 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 21 R(K)=TB 22 RETURN C C C ERROR RETURN 23 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE GELS C C PURPOSE C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH C IS ASSUMED TO BE STORED COLUMNWISE. C C USAGE C CALL GELS(R,A,M,N,EPS,IER,AUX) C C DESCRIPTION OF PARAMETERS C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. C A - UPPER TRIANGULAR PART OF THE SYMMETRIC C M BY M COEFFICIENT MATRIX. (DESTROYED) C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR C PIVOT ELEMENT AT ANY ELIMINATION STEP C EQUAL TO 0, C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT ELIMINATION STEP K+1, C WHERE PIVOT ELEMENT WAS LESS THAN OR C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES C ABSOLUTELY GREATEST MAIN DIAGONAL C ELEMENT OF MATRIX A. C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. C C REMARKS C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE C TOO. C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS C GIVEN IN CASE M=1. C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE C SYMMETRY IN REMAINING COEFFICIENT MATRICES. C C .................................................................. C SUBROUTINE GELS(R,A,M,N,EPS,IER,AUX) C C DIMENSION A(1),R(1),AUX(1) IF(M)24,24,1 C C SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT 1 IER=0 PIV=0. L=0 DO 3 K=1,M L=L+K TB=ABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L J=K 3 CONTINUE TOL=EPS*PIV C MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT. C PIV CONTAINS THE ABSOLUTE VALUE OF A(I). C C C START ELIMINATION LOOP LST=0 NM=N*M LEND=M-1 DO 18 K=1,M C C TEST ON USEFULNESS OF SYMMETRIC ALGORITHM IF(PIV)24,24,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 LT=J-K LST=LST+K C C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R PIVI=1./A(I) DO 8 L=K,NM,M LL=L+LT TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB C C IS ELIMINATION TERMINATED IF(K-M)9,19,19 C C ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A. C ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX. 9 LR=LST+(LT*(K+J-1))/2 LL=LR L=LST DO 14 II=K,LEND L=L+II LL=LL+1 IF(L-LR)12,10,11 10 A(LL)=A(LST) TB=A(L) GO TO 13 11 LL=L+LT 12 TB=A(LL) A(LL)=A(L) 13 AUX(II)=TB 14 A(L)=PIVI*TB C C SAVE COLUMN INTERCHANGE INFORMATION A(LST)=LT C C ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT PIV=0. LLST=LST LT=0 DO 18 II=K,LEND PIVI=-AUX(II) LL=LLST LT=LT+1 DO 15 LLD=II,LEND LL=LL+LLD L=LL+LT 15 A(L)=A(L)+PIVI*A(LL) LLST=LLST+II LR=LLST+LT TB=ABS(A(LR)) IF(TB-PIV)17,17,16 16 PIV=TB I=LR J=II+1 17 DO 18 LR=K,NM,M LL=LR+LT 18 R(LL)=R(LL)+PIVI*R(LR) C END OF ELIMINATION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE 19 IF(LEND)24,23,20 20 II=M DO 22 I=2,M LST=LST-II II=II-1 L=A(LST)+.5 DO 22 J=II,NM,M TB=R(J) LL=J K=LST DO 21 LT=II,LEND LL=LL+1 K=K+LT 21 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 22 R(K)=TB 23 RETURN C C C ERROR RETURN 24 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE GMADD C C PURPOSE C ADD TWO GENERAL MATRICES TO FORM RESULTANT GENERAL MATRIX C C USAGE C CALL GMADD(A,B,R,N,M) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A,B,R C M - NUMBER OF COLUMNS IN A,B,R C C REMARKS C ALL MATRICES MUST BE STORED AS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C ADDITION IS PERFORMED ELEMENT BY ELEMENT C C .................................................................. C SUBROUTINE GMADD(A,B,R,N,M) DIMENSION A(1),B(1),R(1) C C CALCULATE NUMBER OF ELEMENTS C NM=N*M C C ADD MATRICES C DO 10 I=1,NM 10 R(I)=A(I)+B(I) RETURN END C C .................................................................. C C SUBROUTINE GMMMA C C PURPOSE C COMPUTES THE GAMMA FUNCTION FOR A GIVEN ARGUMENT C C USAGE C CALL GMMMA(XX,GX,IER) C C DESCRIPTION OF PARAMETERS C XX -THE ARGUMENT FOR THE GAMMA FUNCTION C GX -THE RESULTANT GAMMA FUNCTION VALUE C IER-RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 XX IS WITHIN .000001 OF BEING A NEGATIVE INTEGER C IER=2 XX GT 57, OVERFLOW, GX SET TO 1.0E75 C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE RECURSION RELATION AND POLYNOMIAL APPROXIMATION C BY C.HASTINGS,JR., 'APPROXIMATIONS FOR DIGITAL COMPUTERS', C PRINCETON UNIVERSITY PRESS, 1955 C C .................................................................. C SUBROUTINE GMMMA(XX,GX,IER) IF(XX-57.)6,6,4 4 IER=2 GX=1.7E38 0 RETURN 6 X=XX ERR=1.0E-6 IER=0 GX=1.0 IF(X-2.0)50,50,15 10 IF(X-2.0)110,110,15 15 X=X-1.0 GX=GX*X GO TO 10 50 IF(X-1.0)60,120,110 C C SEE IF X IS NEAR NEGATIVE INTEGER OR ZERO C 60 IF(X-ERR)62,62,80 62 Y=FLOAT(INT(X))-X IF(ABS(Y)-ERR)130,130,64 64 IF(1.0-Y-ERR)130,130,70 C C X NOT NEAR A NEGATIVE INTEGER OR ZERO C 70 IF(X-1.0)80,80,110 80 GX=GX/X X=X+1.0 GO TO 70 110 Y=X-1.0 GY=1.0+Y*(-0.5771017+Y*(+0.9858540+Y*(-0.8764218+Y*(+0.8328212+ 1Y*(-0.5684729+Y*(+0.2548205+Y*(-0.05149930))))))) GX=GX*GY 120 RETURN 130 IER=1 RETURN END C C .................................................................. C C SUBROUTINE GMPRD C C PURPOSE C MULTIPLY TWO GENERAL MATRICES TO FORM A RESULTANT GENERAL C MATRIX C C USAGE C CALL GMPRD(A,B,R,N,M,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A AND ROWS IN B C L - NUMBER OF COLUMNS IN B C C REMARKS C ALL MATRICES MUST BE STORED AS GENERAL MATRICES C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B C NUMBER OF COLUMNS OF MATRIX A MUST BE EQUAL TO NUMBER OF ROW C OF MATRIX B C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE M BY L MATRIX B IS PREMULTIPLIED BY THE N BY M MATRIX A C AND THE RESULT IS STORED IN THE N BY L MATRIX R. C C .................................................................. C SUBROUTINE GMPRD(A,B,R,N,M,L) DIMENSION A(1),B(1),R(1) C IR=0 IK=-M DO 10 K=1,L IK=IK+M DO 10 J=1,N IR=IR+1 JI=J-N IB=IK R(IR)=0 DO 10 I=1,M JI=JI+N IB=IB+1 10 R(IR)=R(IR)+A(JI)*B(IB) RETURN END C C .................................................................. C C SUBROUTINE GMSUB C C PURPOSE C SUBTRACT ONE GENERAL MATRIX FROM ANOTHER TO FORM RESULTANT C MATRIX C C USAGE C CALL GMSUB(A,B,R,N,M) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A,B,R C M - NUMBER OF COLUMNS IN A,B,R C C REMARKS C ALL MATRICES MUST BE STORED AS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C MATRIX B ELEMENTS ARE SUBTRACTED FROM CORRESPONDING MATRIX A C ELEMENTS C C .................................................................. C SUBROUTINE GMSUB(A,B,R,N,M) DIMENSION A(1),B(1),R(1) C C CALCULATE NUMBER OF ELEMENTS C NM=N*M C C SUBTRACT MATRICES C DO 10 I=1,NM 10 R(I)=A(I)-B(I) RETURN END C C .................................................................. C C SUBROUTINE GMTRA C C PURPOSE C TRANSPOSE A GENERAL MATRIX C C USAGE C CALL GMTRA(A,R,N,M) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX TO BE TRANSPOSED C R - NAME OF RESULTANT MATRIX C N - NUMBER OF ROWS OF A AND COLUMNS OF R C M - NUMBER OF COLUMNS OF A AND ROWS OF R C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRICES A AND R MUST BE STORED AS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C TRANSPOSE N BY M MATRIX A TO FORM M BY N MATRIX R C C .................................................................. C SUBROUTINE GMTRA(A,R,N,M) DIMENSION A(1),R(1) C IR=0 DO 10 I=1,N IJ=I-N DO 10 J=1,M IJ=IJ+N IR=IR+1 10 R(IR)=A(IJ) RETURN END C C .................................................................. C C SUBROUTINE GTPRD C C PURPOSE C PREMULTIPLY A GENERAL MATRIX BY THE TRANSPOSE OF ANOTHER C GENERAL MATRIX C C USAGE C CALL GTPRD(A,B,R,N,M,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A AND B C M - NUMBER OF COLUMNS IN A AND ROWS IN R C L - NUMBER OF COLUMNS IN B AND R C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX B C ALL MATRICES MUST BE STORED AS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C MATRIX TRANSPOSE OF A IS NOT ACTUALLY CALCULATED. INSTEAD, C ELEMENTS OF MATRIX A ARE TAKEN COLUMNWISE RATHER THAN C ROWWISE FOR POSTMULTIPLICATION BY MATRIX B. C C .................................................................. C SUBROUTINE GTPRD(A,B,R,N,M,L) DIMENSION A(1),B(1),R(1) C IR=0 IK=-N DO 10 K=1,L IJ=0 IK=IK+N DO 10 J=1,M IB=IK IR=IR+1 R(IR)=0 DO 10 I=1,N IJ=IJ+1 IB=IB+1 10 R(IR)=R(IR)+A(IJ)*B(IB) RETURN END C C .................................................................. C C SUBROUTINE HARM C C PURPOSE C PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX C THREE DIMENSIONAL ARRAY C C USAGE C CALL HARM (A,M,INV,S,IFSET,IFERR) C C DESCRIPTION OF PARAMETERS C A - AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL C ARRAY TO BE TRANSFORMED. THE REAL PART OF C A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL C WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE C NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC. C THE IMAGINARY PART IS IN THE CELL IMMEDIATELY C FOLLOWING. NOTE THAT THE SUBSCRIPT I1 INCREASES C MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY. C AS OUTPUT, A CONTAINS THE COMPLEX FOURIER C TRANSFORM. THE NUMBER OF CORE LOCATIONS OF C ARRAY A IS 2*(N1*N2*N3) C M - A THREE CELL VECTOR WHICH DETERMINES THE SIZES C OF THE 3 DIMENSIONS OF THE ARRAY A. THE SIZE, C NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3 C INV - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION C OF DIMENSION ONE FOURTH OF THE QUANTITY C MAX(N1,N2,N3) C S - A VECTOR WORK AREA FOR SINE TABLES WITH DIMENSION C THE SAME AS INV C IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS C 0 SET UP SINE AND INV TABLES ONLY C 1 SET UP SINE AND INV TABLES ONLY AND C CALCULATE FOURIER TRANSFORM C -1 SET UP SINE AND INV TABLES ONLY AND C CALCULATE INVERSE FOURIER TRANSFORM (FOR C THE MEANING OF INVERSE SEE THE EQUATIONS C UNDER METHOD BELOW) C 2 CALCULATE FOURIER TRANSFORM ONLY (ASSUME C SINE AND INV TABLES EXIST) C -2 CALCULATE INVERSE FOURIER TRANSFORM ONLY C (ASSUME SINE AND INV TABLES EXIST) C IFERR - ERROR INDICATOR. WHEN IFSET IS 0,+1,-1, C IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN C 20 , I=1,2,3 WHEN IFSET IS 2,-2 , IFERR = 1 C MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE C ENOUGH OR HAVE NOT BEEN COMPUTED . C IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE C CONDITIONS ARE PRESENT C C REMARKS C THIS SUBROUTINE IS TO BE USED FOR COMPLEX, 3-DIMENSIONAL C ARRAYS IN WHICH EACH DIMENSION IS A POWER OF 2. THE C MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN 20, C I = 1,2,3 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C FOR IFSET = +1, OR +2, THE FOURIER TRANSFORM OF COMPLEX C ARRAY A IS OBTAINED. C C N1-1 N2-1 N3-1 L1 L2 L3 C X(J1,J2,J3)=SUM SUM SUM A(K1,K2,K3)*W1 *W2 *W3 C K1=0 K2=0 K3=0 C C WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1, C L2=K2*J2, L3=K3*J3 C C C FOR IFSET = -1, OR -2, THE INVERSE FOURIER TRANSFORM A OF C COMPLEX ARRAY X IS OBTAINED. C C A(K1,K2,K3)= C 1 N1-1 N2-1 N3-1 -L1 -L2 -L3 C -------- *SUM SUM SUM X(J1,J2,J3)*W1 *W2 *W3 C N1*N2*N3 J1=0 J2=0 J3=0 C C C SEE J.W. COOLEY AND J.W. TUKEY, 'AN ALGORITHM FOR THE C MACHINE CALCULATION OF COMPLEX FOURIER SERIES', C MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297. C C .................................................................. C SUBROUTINE HARM(A,M,INV,S,IFSET, IFERR) DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2) EQUIVALENCE (N(1),N1),(N(2),N2),(N(3),N3) 10 IF( IABS(IFSET) - 1) 900,900,12 12 MTT=MAX0(M(1),M(2),M(3)) -2 ROOT2 = SQRT(2.) IF (MTT-MT ) 14,14,13 13 IFERR=1 RETURN 14 IFERR=0 M1=M(1) M2=M(2) M3=M(3) N1=2**M1 N2=2**M2 N3=2**M3 16 IF(IFSET) 18,18,20 18 NX= N1*N2*N3 FN = NX DO 19 I = 1,NX A(2*I-1) = A(2*I-1)/FN 19 A(2*I) = -A(2*I)/FN 20 NP(1)=N1*2 NP(2)= NP(1)*N2 NP(3)=NP(2)*N3 DO 250 ID=1,3 IL = NP(3)-NP(ID) IL1 = IL+1 MI = M(ID) IF (MI)250,250,30 30 IDIF=NP(ID) KBIT=NP(ID) MEV = 2*(MI/2) IF (MI - MEV )60,60,40 C C M IS ODD. DO L=1 CASE 40 KBIT=KBIT/2 KL=KBIT-2 DO 50 I=1,IL1,IDIF KLAST=KL+I DO 50 K=I,KLAST,2 KD=K+KBIT C C DO ONE STEP WITH L=1,J=0 C A(K)=A(K)+A(KD) C A(KD)=A(K)-A(KD) C T=A(KD) A(KD)=A(K)-T A(K)=A(K)+T T=A(KD+1) A(KD+1)=A(K+1)-T 50 A(K+1)=A(K+1)+T IF (MI - 1)250,250,52 52 LFIRST =3 C C DEF - JLAST = 2**(L-2) -1 JLAST=1 GO TO 70 C C M IS EVEN 60 LFIRST = 2 JLAST=0 70 DO 240 L=LFIRST,MI,2 JJDIF=KBIT KBIT=KBIT/4 KL=KBIT-2 C C DO FOR J=0 DO 80 I=1,IL1,IDIF KLAST=I+KL DO 80 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT C C DO TWO STEPS WITH J=0 C A(K)=A(K)+A(K2) C A(K2)=A(K)-A(K2) C A(K1)=A(K1)+A(K3) C A(K3)=A(K1)-A(K3) C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C T=A(K2) A(K2)=A(K)-T A(K)=A(K)+T T=A(K2+1) A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C T=A(K3) A(K3)=A(K1)-T A(K1)=A(K1)+T T=A(K3+1) A(K3+1)=A(K1+1)-T A(K1+1)=A(K1+1)+T C T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T C R=-A(K3+1) T = A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 80 A(K2+1)=A(K2+1)+T IF (JLAST) 235,235,82 82 JJ=JJDIF +1 C C DO FOR J=1 ILAST= IL +JJ DO 85 I = JJ,ILAST,IDIF KLAST = KL+I DO 85 K=I,KLAST,2 K1 = K+KBIT K2 = K1+KBIT K3 = K2+KBIT C C LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I, C A(K)=A(K)+A(K2)*I C A(K2)=A(K)-A(K2)*I C A(K1)=A(K1)*W+A(K3)*W3 C A(K3)=A(K1)*W-A(K3)*W3 C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C R =-A(K2+1) T = A(K2) A(K2) = A(K)-R A(K) = A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C AWR=A(K1)-A(K1+1) AWI = A(K1+1)+A(K1) R=-A(K3)-A(K3+1) T=A(K3)-A(K3+1) A(K3)=(AWR-R)/ROOT2 A(K3+1)=(AWI-T)/ROOT2 A(K1)=(AWR+R)/ROOT2 A(K1+1)=(AWI+T)/ROOT2 T= A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 85 A(K2+1)=A(K2+1)+T IF(JLAST-1) 235,235,90 90 JJ= JJ + JJDIF C C NOW DO THE REMAINING J'S DO 230 J=2,JLAST C C FETCH W'S C DEF- W=W**INV(J), W2=W**2, W3=W**3 96 I=INV(J+1) 98 IC=NT-I W(1)=S(IC) W(2)=S(I) I2=2*I I2C=NT-I2 IF(I2C)120,110,100 C C 2*I IS IN FIRST QUADRANT 100 W2(1)=S(I2C) W2(2)=S(I2) GO TO 130 110 W2(1)=0. W2(2)=1. GO TO 130 C C 2*I IS IN SECOND QUADRANT 120 I2CC = I2C+NT I2C=-I2C W2(1)=-S(I2C) W2(2)=S(I2CC) 130 I3=I+I2 I3C=NT-I3 IF(I3C)160,150,140 C C I3 IN FIRST QUADRANT 140 W3(1)=S(I3C) W3(2)=S(I3) GO TO 200 150 W3(1)=0. W3(2)=1. GO TO 200 C 160 I3CC=I3C+NT IF(I3CC)190,180,170 C C I3 IN SECOND QUADRANT 170 I3C=-I3C W3(1)=-S(I3C) W3(2)=S(I3CC) GO TO 200 180 W3(1)=-1. W3(2)=0. GO TO 200 C C 3*I IN THIRD QUADRANT 190 I3CCC=NT+I3CC I3CC = -I3CC W3(1)=-S(I3CCC) W3(2)=-S(I3CC) 200 ILAST=IL+JJ DO 220 I=JJ,ILAST,IDIF KLAST=KL+I DO 220 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT C C DO TWO STEPS WITH J NOT 0 C A(K)=A(K)+A(K2)*W2 C A(K2)=A(K)-A(K2)*W2 C A(K1)=A(K1)*W+A(K3)*W3 C A(K3)=A(K1)*W-A(K3)*W3 C C A(K)=A(K)+A(K1) C A(K1)=A(K)-A(K1) C A(K2)=A(K2)+A(K3)*I C A(K3)=A(K2)-A(K3)*I C R=A(K2)*W2(1)-A(K2+1)*W2(2) T=A(K2)*W2(2)+A(K2+1)*W2(1) A(K2)=A(K)-R A(K)=A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T C R=A(K3)*W3(1)-A(K3+1)*W3(2) T=A(K3)*W3(2)+A(K3+1)*W3(1) AWR=A(K1)*W(1)-A(K1+1)*W(2) AWI=A(K1)*W(2)+A(K1+1)*W(1) A(K3)=AWR-R A(K3+1)=AWI-T A(K1)=AWR+R A(K1+1)=AWI+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 220 A(K2+1)=A(K2+1)+T C END OF I AND K LOOPS C 230 JJ=JJDIF+JJ C END OF J-LOOP C 235 JLAST=4*JLAST+3 240 CONTINUE C END OF L LOOP C 250 CONTINUE C END OF ID LOOP C C WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE C BIT-REVERSED. THE FOLLOWING ROUTINE PUTS THEM IN ORDER NTSQ=NT*NT M3MT=M3-MT 350 IF(M3MT) 370,360,360 C C M3 GR. OR EQ. MT 360 IGO3=1 N3VNT=N3/NT MINN3=NT GO TO 380 C C M3 LESS THAN MT 370 IGO3=2 N3VNT=1 NTVN3=NT/N3 MINN3=N3 380 JJD3 = NTSQ/N3 M2MT=M2-MT 450 IF (M2MT)470,460,460 C C M2 GR. OR EQ. MT 460 IGO2=1 N2VNT=N2/NT MINN2=NT GO TO 480 C C M2 LESS THAN MT 470 IGO2 = 2 N2VNT=1 NTVN2=NT/N2 MINN2=N2 480 JJD2=NTSQ/N2 M1MT=M1-MT 550 IF(M1MT)570,560,560 C C M1 GR. OR EQ. MT 560 IGO1=1 N1VNT=N1/NT MINN1=NT GO TO 580 C C M1 LESS THAN MT 570 IGO1=2 N1VNT=1 NTVN1=NT/N1 MINN1=N1 580 JJD1=NTSQ/N1 600 JJ3=1 J=1 DO 880 JPP3=1,N3VNT IPP3=INV(JJ3) DO 870 JP3=1,MINN3 GO TO (610,620),IGO3 610 IP3=INV(JP3)*N3VNT GO TO 630 620 IP3=INV(JP3)/NTVN3 630 I3=(IPP3+IP3)*N2 700 JJ2=1 DO 870 JPP2=1,N2VNT IPP2=INV(JJ2)+I3 DO 860 JP2=1,MINN2 GO TO (710,720),IGO2 710 IP2=INV(JP2)*N2VNT GO TO 730 720 IP2=INV(JP2)/NTVN2 730 I2=(IPP2+IP2)*N1 800 JJ1=1 DO 860 JPP1=1,N1VNT IPP1=INV(JJ1)+I2 DO 850 JP1=1,MINN1 GO TO (810,820),IGO1 810 IP1=INV(JP1)*N1VNT GO TO 830 820 IP1=INV(JP1)/NTVN1 830 I=2*(IPP1+IP1)+1 IF (J-I) 840,850,850 840 T=A(I) A(I)=A(J) A(J)=T T=A(I+1) A(I+1)=A(J+1) A(J+1)=T 850 J=J+2 860 JJ1=JJ1+JJD1 C END OF JPP1 AND JP2 C 870 JJ2=JJ2+JJD2 C END OF JPP2 AND JP3 LOOPS C 880 JJ3 = JJ3+JJD3 C END OF JPP3 LOOP C 890 IF(IFSET)891,895,895 891 DO 892 I = 1,NX 892 A(2*I) = -A(2*I) 895 RETURN C C THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES. C 900 MT=MAX0(M(1),M(2),M(3)) -2 MT = MAX0(2,MT) 904 IF (MT-18) 906,906,13 906 IFERR=0 NT=2**MT NTV2=NT/2 C C SET UP SIN TABLE C THETA=PIE/2**(L+1) FOR L=1 910 THETA=.7853981634 C C JSTEP=2**(MT-L+1) FOR L=1 JSTEP=NT C C JDIF=2**(MT-L) FOR L=1 JDIF=NTV2 S(JDIF)=SIN(THETA) DO 950 L=2,MT THETA=THETA/2. JSTEP2=JSTEP JSTEP=JDIF JDIF=JSTEP/2 S(JDIF)=SIN(THETA) JC1=NT-JDIF S(JC1)=COS(THETA) JLAST=NT-JSTEP2 IF(JLAST - JSTEP) 950,920,920 920 DO 940 J=JSTEP,JLAST,JSTEP JC=NT-J JD=J+JDIF 940 S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC) 950 CONTINUE C C SET UP INV(J) TABLE C 960 MTLEXP=NTV2 C C MTLEXP=2**(MT-L). FOR L=1 LM1EXP=1 C C LM1EXP=2**(L-1). FOR L=1 INV(1)=0 DO 980 L=1,MT INV(LM1EXP+1) = MTLEXP DO 970 J=2,LM1EXP JJ=J+LM1EXP 970 INV(JJ)=INV(J)+MTLEXP MTLEXP=MTLEXP/2 980 LM1EXP=LM1EXP*2 982 IF(IFSET)12,895,12 END C C .................................................................. C C SUBROUTINE HEP C C PURPOSE C COMPUTE THE VALUES OF THE HERMITE POLYNOMIALS H(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL HEP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF HERMITE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF HERMITE POLYNOMIAL C N - ORDER OF HERMITE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C HERMITE POLYNOMIALS H(N,X) C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)) C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE H(0,X)=1, H(1,X)=2*X. C C .................................................................. C SUBROUTINE HEP(Y,X,N) C DIMENSION Y(1) C C TEST OF ORDER Y(1)=1. IF(N)1,1,2 1 RETURN C 2 Y(2)=X+X IF(N-1)1,1,3 C 3 DO 4 I=2,N F=X*Y(I)-FLOAT(I-1)*Y(I-1) 4 Y(I+1)=F+F RETURN END C C .................................................................. C C SUBROUTINE HEPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN HERMITE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL HEPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C X - ARGUMENT VALUE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR HERMITE POLYNOMIALS C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)). C C .................................................................. C SUBROUTINE HEPS(Y,X,C,N) C DIMENSION C(1) C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1. H1=X+X C DO 4 I=2,N H2=X*H1-FLOAT(I-1)*H0 H0=H1 H1=H2+H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE HIST C C PURPOSE C PRINT A HISTOGRAM OF FREQUENCIES VERSUS INTERVALS C C USAGE C CALL HIST(NU,FREQ,IN) C C DESCRIPTION OF PARAMETERS C NU - HISTOGRAM NUMBER (3 DIGITS MAXIMUM) C FREQ - VECTOR OF FREQUENCIES C IN - NUMBER OF INTERVALS AND LENGTH OF FREQ (MAX IS 20) C NORMALLY, FREQ(1) CONTAINS THE FREQUENCY SMALLER THAN C THE LOWER BOUND AND FREQ(IN) CONTAINS THE FREQUENCY C LARGER THAN THE UPPER BOUND C C REMARKS C FREQUENCIES MUST BE POSITIVE NUMBERS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE LARGEST FREQUENCY IS DETERMINED AND SCALING IS USED C IF REQUIRED C C .................................................................. C SUBROUTINE HIST(NU,FREQ,IN) DIMENSION JOUT(20),FREQ(20) C 1 FORMAT(6H EACH ,A1,8H EQUALS ,I2,7H POINTS,/) 2 FORMAT(I6,4X,20(4X,A1)) 3 FORMAT(9H0INTERVAL,4X,19(I2,3X),I2) 4 FORMAT(1H1,47X,11H HISTOGRAM ,I3) 5 FORMAT(10H0FREQUENCY,20I5) 6 FORMAT(6H CLASS) 7 FORMAT(113H ---------------------------------------------------- 1----------------------------------------------------------) 8 FORMAT(1H ) 9 FORMAT(A1) 10 FORMAT(1H*) C REWIND 13 WRITE(13,10) REWIND 13 READ(13,9) K REWIND 13 WRITE(13,8) REWIND 13 READ(13,9) NOTH REWIND 13 C C PRINT TITLE AND FREQUENCY VECTOR C WRITE(6,4) NU DO 12 I=1,IN 12 JOUT(I)=FREQ(I) WRITE(6,5)(JOUT(I),I=1,IN) WRITE(6,7) C C FIND LARGEST FREQUENCY C FMAX=0.0 DO 20 I=1,IN IF(FREQ(I)-FMAX) 20,20,15 15 FMAX=FREQ(I) 20 CONTINUE C C SCALE IF NECESSARY C JSCAL=1 IF(FMAX-50.0) 40,40,30 30 JSCAL=(FMAX+49.0)/50.0 WRITE(6,1)K,JSCAL C C CLEAR OUTPUT AREA TO BLANKS C 40 DO 50 I=1,IN 50 JOUT(I)=NOTH C C LOCATE FREQUENCIES IN EACH INTERVAL C MAX=FMAX/FLOAT(JSCAL) DO 80 I=1,MAX X=MAX-(I-1) DO 70 J=1,IN IF(FREQ(J)/FLOAT(JSCAL)-X) 70,60,60 60 JOUT(J)=K 70 CONTINUE IX=X*FLOAT(JSCAL) C C PRINT LINE OF FREQUENCIES C 80 WRITE(6,2)IX,(JOUT(J),J=1,IN) C C GENERATE CONSTANTS C DO 90 I=1,IN 90 JOUT(I)=I C C PRINT INTERVAL NUMBERS C WRITE(6,7) WRITE(6,3)(JOUT(J),J=1,IN) WRITE(6,6) RETURN END C C C .................................................................. C C SUBROUTINE HPCG C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL C DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL HPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER C OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF C THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR C COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED C BY THE USER) AND SUBROUTINE HPCG. EXCEPT PRMT(5) C THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE C HPCG AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCG INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE HPCG AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE HPCG DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING HPCG) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - INPUT VECTOR OF INITIAL VALUES. (DESTROYED) C LATERON Y IS THE RESULTING VECTOR OF DEPENDENT C VARIABLES COMPUTED AT INTERMEDIATE POINTS X. C DERY - INPUT VECTOR OF ERROR WEIGHTS. (DESTROYED) C THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1. C LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH C BELONG TO FUNCTION VALUES Y AT A POINT X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE HPCG RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM C TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST C MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT C DESTROY X AND Y. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE HPCG IS TERMINATED. C AUX - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM C COLUMNS. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR- C CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4 C PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE C DEPENDENT VARIABLES. C FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS C USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR C COMPUTATION OF STARTING VALUES. C SUBROUTINE HPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE CODED BY THE USER. C FOR REFERENCE, SEE C (1) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (2) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C C .................................................................. C SUBROUTINE HPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C C DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1) N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0. DO 1 I=1,NDIM AUX(16,I)=0. AUX(15,I)=DERY(I) 1 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))3,2,4 C C ERROR RETURNS 2 IHLF=12 GOTO 4 3 IHLF=13 C C COMPUTATION OF DERY FOR STARTING VALUES 4 CALL FCT(X,Y,DERY) C C RECORDING OF STARTING VALUES CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,5,6 5 IF(IHLF)7,7,6 6 RETURN 7 DO 8 I=1,NDIM 8 AUX(8,I)=DERY(I) C C COMPUTATION OF AUX(2,I) ISW=1 GOTO 100 C 9 X=X+H DO 10 I=1,NDIM 10 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 11 IHLF=IHLF+1 X=X-H DO 12 I=1,NDIM 12 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW=2 GOTO 100 C 13 X=X+H CALL FCT(X,Y,DERY) N=2 DO 14 I=1,NDIM AUX(2,I)=Y(I) 14 AUX(9,I)=DERY(I) ISW=3 GOTO 100 C C COMPUTATION OF TEST VALUE DELT 15 DELT=0. DO 16 I=1,NDIM 16 DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I)) DELT=.06666667*DELT IF(DELT-PRMT(4))19,19,17 17 IF(IHLF-10)11,18,18 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 18 IHLF=11 X=X+H GOTO 4 C C THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS. 19 X=X+H CALL FCT(X,Y,DERY) DO 20 I=1,NDIM AUX(3,I)=Y(I) 20 AUX(10,I)=DERY(I) N=3 ISW=4 GOTO 100 C 21 N=1 X=X+H CALL FCT(X,Y,DERY) X=PRMT(1) DO 22 I=1,NDIM AUX(11,I)=DERY(I) 22 Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 23 X=X+H N=N+1 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,24,6 24 IF(N-4)25,200,200 25 DO 26 I=1,NDIM AUX(N,I)=Y(I) 26 AUX(N+7,I)=DERY(I) IF(N-3)27,29,200 C 27 DO 28 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 28 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 23 C 29 DO 30 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 30 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 23 C C THE FOLLOWING PART OF SUBROUTINE HPCG COMPUTES BY MEANS OF C RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING C PREDICTOR-CORRECTOR METHOD. 100 DO 101 I=1,NDIM Z=H*AUX(N+7,I) AUX(5,I)=Z 101 Y(I)=AUX(N,I)+.4*Z C Z IS AN AUXILIARY STORAGE LOCATION C Z=X+.4*H CALL FCT(Z,Y,DERY) DO 102 I=1,NDIM Z=H*DERY(I) AUX(6,I)=Z 102 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*Z C Z=X+.4557372*H CALL FCT(Z,Y,DERY) DO 103 I=1,NDIM Z=H*DERY(I) AUX(7,I)=Z 103 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*Z C Z=X+H CALL FCT(Z,Y,DERY) DO 104 I=1,NDIM 104 Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) GOTO(9,13,15,21),ISW C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 200 ISTEP=3 201 IF(N-8)204,202,204 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 202 DO 203 N=2,7 DO 203 I=1,NDIM AUX(N-1,I)=AUX(N,I) 203 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 204 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 205 I=1,NDIM AUX(N-1,I)=Y(I) 205 AUX(N+6,I)=DERY(I) X=X+H 206 ISTEP=ISTEP+1 DO 207 I=1,NDIM DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 207 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. C CALL FCT(X,Y,DERY) C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY C DO 208 I=1,NDIM DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 208 Y(I)=DELT+.07438017*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0. DO 209 I=1,NDIM 209 DELT=DELT+AUX(15,I)*ABS(AUX(16,I)) IF(DELT-PRMT(4))210,222,222 C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. 210 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))212,211,212 211 IF(IHLF-11)213,212,212 212 RETURN 213 IF(H*(X-PRMT(2)))214,212,212 214 IF(ABS(X-PRMT(2))-.1*ABS(H))212,215,215 215 IF(DELT-.02*PRMT(4))216,216,201 C C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE 216 IF(IHLF)201,201,217 217 IF(N-7)201,218,218 218 IF(ISTEP-4)201,219,219 219 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)201,220,201 220 H=H+H IHLF=IHLF-1 ISTEP=0 DO 221 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 221 AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 201 C C C H MUST BE HALVED 222 IHLF=IHLF+1 IF(IHLF-10)223,223,210 223 H=.5*H ISTEP=0 DO 224 I=1,NDIM Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 224 AUX(N+4,I)=AUX(N+5,I) X=X-H DELT=X-(H+H) CALL FCT(DELT,Y,DERY) DO 225 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 225 Y(I)=AUX(N-4,I) DELT=DELT-(H+H) CALL FCT(DELT,Y,DERY) DO 226 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 226 AUX(N+3,I)=DERY(I) GOTO 206 END C C .................................................................. C C SUBROUTINE HPCL C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY LINEAR C DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL HPCL (PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) C PARAMETERS AFCT,FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER C OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF C THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR C COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED C BY THE USER) AND SUBROUTINE HPCL. EXCEPT PRMT(5) C THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE C HPCL AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCL INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE HPCL AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE HPCL DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING HPCL) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - INPUT VECTOR OF INITIAL VALUES. (DESTROYED) C LATERON Y IS THE RESULTING VECTOR OF DEPENDENT C VARIABLES COMPUTED AT INTERMEDIATE POINTS X. C DERY - INPUT VECTOR OF ERROR WEIGHTS. (DESTROYED) C THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1. C LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH C BELONG TO FUNCTION VALUES Y AT A POINT X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE HPCL RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C AFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES MATRIX A (FACTOR OF VECTOR Y ON THE C RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE. C ITS PARAMETER LIST MUST BE X,A. THE SUBROUTINE C SHOULD NOT DESTROY X. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE C RIGHT HAND SIDE OF THE SYSTEM) FOR A GIVEN X-VALUE. C ITS PARAMETER LIST MUST BE X,F. THE SUBROUTINE C SHOULD NOT DESTROY X. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE HPCL IS TERMINATED. C AUX - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM C COLUMNS. C A - AN NDIM BY NDIM MATRIX, WHICH IS USED AS AUXILIARY C STORAGE ARRAY. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR- C CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4 C PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE C DEPENDENT VARIABLES. C FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS C USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR C COMPUTATION OF STARTING VALUES. C SUBROUTINE HPCL AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE CODED BY THE USER. C FOR REFERENCE, SEE C (1) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (2) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C C .................................................................. C SUBROUTINE HPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) C C C THE FOLLOWING FIRST PART OF SUBROUTINE HPCL (UNTIL FIRST BREAK- C POINT FOR LINKAGE) HAS TO STAY IN CORE DURING THE WHOLE C COMPUTATION C DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1) GOTO 100 C C THIS PART OF SUBROUTINE HPCL COMPUTES THE RIGHT HAND SIDE DERY OF C THE GIVEN SYSTEM OF LINEAR DIFFERENTIAL EQUATIONS. 1 CALL AFCT(X,A) CALL FCT(X,DERY) DO 3 M=1,NDIM LL=M-NDIM HS=0. DO 2 L=1,NDIM LL=LL+NDIM 2 HS=HS+A(LL)*Y(L) 3 DERY(M)=HS+DERY(M) GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2 C C POSSIBLE BREAK-POINT FOR LINKAGE C 100 N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0. DO 101 I=1,NDIM AUX(16,I)=0. AUX(15,I)=DERY(I) 101 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))103,102,104 C C ERROR RETURNS 102 IHLF=12 GOTO 104 103 IHLF=13 C C COMPUTATION OF DERY FOR STARTING VALUES 104 ISW2=1 GOTO 1 C C RECORDING OF STARTING VALUES 105 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,106,107 106 IF(IHLF)108,108,107 107 RETURN 108 DO 109 I=1,NDIM 109 AUX(8,I)=DERY(I) C C COMPUTATION OF AUX(2,I) ISW1=1 GOTO 200 C 110 X=X+H DO 111 I=1,NDIM 111 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 112 IHLF=IHLF+1 X=X-H DO 113 I=1,NDIM 113 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW1=2 GOTO 200 C 114 X=X+H ISW2=5 GOTO 1 115 N=2 DO 116 I=1,NDIM AUX(2,I)=Y(I) 116 AUX(9,I)=DERY(I) ISW1=3 GOTO 200 C C COMPUTATION OF TEST VALUE DELT 117 DELT=0. DO 118 I=1,NDIM 118 DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I)) DELT=.06666667*DELT IF(DELT-PRMT(4))121,121,119 119 IF(IHLF-10)112,120,120 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 120 IHLF=11 X=X+H GOTO 104 C C SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS 121 X=X+H ISW2=6 GOTO 1 122 DO 123 I=1,NDIM AUX(3,I)=Y(I) 123 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 200 C 124 N=1 X=X+H ISW2=7 GOTO 1 125 X=PRMT(1) DO 126 I=1,NDIM AUX(11,I)=DERY(I) 126 Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 127 X=X+H N=N+1 ISW2=12 GOTO 1 128 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,129,107 129 IF(N-4)130,300,300 130 DO 131 I=1,NDIM AUX(N,I)=Y(I) 131 AUX(N+7,I)=DERY(I) IF(N-3)132,134,300 C 132 DO 133 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 133 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 127 C 134 DO 135 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 135 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 127 C C THE FOLLOWING PART OF SUBROUTINE HPCL COMPUTES BY MEANS OF C RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING C PREDICTOR-CORRECTOR METHOD. 200 Z=X DO 201 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 201 Y(I)=AUX(N,I)+.4*X C X IS AN AUXILIARY STORAGE LOCATION C X=Z+.4*H ISW2=2 GOTO 1 202 DO 203 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 203 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X C X=Z+.4557372*H ISW2=3 GOTO 1 204 DO 205 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 205 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X C X=Z+H ISW2=4 GOTO 1 206 DO 207 I=1,NDIM 207 Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) X=Z GOTO(110,114,117,124),ISW1 C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 300 ISTEP=3 301 IF(N-8)304,302,304 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 302 DO 303 N=2,7 DO 303 I=1,NDIM AUX(N-1,I)=AUX(N,I) 303 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 304 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 305 I=1,NDIM AUX(N-1,I)=Y(I) 305 AUX(N+6,I)=DERY(I) X=X+H 306 ISTEP=ISTEP+1 DO 307 I=1,NDIM DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 307 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. ISW2=8 GOTO 1 C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY C 308 DO 309 I=1,NDIM DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 309 Y(I)=DELT+.07438017*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0. DO 310 I=1,NDIM 310 DELT=DELT+AUX(15,I)*ABS(AUX(16,I)) IF(DELT-PRMT(4))311,324,324 C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. 311 ISW2=9 GOTO 1 312 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))314,313,314 313 IF(IHLF-11)315,314,314 314 RETURN 315 IF(H*(X-PRMT(2)))316,314,314 316 IF(ABS(X-PRMT(2))-.1*ABS(H))314,317,317 317 IF(DELT-.02*PRMT(4))318,318,301 C C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE 318 IF(IHLF)301,301,319 319 IF(N-7)301,320,320 320 IF(ISTEP-4)301,321,321 321 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)301,322,301 322 H=H+H IHLF=IHLF-1 ISTEP=0 DO 323 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 323 AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 301 C C C H MUST BE HALVED 324 IHLF=IHLF+1 IF(IHLF-10)325,325,311 325 H=.5*H ISTEP=0 DO 326 I=1,NDIM Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 326 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=10 GOTO 1 327 DO 328 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 328 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=11 GOTO 1 329 X=DELT DO 330 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 330 AUX(N+3,I)=DERY(I) GOTO 306 END C C .................................................................. C C SUBROUTINE HSBG C C PURPOSE C TO REDUCE A REAL MATRIX INTO UPPER ALMOST TRIANGULAR FORM C C USAGE C CALL HSBG(N,A,IA) C C DESCRIPTION OF THE PARAMETERS C N ORDER OF THE MATRIX C A THE INPUT MATRIX, N BY N C IA SIZE OF THE FIRST DIMENSION ASSIGNED TO THE ARRAY C A IN THE CALLING PROGRAM WHEN THE MATRIX IS IN C DOUBLE SUBSCRIPTED DATA STORAGE MODE. IA=N WHEN C THE MATRIX IS IN SSP VECTOR STORAGE MODE. C C REMARKS C THE HESSENBERG FORM REPLACES THE ORIGINAL MATRIX IN THE C ARRAY A. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SIMILARITY TRANSFORMATIONS USING ELEMENTARY ELIMINATION C MATRICES, WITH PARTIAL PIVOTING. C C REFERENCES C J.H. WILKINSON - THE ALGEBRAIC EIGENVALUE PROBLEM - C CLARENDON PRESS, OXFORD, 1965. C C .................................................................. C SUBROUTINE HSBG(N,A,IA) DIMENSION A(1) DOUBLE PRECISION S L=N NIA=L*IA LIA=NIA-IA C C L IS THE ROW INDEX OF THE ELIMINATION C 20 IF(L-3) 360,40,40 40 LIA=LIA-IA L1=L-1 L2=L1-1 C C SEARCH FOR THE PIVOTAL ELEMENT IN THE LTH ROW C ISUB=LIA+L IPIV=ISUB-IA PIV=ABS(A(IPIV)) IF(L-3) 90,90,50 50 M=IPIV-IA DO 80 I=L,M,IA T=ABS(A(I)) IF(T-PIV) 80,80,60 60 IPIV=I PIV=T 80 CONTINUE 90 IF(PIV) 100,320,100 100 IF(PIV-ABS(A(ISUB))) 180,180,120 C C INTERCHANGE THE COLUMNS C 120 M=IPIV-L DO 140 I=1,L J=M+I T=A(J) K=LIA+I A(J)=A(K) 140 A(K)=T C C INTERCHANGE THE ROWS C M=L2-M/IA DO 160 I=L1,NIA,IA T=A(I) J=I-M A(I)=A(J) 160 A(J)=T C C TERMS OF THE ELEMENTARY TRANSFORMATION C 180 DO 200 I=L,LIA,IA 200 A(I)=A(I)/A(ISUB) C C RIGHT TRANSFORMATION C J=-IA DO 240 I=1,L2 J=J+IA LJ=L+J DO 220 K=1,L1 KJ=K+J KL=K+LIA 220 A(KJ)=A(KJ)-A(LJ)*A(KL) 240 CONTINUE C C LEFT TRANSFORMATION C K=-IA DO 300 I=1,N K=K+IA LK=K+L1 S=A(LK) LJ=L-IA DO 280 J=1,L2 JK=K+J LJ=LJ+IA 280 S=S+A(LJ)*A(JK)*1.0D0 300 A(LK)=S C C SET THE LOWER PART OF THE MATRIX TO ZERO C DO 310 I=L,LIA,IA 310 A(I)=0.0 320 L=L1 GO TO 20 360 RETURN END C C .................................................................. C C SUBROUTINE I0 C C PURPOSE C COMPUTE THE MODIFIED BESSEL FUNCTION I OF ORDER ZERO C C USAGE C CALL I0(X,RI0) C C DESCRIPTION OF PARAMETERS C X -GIVEN ARGUMENT OF THE BESSEL FUNCTION I OF ORDER 0 C RI0 -RESULTANT VALUE OF THE BESSEL FUNCTION I OF ORDER 0 C C REMARKS C LARGE VALUES OF THE ARGUMENT MAY CAUSE OVERFLOW IN THE C BUILTIN EXP-FUNCTION C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C POLYNOMIAL APPROXIMATIONS GIVEN BY E.E. ALLEN ARE USED FOR C CALCULATION. C FOR REFERENCE SEE C M. ABRAMOWITZ AND I.A. STEGUN,'HANDBOOK OF MATHEMATICAL C FUNCTIONS', U.S. DEPARTMENT OF COMMERCE, NATIONAL BUREAU OF C STANDARDS APPLIED MATHEMATICS SERIES, 1966, P.378. C C .................................................................. C SUBROUTINE I0(X,RI0) RI0=ABS(X) IF(RI0-3.75)1,1,2 1 Z=X*X*7.111111E-2 RI0=((((( 4.5813E-3*Z+3.60768E-2)*Z+2.659732E-1)*Z+1.206749E0)*Z 1+3.089942E0)*Z+3.515623E0)*Z+1. RETURN 2 Z=3.75/RI0 RI0= EXP(RI0)/SQRT(RI0)*((((((((3.92377E-3*Z-1.647633E-2)*Z 1+2.635537E-2)*Z-2.057706E-2)*Z+9.16281E-3)*Z-1.57565E-3)*Z 2+2.25319E-3)*Z+1.328592E-2)*Z+3.989423E-1) RETURN END C C .................................................................. C C SUBROUTINE INUE C C PURPOSE C COMPUTE THE MODIFIED BESSEL FUNCTIONS I FOR ORDERS 1 TO N C C USAGE C CALL INUE(X,N,ZI,RI) C C DESCRIPTION OF PARAMETERS C X -GIVEN ARGUMENT OF THE BESSEL FUNCTIONS I C N -GIVEN MAXIMUM ORDER OF BESSEL FUNCTIONS I C ZI -GIVEN VALUE OF BESSEL FUNCTION I OF ORDER ZERO C FOR ARGUMENT X C RI -RESULTANT VECTOR OF DIMENSION N, CONTAINING THE C VALUES OF THE FUNCTIONS I FOR ORDERS 1 TO N C C REMARKS C THE VALUE OF ZI MAY BE CALCULATED USING SUBROUTINE I0. C USING A DIFFERENT VALUE HAS THE EFFECT THAT ALL VALUES OF C BESSEL FUNCTIONS I ARE MULTIPLIED BY THE FACTOR ZI/I(0,X) C WHERE I(0,X) IS THE VALUE OF I FOR ORDER 0 AND ARGUMENT X. C THIS MAY BE USED DISADVANTAGEOUSLY IF ONLY THE RATIOS OF I C FOR DIFFERENT ORDERS ARE REQUIRED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE VALUES ARE OBTAINED USING BACKWARD RECURRENCE RELATION C TECHNIQUE. THE RATIO I(N+1,X)/I(N,X) IS OBTAINED FROM A C CONTINUED FRACTION. C FOR REFERENCE SEE C G. BLANCH,'NUMERICAL EVALUATION OF CONTINUED FRACTIONS', C SIAM REVIEW, VOL.6,NO.4,1964,PP.383-421. C C .................................................................. C SUBROUTINE INUE(X,N,ZI,RI) DIMENSION RI(1) IF(N)10,10,1 1 FN=N+N Q1=X/FN IF(ABS(X)-5.E-4)6,6,2 2 A0=1. A1=0. B0=0. B1=1. FI=FN 3 FI=FI+2. AN=FI/ABS(X) A=AN*A1+A0 B=AN*B1+B0 A0=A1 B0=B1 A1=A B1=B Q0=Q1 Q1=A/B IF(ABS((Q1-Q0)/Q1)-1.E-6)4,4,3 4 IF(X)5,6,6 5 Q1=-Q1 6 K=N 7 Q1=X/(FN+X*Q1) RI(K)=Q1 FN=FN-2. K=K-1 IF(K)8,8,7 8 FI=ZI DO 9 I=1,N FI=FI*RI(I) 9 RI(I)=FI 10 RETURN END C C .................................................................. C C SUBROUTINE JELF C C PURPOSE C COMPUTES THE THREE JACOBIAN ELLIPTIC FUNCTIONS SN, CN, DN. C C USAGE C CALL JELF(SN,CN,DN,X,SCK) C C DESCRIPTION OF PARAMETERS C SN - RESULT VALUE SN(X) C CN - RESULT VALUE CN(X) C DN - RESULT VALUE DN(X) C X - ARGUMENT OF JACOBIAN ELLIPTIC FUNCTIONS C SCK - SQUARE OF COMPLEMENTARY MODULUS C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C X=INTEGRAL(1/SQRT((1-T*T)*(1-(K*T)**2)), SUMMED OVER C T FROM 0 TO SN), WHERE K=SQRT(1-SCK). C SN*SN + CN*CN = 1 C (K*SN)**2 + DN**2 = 1. C EVALUATION C CALCULATION IS DONE USING THE PROCESS OF THE ARITHMETIC C GEOMETRIC MEAN TOGETHER WITH GAUSS DESCENDING TRANSFORMATION C BEFORE INVERSION OF THE INTEGRAL TAKES PLACE. C REFERENCE C R. BULIRSCH, NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIOMS. C HANDBOOK SERIES OF SPECIAL FUNCTIONS C NUMERISCHE MATHEMATIK VOL. 7, 1965, PP. 78-90. C C .................................................................. C SUBROUTINE JELF(SN,CN,DN,X,SCK) C C DIMENSION ARI(12),GEO(12) C TEST MODULUS CM=SCK Y=X IF(SCK)3,1,4 1 D=EXP(X) A=1./D B=A+D CN=2./B DN=CN SN=TANH(X) C DEGENERATE CASE SCK=0 GIVES RESULTS C CN X = DN X = 1/COSH X C SN X = TANH X 2 RETURN C JACOBIS MODULUS TRANSFORMATION 3 D=1.-SCK CM=-SCK/D D=SQRT(D) Y=D*X 4 A=1. DN=1. DO 6 I=1,12 L=I ARI(I)=A CM=SQRT(CM) GEO(I)=CM C=(A+CM)*.5 IF(ABS(A-CM)-1.E-4*A)7,7,5 5 CM=A*CM 6 A=C C C START BACKWARD RECURSION 7 Y=C*Y SN=SIN(Y) CN=COS(Y) IF(SN)8,13,8 8 A=CN/SN C=A*C DO 9 I=1,L K=L-I+1 B=ARI(K) A=C*A C=DN*C DN=(GEO(K)+A)/(B+A) 9 A=C/B A=1./SQRT(C*C+1.) IF(SN)10,11,11 10 SN=-A GOTO 12 11 SN=A 12 CN=C*SN 13 IF(SCK)14,2,2 14 A=DN DN=CN CN=A SN=SN/D RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR THE KOLMOGOROV-SMIRNOV TEST-KOLM C C PURPOSE C (1) READ THE CONTROL CARD FOR A ONE OR TWO SAMPLE TEST C (2) READ THE SAMPLE DATA AND DETERMINE THE SAMPLE SIZES C (3) PRINT RESULTS C C REMARKS C THE USER SHOULD NOTE THE REMARKS GIVEN IN SUBROUTINES C KOLMO, KOLM2, AND SMIRN, AND THE MATHEMATICAL DESCRIPTIONS C FOR THESE SUBROUTINES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C KOLMO C KOLM2 C SMIRN C NDTR C C METHOD C REFER TO SUBROUTINES KOLMO, KOLM2, AND SMIRN C C .................................................................. C C THE FOLLOWING DIMENSIONS MUST BE GREATER THAN THE NUMBER OF DATA C ELEMENTS IN THE TWO SAMPLES, M AND N cC c DIMENSION X(501),Y(501) cC cC .................................................................. cC c DIMENSION TITLE(5),D(12),TIT1(20),DIST(5,3) cC cC .................................................................. cC c1 FORMAT(5A4,3I1,5(F1.0,2F5.0)) c2 FORMAT(//'CC.21, CONTROL CARD, INCORRECT, OR SAMPLE SIZE IS TOO LA c 1RGE. JOB IGNORED.') c3 FORMAT(12F6.0) c4 FORMAT(1H1,5A4) c5 FORMAT(//2H A,I2,' SAMPLE TEST WAS REQUESTED') c6 FORMAT(20A4) c7 FORMAT(//(10F10.3)) c8 FORMAT(//' SORTED SAMPLE ONE FOLLOWS') c9 FORMAT(//' THE HYPOTHESIS THAT THE SAMPLE IS FROM A(N) ',4A4, ' D c 1ISTRIBUTION') c10 FORMAT(//' SORTED SAMPLE TWO FOLLOWS') c11 FORMAT(//' THE HYPOTHESIS THAT THE TWO SAMPLES ARE FROM THE SAME P c 1OPULATION CAN BE REJECTED WITH (ASYMPTOTIC)',/,' PROBABILITY OF BE c 2ING INCORRECT OF ',F6.3,'. THE STATISTIC Z IS ',E12.4,' FOR THESE c 3 SAMPLES.') c12 FORMAT(//,' THE SIZE OF SAMPLE',I3,' IS',I4,'.') c13 FORMAT(//,' NOTE THE REMARKS CONCERNING ASYMPTOTIC RESULTS AND SAM c 1PLE SIZE IN SUBROUTINE SMIRN') c14 FORMAT(//,' AT LEAST ONE (S) ENTRY PARAMETER FOR THE SUBROUTINE KO c 1LMO WAS INCORRECT.'/' THE TEST FOR THE ASSOCIATED CONTINUOUS PDF W c 2AS IGNORED.') c15 FORMAT(A4) c16 FORMAT(//,' THIS JOB CALLS FOR THE USE OF A PREVIOUSLY READ SAMPLE c 1, AND THE PREVIOUS JOB WAS IGNORED BECAUSE OF ERRORS.'/ ' JOB IGNO c 2RED.') c17 FORMAT(//,' FIRST CARD IN JOB DECK (JOB CONTROL CARD) IS INCORRECT c 1.') c18 FORMAT(1H ,' WITH MEAN',F13.4,' AND VARIANCE',F13.4) c19 FORMAT(1H ,' WITH MEDIAN',F13.4,' AND FIRST QUARTILE',F13.4) c20 FORMAT(1H ,' IN THE INTERVAL',F13.4,' TO',F13.4,' INCLUSIVE') c21 FORMAT(1H ,' CAN BE REJECTED WITH PROBABILITY',F6.3,' OF BEING INC c 1ORRECT. THE STATISTIC Z',/,' IS',E12.4,' FOR THIS SAMPLE.') c22 FORMAT(//,' THE JOB WITH TITLE ',5A4,' WAS COMPLETED.') cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC READ DISTRIBUTION NAMES AND JOB CONTROL CARD cC c IFL=0 c READ(5,15)DASH c READ(5,6)TIT1 cC cC SELECT PROGRAM CONTROLS cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ(5,15)DAS2 c IF (EOF) GOTO 999 c IF(DASH-DAS2)101,102,101 c101 WRITE(6,17) c GO TO 107 c102 READ(5,1)TITLE,IS,IR,IO,((DIST(I,J),J=1,3),I=1,5) c IES=0 c WRITE(6,4)TITLE c WRITE(6,5)IS cC cC NUMBER OF SAMPLES DECISION cC c IF(IR)103,105,103 c103 IF(IFL)104,115,104 c104 WRITE(6,16) c GO TO 107 c105 IF(IS-1)106,109,109 cC cC NOT ONE OR TWO SAMPLES cC c106 WRITE(6,2) c107 READ(5,15)DAS2 c IF(DASH-DAS2)107,108,107 c108 IFL=1 c GO TO 102 cC cC READ FIRST SAMPLE cC c109 N=0 c DO 111 I=1,50 c READ(5,3)D c DO 111 J=1,12 c IF(D(J)-999999.0)110,112,110 c110 N=N+1 c IF(N-501)111,106,106 c111 X(N)=D(J) c112 N1=1 c WRITE(6,12)N1,N cC cC CHECK THE SIZE OF N cC c IF(N-100)113,113,114 c113 WRITE(6,13) c114 IF(IS-2)121,115,106 cC cC READ SECOND SAMPLE cC c115 M=0 c DO 117 I=1,50 c READ(5,3)D c DO 117 J=1,12 c IF(D(J)-999999.0)116,118,116 c116 M=M+1 c IF(M-501)117,106,106 c117 Y(M)=D(J) c118 N1=2 c WRITE(6,12)N1,M cC cC CHECK THE SIZE OF M cC c IF(M-100)119,119,120 c119 WRITE(6,13) c120 IF(IS-1)121,121,133 cC cC ONE SAMPLE TEST USING ALL DISTRIBUTIONS REQUESTED cC c121 DO 130 I=1,5 c IF(DIST(I,1))130,130,122 c122 CALL KOLMO(X,N,Z,P,I,DIST(I,2),DIST(I,3),IER) c IES=IER+IES c IF(IER)130,124,130 c123 WRITE(6,14) c GO TO 136 cC cC OUTPUT RESULTS cC c124 K=4*I-3 c WRITE(6,9)TIT1(K),TIT1(K+1),TIT1(K+2),TIT1(K+3) c IF(I-3)125,126,127 c125 S2=DIST(I,3)**2 c WRITE(6,18)DIST(I,2),S2 c GO TO 129 c126 S2=DIST(I,2)-DIST(I,3) c WRITE(6,19)DIST(I,2),S2 c GO TO 129 c127 IF(I-4)128,128,130 c128 WRITE(6,20)DIST(I,2),DIST(I,3) c129 WRITE(6,21)P,Z c130 CONTINUE cC cC OUTPUT SAMPLE ONE DECISION cC c IF(IO)131,132,131 c131 WRITE(6,8) c WRITE(6,7)(X(J),J=1,N) c132 IF(IES)123,136,123 cC cC TWO SAMPLE TEST cC c133 CALL KOLM2(X,Y,N,M,Z,P) cC cC OUTPUT SAMPLES DECISION cC c IF(IO)134,135,134 c134 WRITE(6,8) c WRITE(6,7)(X(J),J=1,N) c WRITE(6,10) c WRITE(6,7)(Y(J),J=1,M) c135 WRITE(6,11)P,Z c136 IFL=0 c WRITE(6,22)TITLE c GO TO 100 c999 STOP c END C C .................................................................. C C SUBROUTINE KOLM2 C C PURPOSE C C TESTS THE DIFFERENCE BETWEEN TWO SAMPLE DISTRIBUTION C FUNCTIONS USING THE KOLMOGOROV-SMIRNOV TEST C C USAGE C CALL KOLM2(X,Y,N,M,Z,PROB) C C DESCRIPTION OF PARAMETERS C X - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS. ON C RETURN FROM KOLM2, X HAS BEEN SORTED INTO A C MONOTONIC NON-DECREASING SEQUENCE. C Y - INPUT VECTOR OF M INDEPENDENT OBSERVATIONS. ON C RETURN FROM KOLM2, Y HAS BEEN SORTED INTO A C MONOTONIC NON-DECREASING SEQUENCE. C N - NUMBER OF OBSERVATIONS IN X C M - NUMBER OF OBSERVATIONS IN Y C Z - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH C RESPECT TO THE SPECTRUM OF X AND Y OF C SQRT((M*N)/(M+N))*ABS(FN(X)-GM(Y)) WHERE C FN(X) IS THE EMPIRICAL DISTRIBUTION FUNCTION OF THE C SET (X) AND GM(Y) IS THE EMPIRICAL DISTRIBUTION C FUNCTION OF THE SET (Y). C PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF C THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF C THE HYPOTHESIS THAT X AND Y ARE FROM THE SAME PDF IS C TRUE. E.G., PROB= 0.05 IMPLIES THAT ONE CAN REJECT C THE NULL HYPOTHESIS THAT THE SETS X AND Y ARE FROM C THE SAME DENSITY WITH 5 PER CENT PROBABILITY OF BEING C INCORRECT. PROB = 1. - SMIRN(Z). C C REMARKS C N AND M SHOULD BE GREATER THAN OR EQUAL TO 100. (SEE THE C MATHEMATICAL DESCRIPTION FOR THIS SUBROUTINE AND FOR THE C SUBROUTINE SMIRN, CONCERNING ASYMPTOTIC FORMULAE). C C DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL C WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY. C IF ONE WISHES TO COMMUNICATE WITH KOLM2 IN A DOUBLE C PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED C PROGRAM SNGL(X) PRIOR TO CALLING KOLM2, AND CALL THE C FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLM2. C (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION C CAPABILITY AS SUPPLIED BY THIS PACKAGE.) C C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SMIRN C C METHOD C FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV C LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS-- C ANNALS OF MATH. STAT., 19, 1948. 177-189, C (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT C OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19, C 1948. 279-281. C (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND C STATISTICS--ACADEMIC PRESS, NEW YORK, 1964. 490-493, C (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA C PUBLISHING COMPANY, NEW YORK, 1962. 384-401. C C .................................................................. C SUBROUTINE KOLM2(X,Y,N,M,Z,PROB) DIMENSION X(1),Y(1) C C SORT X INTO ASCENDING SEQUENCE C DO 5 I=2,N IF(X(I)-X(I-1))1,5,5 1 TEMP=X(I) IM=I-1 DO 3 J=1,IM L=I-J IF(TEMP-X(L))2,4,4 2 X(L+1)=X(L) 3 CONTINUE X(1)=TEMP GO TO 5 4 X(L+1)=TEMP 5 CONTINUE C C SORT Y INTO ASCENDING SEQUENCE C DO 10 I=2,M IF(Y(I)-Y(I-1))6,10,10 6 TEMP=Y(I) IM=I-1 DO 8 J=1,IM L=I-J IF(TEMP-Y(L))7,9,9 7 Y(L+1)=Y(L) 8 CONTINUE Y(1)=TEMP GO TO 10 9 Y(L+1)=TEMP 10 CONTINUE C C CALCULATE D = ABS(FN-GM) OVER THE SPECTRUM OF X AND Y C XN=FLOAT(N) XN1=1./XN XM=FLOAT(M) XM1=1./XM D=0.0 I=0 J=0 K=0 L=0 11 IF(X(I+1)-Y(J+1))12,13,18 12 K=1 GO TO 14 13 K=0 14 I=I+1 IF(I-N)15,21,21 15 IF(X(I+1)-X(I))14,14,16 16 IF(K)17,18,17 C C CHOOSE THE MAXIMUM DIFFERENCE, D C 17 D=AMAX1(D,ABS(FLOAT(I)*XN1-FLOAT(J)*XM1)) IF(L)22,11,22 18 J=J+1 IF(J-M)19,20,20 19 IF(Y(J+1)-Y(J))18,18,17 20 L=1 GO TO 17 21 L=1 GO TO 16 C C CALCULATE THE STATISTIC Z C 22 Z=D*SQRT((XN*XM)/(XN+XM)) C C CALCULATE THE PROBABILITY ASSOCIATED WITH Z C CALL SMIRN(Z,PROB) PROB=1.0-PROB RETURN END C C .................................................................. C C SUBROUTINE KOLMO C C PURPOSE C TESTS THE DIFFERENCE BETWEEN EMPIRICAL AND THEORETICAL C DISTRIBUTIONS USING THE KOLMOGOROV-SMIRNOV TEST C C USAGE C CALL KOLMO(X,N,Z,PROB,IFCOD,U,S,IER) C C DESCRIPTION OF PARAMETERS C X - INPUT VECTOR OF N INDEPENDENT OBSERVATIONS. ON C RETURN FROM KOLMO, X HAS BEEN SORTED INTO A C MONOTONIC NON-DECREASING SEQUENCE. C N - NUMBER OF OBSERVATIONS IN X C Z - OUTPUT VARIABLE CONTAINING THE GREATEST VALUE WITH C RESPECT TO X OF SQRT(N)*ABS(FN(X)-F(X)) WHERE C F(X) IS A THEORETICAL DISTRIBUTION FUNCTION AND C FN(X) AN EMPIRICAL DISTRIBUTION FUNCTION. C PROB - OUTPUT VARIABLE CONTAINING THE PROBABILITY OF C THE STATISTIC BEING GREATER THAN OR EQUAL TO Z IF C THE HYPOTHESIS THAT X IS FROM THE DENSITY UNDER C CONSIDERATION IS TRUE. E.G., PROB = 0.05 IMPLIES C THAT ONE CAN REJECT THE NULL HYPOTHESIS THAT THE SET C X IS FROM THE DENSITY UNDER CONSIDERATION WITH 5 PER C CENT PROBABILITY OF BEING INCORRECT. PROB = 1. - C SMIRN(Z). C IFCOD- A CODE DENOTING THE PARTICULAR THEORETICAL C PROBABILITY DISTRIBUTION FUNCTION BEING CONSIDERED. C = 1---F(X) IS THE NORMAL PDF. C = 2---F(X) IS THE EXPONENTIAL PDF. C = 3---F(X) IS THE CAUCHY PDF. C = 4---F(X) IS THE UNIFORM PDF. C = 5---F(X) IS USER SUPPLIED. C U - WHEN IFCOD IS 1 OR 2, U IS THE MEAN OF THE DENSITY C GIVEN ABOVE. C WHEN IFCOD IS 3, U IS THE MEDIAN OF THE CAUCHY C DENSITY. C WHEN IFCOD IS 4, U IS THE LEFT ENDPOINT OF THE C UNIFORM DENSITY. C WHEN IFCOD IS 5, U IS USER SPECIFIED. C S - WHEN IFCOD IS 1 OR 2, S IS THE STANDARD DEVIATION OF C DENSITY GIVEN ABOVE, AND SHOULD BE POSITIVE. C WHEN IFCOD IS 3, U - S SPECIFIES THE FIRST QUARTILE C OF THE CAUCHY DENSITY. S SHOULD BE NON-ZERO. C IF IFCOD IS 4, S IS THE RIGHT ENDPOINT OF THE UNIFORM C DENSITY. S SHOULD BE GREATER THAN U. C IF IFCOD IS 5, S IS USER SPECIFIED. C IER - ERROR INDICATOR WHICH IS NON-ZERO IF S VIOLATES ABOVE C CONVENTIONS. ON RETURN NO TEST HAS BEEN MADE, AND X C AND Y HAVE BEEN SORTED INTO MONOTONIC NON-DECREASING C SEQUENCES. IER IS SET TO ZERO ON ENTRY TO KOLMO. C IER IS CURRENTLY SET TO ONE IF THE USER-SUPPLIED PDF C IS REQUESTED FOR TESTING. THIS SHOULD BE CHANGED C (SEE REMARKS) WHEN SOME PDF IS SUPPLIED BY THE USER. C C REMARKS C N SHOULD BE GREATER THAN OR EQUAL TO 100. (SEE THE C MATHEMATICAL DESCRIPTION GIVEN FOR THE PROGRAM SMIRN, C CONCERNING ASYMPTOTIC FORMULAE) ALSO, PROBABILITY LEVELS C DETERMINED BY THIS PROGRAM WILL NOT BE CORRECT IF THE C SAME SAMPLES ARE USED TO ESTIMATE PARAMETERS FOR THE C CONTINUOUS DISTRIBUTIONS WHICH ARE USED IN THIS TEST. C (SEE THE MATHEMATICAL DESCRIPTION FOR THIS PROGRAM) C F(X) SHOULD BE A CONTINUOUS FUNCTION. C ANY USER SUPPLIED CUMULATIVE PROBABILITY DISTRIBUTION C FUNCTION SHOULD BE CODED BEGINNING WITH STATEMENT 26 BELOW, C AND SHOULD RETURN TO STATEMENT 27. C C DOUBLE PRECISION USAGE---IT IS DOUBTFUL THAT THE USER WILL C WISH TO PERFORM THIS TEST USING DOUBLE PRECISION ACCURACY. C IF ONE WISHES TO COMMUNICATE WITH KOLMO IN A DOUBLE C PRECISION PROGRAM, HE SHOULD CALL THE FORTRAN SUPPLIED C PROGRAM SNGL(X) PRIOR TO CALLING KOLMO, AND CALL THE C FORTRAN SUPPLIED PROGRAM DBLE(X) AFTER EXITING FROM KOLMO. C (NOTE THAT SUBROUTINE SMIRN DOES HAVE DOUBLE PRECISION C CAPABILITY AS SUPPLIED BY THIS PACKAGE.) C C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SMIRN, NDTR, AND ANY USER SUPPLIED SUBROUTINES REQUIRED. C C METHOD C FOR REFERENCE, SEE (1) W. FELLER--ON THE KOLMOGOROV-SMIRNOV C LIMIT THEOREMS FOR EMPIRICAL DISTRIBUTIONS-- C ANNALS OF MATH. STAT., 19, 1948. 177-189, C (2) N. SMIRNOV--TABLE FOR ESTIMATING THE GOODNESS OF FIT C OF EMPIRICAL DISTRIBUTIONS--ANNALS OF MATH. STAT., 19, C 1948. 279-281. C (3) R. VON MISES--MATHEMATICAL THEORY OF PROBABILITY AND C STATISTICS--ACADEMIC PRESS, NEW YORK, 1964. 490-493, C (4) B.V. GNEDENKO--THE THEORY OF PROBABILITY--CHELSEA C PUBLISHING COMPANY, NEW YORK, 1962. 384-401. C C .................................................................. C SUBROUTINE KOLMO(X,N,Z,PROB,IFCOD,U,S,IER) DIMENSION X(1) C C NON DECREASING ORDERING OF X(I)'S (DUBY METHOD) C IER=0 DO 5 I=2,N IF(X(I)-X(I-1))1,5,5 1 TEMP=X(I) IM=I-1 DO 3 J=1,IM L=I-J IF(TEMP-X(L))2,4,4 2 X(L+1)=X(L) 3 CONTINUE X(1)=TEMP GO TO 5 4 X(L+1)=TEMP 5 CONTINUE C C COMPUTES MAXIMUM DEVIATION DN IN ABSOLUTE VALUE BETWEEN C EMPIRICAL AND THEORETICAL DISTRIBUTIONS C NM1=N-1 XN=N DN=0.0 FS=0.0 IL=1 6 DO 7 I=IL,NM1 J=I IF(X(J)-X(J+1))9,7,9 7 CONTINUE 8 J=N 9 IL=J+1 FI=FS FS=FLOAT(J)/XN IF(IFCOD-2)10,13,17 10 IF(S)11,11,12 11 IER=1 GO TO 29 12 Z =(X(J)-U)/S CALL NDTR(Z,Y,D) GO TO 27 13 IF(S)11,11,14 14 Z=(X(J)-U)/S+1.0 IF(Z)15,15,16 15 Y=0.0 GO TO 27 16 Y=1.-EXP(-Z) GO TO 27 17 IF(IFCOD-4)18,20,26 18 IF(S)19,11,19 19 Y=ATAN((X(J)-U)/S)*0.3183099+0.5 GO TO 27 20 IF(S-U)11,11,21 21 IF(X(J)-U)22,22,23 22 Y=0.0 GO TO 27 23 IF(X(J)-S)25,25,24 24 Y=1.0 GO TO 27 25 Y=(X(J)-U)/(S-U) GO TO 27 26 IER=1 GO TO 29 27 EI=ABS(Y-FI) ES=ABS(Y-FS) DN=AMAX1(DN,EI,ES) IF(IL-N)6,8,28 C C COMPUTES Z=DN*SQRT(N) AND PROBABILITY C 28 Z=DN*SQRT(XN) CALL SMIRN(Z,PROB) PROB=1.0-PROB 29 RETURN END C C .................................................................. C C SUBROUTINE KRANK C C PURPOSE C TEST CORRELATION BETWEEN TWO VARIABLES BY MEANS OF KENDALL C RANK CORRELATION COEFFICIENT C C USAGE C CALL KRANK(A,B,R,N,TAU,SD,Z,NR) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF N OBSERVATIONS FOR FIRST VARIABLE C B - INPUT VECTOR OF N OBSERVATIONS FOR SECOND VARIABLE C R - OUTPUT VECTOR OF RANKED DATA OF LENGTH 2*N. SMALLEST C OBSERVATION IS RANKED 1, LARGEST IS RANKED N. TIES C ARE ASSIGNED AVERAGE OF TIED RANKS. C N - NUMBER OF OBSERVATIONS C TAU - KENDALL RANK CORRELATION COEFFICIENT (OUTPUT) C SD - STANDARD DEVIATION (OUTPUT) C Z - TEST OF SIGNIFICANCE OF TAU IN TERMS OF NORMAL C DISTRIBUTION (OUTPUT) C NR - CODE, 0 FOR UNRANKED DATA IN A AND B, 1 FOR RANKED C DATA IN A AND B (INPUT) C C REMARKS C SD AND Z ARE SET TO ZERO IF N IS LESS THAN TEN C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANK C TIE C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 9 C C .................................................................. C SUBROUTINE KRANK(A,B,R,N,TAU,SD,Z,NR) DIMENSION A(1),B(1),R(1) C SD=0.0 Z=0.0 FN=N FN1=N*(N-1) C C DETERMINE WHETHER DATA IS RANKED C IF(NR-1) 5, 10, 5 C C RANK DATA IN A AND B VECTORS AND ASSIGN TIED OBSERVATIONS C AVERAGE OF TIED RANKS C 5 CALL RANK (A,R,N) CALL RANK (B,R(N+1),N) GO TO 40 C C MOVE RANKED DATA TO R VECTOR C 10 DO 20 I=1,N 20 R(I)=A(I) DO 30 I=1,N J=I+N 30 R(J)=B(I) C C SORT RANK VECTOR R IN SEQUENCE OF VARIABLE A C 40 ISORT=0 DO 50 I=2,N IF(R(I)-R(I-1)) 45,50,50 45 ISORT=ISORT+1 RSAVE=R(I) R(I)=R(I-1) R(I-1)=RSAVE I2=I+N SAVER=R(I2) R(I2)=R(I2-1) R(I2-1)=SAVER 50 CONTINUE IF(ISORT) 40,55,40 C C COMPUTE S ON VARIABLE B. STARTING WITH THE FIRST RANK, ADD 1 C TO S FOR EACH LARGER RANK TO ITS RIGHT AND SUBTRACT 1 FOR EACH C SMALLER RANK. REPEAT FOR ALL RANKS. C 55 S=0.0 NM=N-1 DO 60 I=1,NM J=N+I DO 60 L=I,N K=N+L IF(R(I)-R(L))58,60,58 58 IF(R(K)-R(J)) 56,60,57 56 S=S-1.0 GO TO 60 57 S=S+1.0 60 CONTINUE C C COMPUTE TIED SCORE INDEX FOR BOTH VARIABLES C KT=2 CALL TIE(R,N,KT,TA) CALL TIE(R(N+1),N,KT,TB) C C COMPUTE TAU C IF(TA) 70,65,70 65 IF(TB) 70,67,70 67 TAU=S/(0.5*FN1) GO TO 80 70 TAU=S/((SQRT(0.5*FN1-TA))*(SQRT(0.5*FN1-TB))) C C COMPUTE STANDARD DEVIATION AND Z IF N IS 10 OR LARGER C 80 IF(N-10) 90,85,85 85 SD=(SQRT((2.0*(FN+FN+5.0))/(9.0*FN1))) Z=TAU/SD 90 RETURN END C C .................................................................. C C SUBROUTINE LAP C C PURPOSE C COMPUTE THE VALUES OF THE LAGUERRE POLYNOMIALS L(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL LAP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF LAGUERRE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF LAGUERRE POLYNOMIAL C N - ORDER OF LAGUERRE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C LAGUERRE POLYNOMIALS L(N,X) C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE L(0,X)=1, L(1,X)=1.-X. C C .................................................................. C SUBROUTINE LAP(Y,X,N) C DIMENSION Y(1) C C TEST OF ORDER Y(1)=1. IF(N)1,1,2 1 RETURN C 2 Y(2)=1.-X IF(N-1)1,1,3 C C INITIALIZATION 3 T=1.+X C DO 4 I=2,N 4 Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/FLOAT(I) RETURN END C C .................................................................. C C SUBROUTINE LAPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LAGUERRE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL LAPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C X - ARGUMENT VALUE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR LAGUERRE POLYNOMIALS C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1). C C .................................................................. C SUBROUTINE LAPS(Y,X,C,N) C DIMENSION C(1) C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1. H1=1.-X T=1.+X C DO 4 I=2,N H2=H1-H0+H1-(T*H1-H0)/FLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE LBVP C C PURPOSE C TO SOLVE A LINEAR BOUNDARY VALUE PROBLEM, WHICH CONSISTS OF C A SYSTEM OF NDIM LINEAR FIRST ORDER DIFFERENTIAL EQUATIONS C DY/DX=A(X)*Y(X)+F(X) C AND NDIM LINEAR BOUNDARY CONDITIONS C B*Y(XL)+C*Y(XU)=R. C C USAGE C CALL LBVP (PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, C AUX,A) C PARAMETERS AFCT,FCT,DFCT,OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER C OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF C THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR C COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED C BY THE USER) AND SUBROUTINE LBVP. C THE COMPONENTS ARE C PRMT(1)- LOWER BOUND XL OF THE INTERVAL (INPUT), C PRMT(1)- UPPER BOUND XU OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF RELATIVE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND RELATIVE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE LBVP INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE LBVP AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE LBVP DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING LBVP) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C B - AN NDIM BY NDIM INPUT MATRIX. (DESTROYED) C IT IS THE COEFFICIENT MATRIX OF Y(XL) IN C THE BOUNDARY CONDITIONS. C C - AN NDIM BY NDIM INPUT MATRIX (POSSIBLY DESTROYED). C IT IS THE COEFFICIENT MATRIX OF Y(XU) IN C THE BOUNDARY CONDITIONS. C R - AN INPUT VECTOR WITH DIMENSION NDIM. (DESTROYED) C IT SPECIFIES THE RIGHT HAND SIDE OF THE C BOUNDARY CONDITIONS. C Y - AN AUXILIARY VECTOR WITH DIMENSION NDIM. C IT IS USED AS STORAGE LOCATION FOR THE RESULTING C VALUES OF DEPENDENT VARIABLES COMPUTED AT C INTERMEDIATE POINTS. C DERY - INPUT VECTOR OF ERROR WEIGHTS. (DESTROYED) C ITS MAXIMAL COMPONENT SHOULD BE EQUAL TO 1. C LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH C BELONG TO FUNCTION VALUES Y AT INTERMEDIATE POINTS. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C DIFFERENTIAL EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE LBVP RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. FINALLY ERROR MESSAGE C IHLF=14 INDICATES, THAT THERE IS NO SOLUTION OR C THAT THERE ARE MORE THAN ONE SOLUTION OF THE C PROBLEM. C A NEGATIVE VALUE OF IHLF HANDED TO SUBROUTINE OUTP C TOGETHER WITH INITIAL VALUES OF FINALLY GENERATED C INITIAL VALUE PROBLEM INDICATES, THAT THERE WAS C POSSIBLE LOSS OF SIGNIFICANCE IN THE SOLUTION OF C THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS FOR C THESE INITIAL VALUES. THE ABSOLUTE VALUE OF IHLF C SHOWS, AFTER WHICH ELIMINATION STEP OF GAUSS C ALGORITHM POSSIBLE LOSS OF SIGNIFICANCE WAS C DETECTED. C AFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES THE COEFFICIENT MATRIX A OF VECTOR Y ON C THE RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS FOR A GIVEN X-VALUE. ITS PARAMETER LIST C MUST BE X,A. SUBROUTINE AFCT SHOULD NOT DESTROY X. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR F (INHOMOGENEOUS PART OF THE C RIGHT HAND SIDE OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS) FOR A GIVEN X-VALUE. ITS PARAMETER LIST C MUST BE X,F. SUBROUTINE FCT SHOULD NOT DESTROY X. C DFCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES VECTOR DF (DERIVATIVE OF THE INHOMOGENEOUS C PART ON THE RIGHT HAND SIDE OF THE SYSTEM OF C DIFFERENTIAL EQUATIONS) FOR A GIVEN X-VALUE. ITS C PARAMETER LIST MUST BE X,DF. SUBROUTINE DFCT C SHOULD NOT DESTROY X. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE LBVP IS TERMINATED. C AUX - AN AUXILIARY STORAGE ARRAY WIRH 20 ROWS AND C NDIM COLUMNS. C A - AN NDIM BY NDIM MATRIX, WHICH IS USED AS AUXILIARY C STORAGE ARRAY. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR IF IT HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THERE IS NO OR MORE THAN ONE SOLUTION OF THE PROBLEM C (ERROR MESSAGE IHLF=14), C (4) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (5) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SUBROUTINE GELG SYSTEM OF LINEAR EQUATIONS. C THE EXTERNAL SUBROUTINES AFCT(X,A), FCT(X,F), DFCT(X,DF), C AND OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE USING THE METHOD OF ADJOINT EQUATIONS. C HAMMINGS FOURTH ORDER MODIFIED PREDICTOR-CORRECTOR METHOD C IS USED TO SOLVE THE ADJOINT INITIAL VALUE PROBLEMS AND FI- C NALLY TO SOLVE THE GENERATED INITIAL VALUE PROBLEM FOR Y(X). C THE INITIAL INCREMENT PRMT(3) IS AUTOMATICALLY ADJUSTED. C FOR COMPUTATION OF INTEGRAL SUM, A FOURTH ORDER HERMITEAN C INTEGRATION FORMULA IS USED. C FOR REFERENCE, SEE C (1) LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS, C ILIFFE, LONDON, 1960, PP.64-67. C (2) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (3) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C (4) ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-232. C C .................................................................. C SUBROUTINE LBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, 1AUX,A) C DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1) C C ERROR TEST IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3 1 IHLF=12 RETURN 2 IHLF=13 RETURN C C SEARCH FOR ZERO-COLUMNS IN MATRICES B AND C 3 KK=-NDIM IB=0 IC=0 DO 7 K=1,NDIM AUX(15,K)=DERY(K) AUX(1,K)=1. AUX(17,K)=1. KK=KK+NDIM DO 4 I=1,NDIM II=KK+I IF(B(II))5,4,5 4 CONTINUE IB=IB+1 AUX(1,K)=0. 5 DO 6 I=1,NDIM II=KK+I IF(C(II))7,6,7 6 CONTINUE IC=IC+1 AUX(17,K)=0. 7 CONTINUE C C DETERMINATION OF LOWER AND UPPER BOUND IF(IC-IB)8,11,11 8 H=PRMT(2) PRMT(2)=PRMT(1) PRMT(1)=H PRMT(3)=-PRMT(3) DO 9 I=1,NDIM 9 AUX(17,I)=AUX(1,I) II=NDIM*NDIM DO 10 I=1,II H=B(I) B(I)=C(I) 10 C(I)=H C C PREPARATIONS FOR CONSTRUCTION OF ADJOINT INITIAL VALUE PROBLEMS 11 X=PRMT(2) CALL FCT(X,Y) CALL DFCT(X,DERY) DO 12 I=1,NDIM AUX(18,I)=Y(I) 12 AUX(19,I)=DERY(I) C C POSSIBLE BREAK-POINT FOR LINKAGE C C THE FOLLOWING PART OF SUBROUTINE LBVP UNTIL NEXT BREAK-POINT FOR C LINKAGE HAS TO REMAIN IN CORE DURING THE WHOLE REST OF THE C COMPUTATIONS C C START LOOP FOR GENERATING ADJOINT INITIAL VALUE PROBLEMS K=0 KK=0 100 K=K+1 IF(AUX(17,K))108,108,101 C C INITIALIZATION OF ADJOINT INITIAL VALUE PROBLEM 101 X=PRMT(2) CALL AFCT(X,A) SUM=0. GL=AUX(18,K) DGL=AUX(19,K) II=K DO 104 I=1,NDIM H=-A(II) DERY(I)=H AUX(20,I)=R(I) Y(I)=0. IF(I-K)103,102,103 102 Y(I)=1. 103 DGL=DGL+H*AUX(18,I) 104 II=II+NDIM XEND=PRMT(1) H=.0625*(XEND-X) ISW=0 GOTO 400 C THIS IS BRANCH TO ADJOINT LINEAR INITIAL VALUE PROBLEM C C THIS IS RETURN FROM ADJOINT LINEAR INITIAL VALUE PROBLEM 105 IF(IHLF-10)106,106,117 C C UPDATING OF COEFFICIENT MATRIX B AND VECTOR R 106 DO 107 I=1,NDIM KK=KK+1 H=C(KK) R(I)=AUX(20,I)+H*SUM II=I DO 107 J=1,NDIM B(II)=B(II)+H*Y(J) 107 II=II+NDIM GOTO 109 108 KK=KK+NDIM 109 IF(K-NDIM)100,110,110 C C GENERATION OF LAST INITIAL VALUE PROBLEM 110 X=PRMT(4) CALL GELG(R,B,NDIM,1,X,I) IF(I)111,112,112 111 IHLF=14 RETURN C 112 PRMT(5)=0. IHLF=-I X=PRMT(1) XEND=PRMT(2) H=PRMT(3) DO 113 I=1,NDIM 113 Y(I)=R(I) ISW=1 114 ISW2=12 GOTO 200 115 ISW3=-1 GOTO 300 116 IF(IHLF)400,400,117 C THIS WAS BRANCH INTO INITIAL VALUE PROBLEM C C THIS IS RETURN FROM INITIAL VALUE PROBLEM 117 RETURN C C THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE RIGHT C HAND SIDE DERY OF THE SYSTEM OF ADJOINT LINEAR DIFFERENTIAL C EQUATIONS (IN CASE ISW=0) OR OF THE GIVEN SYSTEM (IN CASE ISW=1). 200 CALL AFCT(X,A) IF(ISW)201,201,205 C C ADJOINT SYSTEM 201 LL=0 DO 203 M=1,NDIM HS=0. DO 202 L=1,NDIM LL=LL+1 202 HS=HS-A(LL)*Y(L) 203 DERY(M)=HS 204 GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2 C C GIVEN SYSTEM 205 CALL FCT(X,DERY) DO 207 M=1,NDIM LL=M-NDIM HS=0. DO 206 L=1,NDIM LL=LL+NDIM 206 HS=HS+A(LL)*Y(L) 207 DERY(M)=HS+DERY(M) GOTO 204 C C THIS PART OF LINEAR BOUNDARY VALUE PROBLEM COMPUTES THE VALUE OF C INTEGRAL SUM, WHICH IS A PART OF THE OUTPUT OF ADJOINT INITIAL C VALUE PROBLEM (IN CASE ISW=0) OR RECORDS RESULT VALUES OF THE C FINAL INITIAL VALUE PROBLEM (IN CASE ISW=1). 300 IF(ISW)301,301,305 C C ADJOINT PROBLEM 301 CALL FCT(X,R) GU=0. DGU=0. DO 302 L=1,NDIM GU=GU+Y(L)*R(L) 302 DGU=DGU+DERY(L)*R(L) CALL DFCT(X,R) DO 303 L=1,NDIM 303 DGU=DGU+Y(L)*R(L) SUM=SUM+.5*H*((GL+GU)+.1666667*H*(DGL-DGU)) GL=GU DGL=DGU 304 IF(ISW3)116,422,618 C C GIVEN PROBLEM 305 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))117,304,117 C C POSSIBLE BREAK-POINT FOR LINKAGE C C THE FOLLOWING PART OF SUBROUTINE LBVP SOLVES IN CASE ISW=0 THE C ADJOINT INITIAL VALUE PROBLEM. IT COMPUTES INTEGRAL SUM AND C THE VECTOR Y OF DEPENDENT VARIABLES AT THE LOWER BOUND PRMT(1). C IN CASE ISW=1 IT SOLVES FINALLY GENERATED INITIAL VALUE PROBLEM. 400 N=1 XST=X IHLF=0 DO 401 I=1,NDIM AUX(16,I)=0. AUX(1,I)=Y(I) 401 AUX(8,I)=DERY(I) ISW1=1 GOTO 500 C 402 X=X+H DO 403 I=1,NDIM 403 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 404 IHLF=IHLF+1 X=X-H DO 405 I=1,NDIM 405 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW1=2 GOTO 500 C 406 X=X+H ISW2=4 GOTO 200 407 N=2 DO 408 I=1,NDIM AUX(2,I)=Y(I) 408 AUX(9,I)=DERY(I) ISW1=3 GOTO 500 C C TEST ON SATISFACTORY ACCURACY 409 DO 414 I=1,NDIM Z=ABS(Y(I)) IF(Z-1.)410,411,411 410 Z=1. 411 DELT=.06666667*ABS(Y(I)-AUX(4,I)) IF(ISW)413,413,412 412 DELT=AUX(15,I)*DELT 413 IF(DELT-Z*PRMT(4))414,414,429 414 CONTINUE C C SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS X=X+H ISW2=5 GOTO 200 415 DO 416 I=1,NDIM AUX(3,I)=Y(I) 416 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 500 C 417 N=1 X=X+H ISW2=6 GOTO 200 418 X=XST DO 419 I=1,NDIM AUX(11,I)=DERY(I) 419 Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 420 X=X+H N=N+1 ISW2=11 GOTO 200 421 ISW3=0 GOTO 300 422 IF(N-4)423,600,600 423 DO 424 I=1,NDIM AUX(N,I)=Y(I) 424 AUX(N+7,I)=DERY(I) IF(N-3)425,427,600 C 425 DO 426 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 426 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 420 C 427 DO 428 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 428 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 420 C C NO SATISFACTORY ACCURACY. H MUST BE HALVED. 429 IF(IHLF-10)404,430,430 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 430 IHLF=11 X=X+H IF(ISW)105,105,114 C C THIS PART OF LINEAR INITIAL VALUE PROBLEM COMPUTES C STARTING VALUES BY MEANS OF RUNGE-KUTTA METHOD. 500 Z=X DO 501 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 501 Y(I)=AUX(N,I)+.4*X C X=Z+.4*H ISW2=1 GOTO 200 502 DO 503 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 503 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X C X=Z+.4557372*H ISW2=2 GOTO 200 504 DO 505 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 505 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X C X=Z+H ISW2=3 GOTO 200 506 DO 507 I=1,NDIM 507 Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) X=Z GOTO(402,406,409,417),ISW1 C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 600 ISTEP=3 601 IF(N-8)604,602,604 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 602 DO 603 N=2,7 DO 603 I=1,NDIM AUX(N-1,I)=AUX(N,I) 603 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 604 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 605 I=1,NDIM AUX(N-1,I)=Y(I) 605 AUX(N+6,I)=DERY(I) X=X+H 606 ISTEP=ISTEP+1 DO 607 I=1,NDIM DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 607 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. C ISW2=7 GOTO 200 C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY. C 608 DO 609 I=1,NDIM DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 609 Y(I)=DELT+.07438017*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0. DO 616 I=1,NDIM Z=ABS(Y(I)) IF(Z-1.)610,611,611 610 Z=1. 611 Z=ABS(AUX(16,I))/Z IF(ISW)613,613,612 612 Z=AUX(15,I)*Z 613 IF(Z-PRMT(4))614,614,628 614 IF(DELT-Z)615,616,616 615 DELT=Z 616 CONTINUE C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. ISW2=8 GOTO 200 617 ISW3=1 GOTO 300 618 IF(H*(X-XEND))619,621,621 619 IF(ABS(X-XEND)-.1*ABS(H))621,620,620 620 IF(DELT-.02*PRMT(4))622,622,601 621 IF(ISW)105,105,117 C C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE. 622 IF(IHLF)601,601,623 623 IF(N-7)601,624,624 624 IF(ISTEP-4)601,625,625 625 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)601,626,601 626 H=H+H IHLF=IHLF-1 ISTEP=0 DO 627 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 627 AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 601 C C C H MUST BE HALVED 628 IHLF=IHLF+1 IF(IHLF-10)630,630,629 629 IF(ISW)105,105,114 630 H=.5*H ISTEP=0 DO 631 I=1,NDIM Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 631 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=9 GOTO 200 632 DO 633 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 633 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=10 GOTO 200 634 X=DELT DO 635 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 635 AUX(N+3,I)=DERY(I) GOTO 606 C C END OF INITIAL VALUE PROBLEM END C C .................................................................. C C SUBROUTINE LEP C C PURPOSE C COMPUTE THE VALUES OF THE LEGENDRE POLYNOMIALS P(N,X) C FOR ARGUMENT VALUE X AND ORDERS 0 UP TO N. C C USAGE C CALL LEP(Y,X,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VECTOR OF DIMENSION N+1 CONTAINING THE VALUES C OF LEGENDRE POLYNOMIALS OF ORDER 0 UP TO N C FOR GIVEN ARGUMENT X. C VALUES ARE ORDERED FROM LOW TO HIGH ORDER C X - ARGUMENT OF LEGENDRE POLYNOMIAL C N - ORDER OF LEGENDRE POLYNOMIAL C C REMARKS C N LESS THAN 0 IS TREATED AS IF N WERE 0 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS BASED ON THE RECURRENCE EQUATION FOR C LEGENDRE POLYNOMIALS P(N,X) C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE ORDER, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE P(0,X)=1, P(1,X)=X. C C .................................................................. C SUBROUTINE LEP(Y,X,N) C DIMENSION Y(1) C C TEST OF ORDER Y(1)=1. IF(N)1,1,2 1 RETURN C 2 Y(2)=X IF(N-1)1,1,3 C 3 DO 4 I=2,N G=X*Y(I) 4 Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/FLOAT(I) RETURN END C C .................................................................. C C SUBROUTINE LEPS C C PURPOSE C COMPUTES THE VALUE OF AN N-TERM EXPANSION IN LEGENDRE C POLYNOMIALS WITH COEFFICIENT VECTOR C FOR ARGUMENT VALUE X. C C USAGE C CALL LEPS(Y,X,C,N) C C DESCRIPTION OF PARAMETERS C Y - RESULT VALUE C X - ARGUMENT VALUE C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR C C C REMARKS C OPERATION IS BYPASSED IN CASE N LESS THAN 1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C Y=SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N). C EVALUATION IS DONE BY MEANS OF UPWARD RECURSION C USING THE RECURRENCE EQUATION FOR LEGENDRE POLYNOMIALS C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1). C C .................................................................. C SUBROUTINE LEPS(Y,X,C,N) C DIMENSION C(1) C C TEST OF DIMENSION IF(N)1,1,2 1 RETURN C 2 Y=C(1) IF(N-2)1,3,3 C C INITIALIZATION 3 H0=1. H1=X C DO 4 I=2,N H2=X*H1 H2=H2-H0+H2-(H2-H0)/FLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END C C .................................................................. C C SUBROUTINE LLSQ C C PURPOSE C TO SOLVE LINEAR LEAST SQUARES PROBLEMS, I.E. TO MINIMIZE C THE EUCLIDEAN NORM OF B-A*X, WHERE A IS A M BY N MATRIX C WITH M NOT LESS THAN N. IN THE SPECIAL CASE M=N SYSTEMS OF C LINEAR EQUATIONS MAY BE SOLVED. C C USAGE C CALL LLSQ (A,B,M,N,L,X,IPIV,EPS,IER,AUX) C C DESCRIPTION OF PARAMETERS C A - M BY N COEFFICIENT MATRIX (DESTROYED). C B - M BY L RIGHT HAND SIDE MATRIX (DESTROYED). C M - ROW NUMBER OF MATRICES A AND B. C N - COLUMN NUMBER OF MATRIX A, ROW NUMBER OF MATRIX X. C L - COLUMN NUMBER OF MATRICES B AND X. C X - N BY L SOLUTION MATRIX. C IPIV - INTEGER OUTPUT VECTOR OF DIMENSION N WHICH C CONTAINS INFORMATIONS ON COLUMN INTERCHANGES C IN MATRIX A. (SEE REMARK NO.3). C EPS - INPUT PARAMETER WHICH SPECIFIES A RELATIVE C TOLERANCE FOR DETERMINATION OF RANK OF MATRIX A. C IER - A RESULTING ERROR PARAMETER. C AUX - AUXILIARY STORAGE ARRAY OF DIMENSION MAX(2*N,L). C ON RETURN FIRST L LOCATIONS OF AUX CONTAIN THE C RESULTING LEAST SQUARES. C C REMARKS C (1) NO ACTION BESIDES ERROR MESSAGE IER=-2 IN CASE C M LESS THAN N. C (2) NO ACTION BESIDES ERROR MESSAGE IER=-1 IN CASE C OF A ZERO-MATRIX A. C (3) IF RANK K OF MATRIX A IS FOUND TO BE LESS THAN N BUT C GREATER THAN 0, THE PROCEDURE RETURNS WITH ERROR CODE C IER=K INTO CALLING PROGRAM. THE LAST N-K ELEMENTS OF C VECTOR IPIV DENOTE THE USELESS COLUMNS IN MATRIX A. C THE REMAINING USEFUL COLUMNS FORM A BASE OF MATRIX A. C (4) IF THE PROCEDURE WAS SUCCESSFUL, ERROR PARAMETER IER C IS SET TO 0. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C HOUSEHOLDER TRANSFORMATIONS ARE USED TO TRANSFORM MATRIX A C TO UPPER TRIANGULAR FORM. AFTER HAVING APPLIED THE SAME C TRANSFORMATION TO THE RIGHT HAND SIDE MATRIX B, AN C APPROXIMATE SOLUTION OF THE PROBLEM IS COMPUTED BY C BACK SUBSTITUTION. FOR REFERENCE, SEE C G. GOLUB, NUMERICAL METHODS FOR SOLVING LINEAR LEAST C SQUARES PROBLEMS, NUMERISCHE MATHEMATIK, VOL.7, C ISS.3 (1965), PP.206-216. C C .................................................................. C SUBROUTINE LLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX) C DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1) C C ERROR TEST IF(M-N)30,1,1 C C GENERATION OF INITIAL VECTOR S(K) (K=1,2,...,N) IN STORAGE C LOCATIONS AUX(K) (K=1,2,...,N) 1 PIV=0. IEND=0 DO 4 K=1,N IPIV(K)=K H=0. IST=IEND+1 IEND=IEND+M DO 2 I=IST,IEND 2 H=H+A(I)*A(I) AUX(K)=H IF(H-PIV)4,4,3 3 PIV=H KPIV=K 4 CONTINUE C C ERROR TEST IF(PIV)31,31,5 C C DEFINE TOLERANCE FOR CHECKING RANK OF A 5 SIG=SQRT(PIV) TOL=SIG*ABS(EPS) C C C DECOMPOSITION LOOP LM=L*M IST=-M DO 21 K=1,N IST=IST+M+1 IEND=IST+M-K I=KPIV-K IF(I)8,8,6 C C INTERCHANGE K-TH COLUMN OF A WITH KPIV-TH IN CASE KPIV.GT.K 6 H=AUX(K) AUX(K)=AUX(KPIV) AUX(KPIV)=H ID=I*M DO 7 I=IST,IEND J=I+ID H=A(I) A(I)=A(J) 7 A(J)=H C C COMPUTATION OF PARAMETER SIG 8 IF(K-1)11,11,9 9 SIG=0. DO 10 I=IST,IEND 10 SIG=SIG+A(I)*A(I) SIG=SQRT(SIG) C C TEST ON SINGULARITY IF(SIG-TOL)32,32,11 C C GENERATE CORRECT SIGN OF PARAMETER SIG 11 H=A(IST) IF(H)12,13,13 12 SIG=-SIG C C SAVE INTERCHANGE INFORMATION 13 IPIV(KPIV)=IPIV(K) IPIV(K)=KPIV C C GENERATION OF VECTOR UK IN K-TH COLUMN OF MATRIX A AND OF C PARAMETER BETA BETA=H+SIG A(IST)=BETA BETA=1./(SIG*BETA) J=N+K AUX(J)=-SIG IF(K-N)14,19,19 C C TRANSFORMATION OF MATRIX A 14 PIV=0. ID=0 JST=K+1 KPIV=JST DO 18 J=JST,N ID=ID+M H=0. DO 15 I=IST,IEND II=I+ID 15 H=H+A(I)*A(II) H=BETA*H DO 16 I=IST,IEND II=I+ID 16 A(II)=A(II)-A(I)*H C C UPDATING OF ELEMENT S(J) STORED IN LOCATION AUX(J) II=IST+ID H=AUX(J)-A(II)*A(II) AUX(J)=H IF(H-PIV)18,18,17 17 PIV=H KPIV=J 18 CONTINUE C C TRANSFORMATION OF RIGHT HAND SIDE MATRIX B 19 DO 21 J=K,LM,M H=0. IEND=J+M-K II=IST DO 20 I=J,IEND H=H+A(II)*B(I) 20 II=II+1 H=BETA*H II=IST DO 21 I=J,IEND B(I)=B(I)-A(II)*H 21 II=II+1 C END OF DECOMPOSITION LOOP C C C BACK SUBSTITUTION AND BACK INTERCHANGE IER=0 I=N LN=L*N PIV=1./AUX(2*N) DO 22 K=N,LN,N X(K)=PIV*B(I) 22 I=I+M IF(N-1)26,26,23 23 JST=(N-1)*M+N DO 25 J=2,N JST=JST-M-1 K=N+N+1-J PIV=1./AUX(K) KST=K-N ID=IPIV(KST)-KST IST=2-J DO 25 K=1,L H=B(KST) IST=IST+N IEND=IST+J-2 II=JST DO 24 I=IST,IEND II=II+M 24 H=H-A(II)*X(I) I=IST-1 II=I+ID X(I)=X(II) X(II)=PIV*H 25 KST=KST+M C C C COMPUTATION OF LEAST SQUARES 26 IST=N+1 IEND=0 DO 29 J=1,L IEND=IEND+M H=0. IF(M-N)29,29,27 27 DO 28 I=IST,IEND 28 H=H+B(I)*B(I) IST=IST+M 29 AUX(J)=H RETURN C C ERROR RETURN IN CASE M LESS THAN N 30 IER=-2 RETURN C C ERROR RETURN IN CASE OF ZERO-MATRIX A 31 IER=-1 RETURN C C ERROR RETURN IN CASE OF RANK OF MATRIX A LESS THAN N 32 IER=K-1 RETURN END C C .................................................................. C C SUBROUTINE LOAD C C PURPOSE C COMPUTE A FACTOR MATRIX (LOADING) FROM EIGENVALUES AND C ASSOCIATED EIGENVECTORS. THIS SUBROUTINE NORMALLY OCCURS C IN A SEQUENCE OF CALLS TO SUBROUTINES CORRE, EIGEN, TRACE, C LOAD, AND VARMX IN THE PERFORMANCE OF A FACTOR ANALYSIS. C C USAGE C CALL LOAD (M,K,R,V) C C DESCRIPTION OF PARAMETERS C M - NUMBER OF VARIABLES. C K - NUMBER OF FACTORS. K MUST BE GREATER THAN OR EQUAL C TO 1 AND LESS THAN OR EQUAL TO M. C R - A MATRIX (SYMMETRIC AND STORED IN COMPRESSED FORM C WITH ONLY UPPER TRIANGLE BY COLUMN IN CORE) CON- C TAINING EIGENVALUES IN DIAGONAL. EIGENVALUES ARE C ARRANGED IN DESCENDING ORDER, AND FIRST K C EIGENVALUES ARE USED BY THIS SUBROUTINE. THE ORDER C OF MATRIX R IS M BY M. ONLY M*(M+1)/2 ELEMENTS ARE C IN STORAGE. (STORAGE MODE OF 1) C V - WHEN THIS SUBROUTINE IS CALLED, MATRIX V (M X M) C CONTAINS EIGENVECTORS COLUMNWISE. UPON RETURNING TO C THE CALLING PROGRAM, MATRIX V CONTAINS A FACTOR C MATRIX (M X K). C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C NORMALIZED EIGENVECTORS ARE CONVERTED TO THE FACTOR PATTERN C BY MULTIPLYING THE ELEMENTS OF EACH VECTOR BY THE SQUARE C ROOT OF THE CORRESPONDING EIGENVALUE. C C .................................................................. C SUBROUTINE LOAD (M,K,R,V) DIMENSION R(1),V(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION R,V,SQ C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENT C 150 MUST BE CHANGED TO DSQRT. C C ............................................................... C L=0 JJ=0 DO 160 J=1,K JJ=JJ+J 150 SQ= SQRT(R(JJ)) DO 160 I=1,M L=L+1 160 V(L)=SQ*V(L) RETURN END C C .................................................................. C C SUBROUTINE LOC C C PURPOSE C COMPUTE A VECTOR SUBSCRIPT FOR AN ELEMENT IN A MATRIX OF C SPECIFIED STORAGE MODE C C USAGE C CALL LOC (I,J,IR,N,M,MS) C C DESCRIPTION OF PARAMETERS C I - ROW NUMBER OF ELEMENT C J - COLUMN NUMBER OF ELEMENT C IR - RESULTANT VECTOR SUBSCRIPT C N - NUMBER OF ROWS IN MATRIX C M - NUMBER OF COLUMNS IN MATRIX C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C MS=0 SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N*M ELEMENTS C IN STORAGE (GENERAL MATRIX) C MS=1 SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N*(N+1)/2 IN C STORAGE (UPPER TRIANGLE OF SYMMETRIC MATRIX). IF C ELEMENT IS IN LOWER TRIANGULAR PORTION, SUBSCRIPT IS C CORRESPONDING ELEMENT IN UPPER TRIANGLE. C MS=2 SUBSCRIPT IS COMPUTED FOR A MATRIX WITH N ELEMENTS C IN STORAGE (DIAGONAL ELEMENTS OF DIAGONAL MATRIX). C IF ELEMENT IS NOT ON DIAGONAL (AND THEREFORE NOT IN C STORAGE), IR IS SET TO ZERO. C C .................................................................. C SUBROUTINE LOC(I,J,IR,N,M,MS) C IX=I JX=J IF(MS-1) 10,20,30 10 IRX=N*(JX-1)+IX GO TO 36 20 IF(IX-JX) 22,24,24 22 IRX=IX+(JX*JX-JX)/2 GO TO 36 24 IRX=JX+(IX*IX-IX)/2 GO TO 36 30 IRX=0 IF(IX-JX) 36,32,36 32 IRX=IX 36 IR=IRX RETURN END C C .................................................................. C C SUBROUTINE MADD C C PURPOSE C ADD TWO MATRICES ELEMENT BY ELEMENT TO FORM RESULTANT C MATRIX C C USAGE C CALL MADD(A,B,R,N,M,MSA,MSB) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C B - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A,B,R C M - NUMBER OF COLUMNS IN A,B,R C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C STORAGE MODE OF OUTPUT MATRIX IS FIRST DETERMINED. ADDITION C OF CORRESPONDING ELEMENTS IS THEN PERFORMED. C THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT C MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES C A B R C GENERAL GENERAL GENERAL C GENERAL SYMMETRIC GENERAL C GENERAL DIAGONAL GENERAL C SYMMETRIC GENERAL GENERAL C SYMMETRIC SYMMETRIC SYMMETRIC C SYMMETRIC DIAGONAL SYMMETRIC C DIAGONAL GENERAL GENERAL C DIAGONAL SYMMETRIC SYMMETRIC C DIAGONAL DIAGONAL DIAGONAL C C .................................................................. C SUBROUTINE MADD(A,B,R,N,M,MSA,MSB) DIMENSION A(1),B(1),R(1) C C DETERMINE STORAGE MODE OF OUTPUT MATRIX C IF(MSA-MSB) 7,5,7 5 CALL LOC(N,M,NM,N,M,MSA) GO TO 100 7 MTEST=MSA*MSB MSR=0 IF(MTEST) 20,20,10 10 MSR=1 20 IF(MTEST-2) 35,35,30 30 MSR=2 C C LOCATE ELEMENTS AND PERFORM ADDITION C 35 DO 90 J=1,M DO 90 I=1,N CALL LOC(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL LOC(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL LOC(I,J,IJB,N,M,MSB) BEL=0.0 IF(IJB) 70,80,70 70 BEL=B(IJB) 80 R(IJR)=AEL+BEL 90 CONTINUE RETURN C C ADD MATRICES FOR OTHER CASES C 100 DO 110 I=1,NM 110 R(I)=A(I)+B(I) RETURN END C C .................................................................. C C SUBROUTINE MATA C C PURPOSE C PREMULTIPLY A MATRIX BY ITS TRANSPOSE TO FORM A C SYMMETRIC MATRIX C C USAGE C CALL MATA(A,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A. ALSO NUMBER OF ROWS AND C NUMBER OF COLUMNS OF R. C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R IS ALWAYS A SYMMETRIC MATRIX WITH A STORAGE MODE=1 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C CALCULATION OF (A TRANSPOSE A) RESULTS IN A SYMMETRIC MATRIX C REGARDLESS OF THE STORAGE MODE OF THE INPUT MATRIX. THE C ELEMENTS OF MATRIX A ARE NOT CHANGED. C C .................................................................. C SUBROUTINE MATA(A,R,N,M,MS) DIMENSION A(1),R(1) C DO 60 K=1,M KX=(K*K-K)/2 DO 60 J=1,M IF(J-K) 10,10,60 10 IR=J+KX R(IR)=0 DO 60 I=1,N IF(MS) 20,40,20 20 CALL LOC(I,J,IA,N,M,MS) CALL LOC(I,K,IB,N,M,MS) IF(IA) 30,60,30 30 IF(IB) 50,60,50 40 IA=N*(J-1)+I IB=N*(K-1)+I 50 R(IR)=R(IR)+A(IA)*A(IB) 60 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE MATIN C C PURPOSE C READS CONTROL CARD AND MATRIX DATA ELEMENTS FROM LOGICAL C UNIT 5 C C USAGE C CALL MATIN(ICODE,A,ISIZE,IROW,ICOL,IS,IER) C C DESCRIPTION OF PARAMETERS C ICODE-UPON RETURN, ICODE WILL CONTAIN FOUR DIGIT C IDENTIFICATION CODE FROM MATRIX PARAMETER CARD C A -DATA AREA FOR INPUT MATRIX C ISIZE-NUMBER OF ELEMENTS DIMENSIONED BY USER FOR AREA A C IROW -UPON RETURN, IROW WILL CONTAIN ROW DIMENSION FROM C MATRIX PARAMETER CARD C ICOL -UPON RETURN, ICOL WILL CONTAIN COLUMN DIMENSION FROM C MATRIX PARAMETER CARD C IS -UPON RETURN, IS WILL CONTAIN STORAGE MODE CODE FROM C MATRIX PARAMETER CARD WHERE C IS=0 GENERAL MATRIX C IS=1 SYMMETRIC MATRIX C IS=2 DIAGONAL MATRIX C IER -UPON RETURN, IER WILL CONTAIN AN ERROR CODE WHERE C IER=0 NO ERROR C IER=1 ISIZE IS LESS THAN NUMBER OF ELEMENTS IN C INPUT MATRIX C IER=2 INCORRECT NUMBER OF DATA CARDS C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C SUBROUTINE ASSUMES THAT INPUT MATRIX CONSISTS OF PARAMETER C CARD FOLLOWED BY DATA CARDS C PARAMETER CARD HAS THE FOLLOWING FORMAT C COL. 1- 2 BLANK C COL. 3- 6 UP TO FOUR DIGIT IDENTIFICATION CODE C COL. 7-10 NUMBER OF ROWS IN MATRIX C COL.11-14 NUMBER OF COLUMNS IN MATRIX C COL.15-16 STORAGE MODE OF MATRIX WHERE C 0 - GENERAL MATRIX C 1 - SYMMETRIC MATRIX C 2 - DIAGONAL MATRIX C DATA CARDS ARE ASSUMED TO HAVE SEVEN FIELDS OF TEN COLUMNS C EACH. DECIMAL POINT MAY APPEAR ANYWHERE IN A FIELD. IF NO C DECIMAL POINT IS INCLUDED, IT IS ASSUMED THAT THE DECIMAL C POINT IS AT THE END OF THE 10 COLUMN FIELD. NUMBER IN EACH C FIELD MAY BE PRECEDED BY BLANKS. DATA ELEMENTS MUST BE C PUNCHED BY ROW. A ROW MAY CONTINUE FROM CARD TO CARD. C HOWEVER EACH NEW ROW MUST START IN THE FIRST FIELD OF THE C NEXT CARD. ONLY THE UPPER TRIANGULAR PORTION OF A SYMMETRIC C OR THE DIAGONAL ELEMENTS OF A DIAGONAL MATRIX ARE CONTAINED C ON DATA CARDS. THE FIRST ELEMENT OF EACH NEW ROW WILL BE C THE DIAGONAL ELEMENT FOR A MATRIX WITH SYMMETRIC OR C DIAGONAL STORAGE MODE. COLUMNS 71-80 OF DATA CARDS MAY BE C USED FOR IDENTIFICATION, SEQUENCE NUMBERING, ETC.. C THE LAST DATA CARD FOR ANY MATRIX MUST BE FOLLOWED BY A CARD C WITH A 9 PUNCH IN COLUMN 1. C C....................................................................... C SUBROUTINE MATIN(ICODE, A,ISIZE,IROW,ICOL,IS,IER) DIMENSION A(1) DIMENSION CARD(8) LOGICAL EOF 1 FORMAT(7F10.0) 2 FORMAT(I6,2I4,I2) C IDC=7 IER=0 CALL CHKEOF (EOF) READ( 5,2)ICODE,IROW,ICOL,IS IF (EOF) GOTO 999 CALL LOC(IROW,ICOL,ICNT,IROW,ICOL,IS) IF(ISIZE-ICNT)6,7,7 6 IER=1 7 IF (ICNT)38,38,8 8 ICOLT=ICOL IROCR=1 C C COMPUTE NUMBER OF CARDS FOR THIS ROW C 11 IRCDS=(ICOLT-1)/IDC+1 IF(IS-1)15,15,12 12 IRCDS=1 C C SET UP LOOP FOR NUMBER OF CARDS IN ROW C 15 DO 31 K=1,IRCDS READ(5,1)(CARD(I),I=1,IDC) C C SKIP THROUGH DATA CARDS IF INPUT AREA TOO SMALL C IF(IER)16,16,31 16 L=0 C C COMPUTE COLUMN NUMBER FOR FIRST FIELD IN CURRENT CARD C JS=(K-1)*IDC+ICOL-ICOLT+1 JE=JS+IDC-1 IF(IS-1)19,19,17 17 JE=JS C C SET UP LOOP FOR DATA ELEMENTS WITHIN CARD C 19 DO 30 J=JS,JE IF(J-ICOL)20,20,31 20 CALL LOC(IROCR ,J,IJ,IROW,ICOL,IS) L=L+1 30 A(IJ)=CARD(L) 31 CONTINUE IROCR=IROCR+1 IF(IROW-IROCR) 38,35,35 35 IF(IS-1)37,36,36 36 ICOLT=ICOLT-1 37 GO TO 11 38 READ(5,1) CARD(1) CALL CHKEOF (EOF) IF (EOF) GOTO 999 IF(CARD(1)-9.E9)39,40,39 39 IER=2 40 RETURN 999 STOP END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR CANONICAL CORRELATION - MCANO C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD FOR A CANONICAL C CORRELATION, (2) CALL TWO SUBROUTINES TO CALCULATE SIMPLE C CORRELATIONS, CANONICAL CORRELATIONS, CHI-SQUARES, DEGREES C OF FREEDOM FOR CHI-SQUARES, AND COEFFICIENTS FOR LEFT AND C RIGHT HAND VARIABLES, NAMELY CANONICAL VARIATES, AND (3) C PRINT THE RESULTS. C C REMARKS C THE NUMBER OF LEFT HAND VARIABLES MUST BE GREATER THAN C OR EQUAL TO THE NUMBER OF RIGHT HAND VARIABLES. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C CORRE (WHICH, IN TURN, CALLS THE INPUT SUBROUTINE NAMED C DATA.) C CANOR (WHICH, IN TURN, CALLS THE SUBROUTINES MINV AND C NROOT. NROOT, IN TURN, CALLS THE SUBROUTINE EIGEN.) C C METHOD C REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO- C CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS, C 1962, CHAPTER 3. C C .................................................................. C C THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE C TOTAL NUMBER OF VARIABLES M (M=MP+MQ, WHERE MP IS THE NUMBER OF C LEFT HAND VARIABLES, AND MQ IS THE NUMBER OF RIGHT HAND VARI- C ABLES).. cC c DIMENSION XBAR(20),STD(20),CANR(20),CHISQ(20),NDF(20) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*M.. cC c DIMENSION RX(400) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO cC (M+1)*M/2.. cC c DIMENSION R(210) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF MP*MQ.. cC c DIMENSION COEFL(400) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF MQ*MQ.. cC c DIMENSION COEFR(400) cC cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION XBAR,STD,RX,R,CANR,CHISQ,COEFL,COEFR cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC ............................................................... cC c1 FORMAT(A4,A2,I5,2I2) c2 FORMAT(27H1CANONICAL CORRELATION.....,A4,A2//22H NO. OF OBSERVAT c 1IONS,8X,I4/29H NO. OF LEFT HAND VARIABLES,I5/30H NO. OF RIGHT c 3HAND VARIABLES,I4/) c3 FORMAT(6H0MEANS/(8F15.5)) c4 FORMAT(20H0STANDARD DEVIATIONS/(8F15.5)) c5 FORMAT(25H0CORRELATION COEFFICIENTS) c6 FORMAT(4H0ROW,I3/(10F12.5)) c7 FORMAT(1H0//12H NUMBER OF, 7X,7HLARGEST,7X,13HCORRESPONDING,31X, c 17HDEGREES/13H EIGENVALUES,5X,10HEIGENVALUE,7X,9HCANONICAL,7X, c 26HLAMBDA,5X,10HCHI-SQUARE,7X,2H0F/4X,7HREMOVED,7X,9HREMAINING,7X, c 311HCORRELATION,32X,7HFREEDOM/) c8 FORMAT(1H ,I7,F19.5,F16.5,2F14.5,5X,I5) c9 FORMAT(1H0/22H CANONICAL CORRELATION,F12.5) c10 FORMAT(39H0 COEFFICIENTS FOR LEFT HAND VARIABLES/(8F15.5)) c11 FORMAT(40H0 COEFFICIENTS FOR RIGHT HAND VARIABLES/(8F15.5)) cC DOUBLE PRECISION TMPFIL,FILE cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC FILE = TMPFIL('SSP') cC OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT', cC 1 DISPOSE='DELETE') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR,PR1,N,MP,MQ c IF (EOF) GOTO 999 cC PR.......PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1......PROBLEM NUMBER (CONTINUED) cC N........NUMBER OF OBSERVATIONS cC MP.......NUMBER OF LEFT HAND VARIABLES cC MQ.......NUMBER OF RIGHT HAND VARIABLES cC c WRITE (6,2) PR,PR1,N,MP,MQ cC c M=MP+MQ c IO=0 c X=0.0 cC c CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,CANR,CHISQ,COEFL) cC cC PRINT MEANS, STANDARD DEVIATIONS, AND CORRELATION cC COEFFICIENTS OF ALL VARIABLES cC c WRITE (6,3) (XBAR(I),I=1,M) c WRITE (6,4) (STD(I),I=1,M) c WRITE (6,5) c DO 160 I=1,M c DO 150 J=1,M c IF(I-J) 120, 130, 130 c120 L=I+(J*J-J)/2 c GO TO 140 c130 L=J+(I*I-I)/2 c140 CANR(J)=R(L) c150 CONTINUE c160 WRITE (6,6) I,(CANR(J),J=1,M) cC c CALL CANOR (N,MP,MQ,R,XBAR,STD,CANR,CHISQ,NDF,COEFR,COEFL,RX) cC cC PRINT EIGENVALUES, CANONICAL CORRELATIONS, LAMBDA, CHI-SQUARES, cC DEGREES OF FREEDOMS cC c WRITE (6,7) c DO 170 I=1,MQ c N1=I-1 cC cC TEST WHETHER EIGENVALUE IS GREATER THAN ZERO cC c IF(XBAR(I)) 165, 165, 170 c165 MM=N1 c GO TO 175 c170 WRITE (6,8) N1,XBAR(I),CANR(I),STD(I),CHISQ(I),NDF(I) c MM=MQ cC cC PRINT CANONICAL COEFFICIENTS cC c175 N1=0 c N2=0 c DO 200 I=1,MM c WRITE (6,9) CANR(I) c DO 180 J=1,MP c N1=N1+1 c180 XBAR(J)=COEFL(N1) c WRITE (6,10) (XBAR(J),J=1,MP) c DO 190 J=1,MQ c N2=N2+1 c190 XBAR(J)=COEFR(N2) c WRITE (6,11) (XBAR(J),J=1,MQ) c200 CONTINUE c GO TO 100 c999 STOP c END C C .................................................................. C C SUBROUTINE MCHB C C PURPOSE C FOR A GIVEN POSITIVE-DEFINITE M BY M MATRIX A WITH SYMMETRIC C BAND STRUCTURE AND - IF NECESSARY - A GIVEN GENERAL M BY N C MATRIX R, THE FOLLOWING CALCULATIONS (DEPENDENT ON THE C VALUE OF THE DECISION PARAMETER IOP) ARE PERFORMED C (1) MATRIX A IS FACTORIZED (IF IOP IS NOT NEGATIVE), THAT C MEANS BAND MATRIX TU WITH UPPER CODIAGONALS ONLY IS C GENERATED ON THE LOCATIONS OF A SUCH THAT C TRANSPOSE(TU)*TU=A. C (2) MATRIX R IS MULTIPLIED ON THE LEFT BY INVERSE(TU) C AND/OR INVERSE(TRANSPOSE(TU)) AND THE RESULT IS STORED C IN THE LOCATIONS OF R. C THIS SUBROUTINE ESPECIALLY CAN BE USED TO SOLVE THE SYSTEM C OF SIMULTANEOUS LINEAR EQUATIONS A*X=R WITH POSITIVE- C DEFINITE COEFFICIENT MATRIX A OF SYMMETRIC BAND STRUCTURE. C C USAGE C CALL MCHB (R,A,M,N,MUD,IOP,EPS,IER) C C DESCRIPTION OF PARAMETERS C R - INPUT IN CASES IOP=-3,-2,-1,1,2,3 M BY N RIGHT C HAND SIDE MATRIX, C IN CASE IOP=0 IRRELEVANT. C OUTPUT IN CASES IOP=1,-1 INVERSE(A)*R, C IN CASES IOP=2,-2 INVERSE(TU)*R, C IN CASES IOP=3,-3 INVERSE(TRANSPOSE(TU))*R, C IN CASE IOP=0 UNCHANGED. C A - INPUT IN CASES IOP=0,1,2,3 M BY M POSITIVE-DEFINITE C COEFFICIENT MATRIX OF SYMMETRIC BAND STRUC- C TURE STORED IN COMPRESSED FORM (SEE REMARKS), C IN CASES IOP=-1,-2,-3 M BY M BAND MATRIX TU C WITH UPPER CODIAGONALS ONLY, STORED IN C COMPRESSED FORM (SEE REMARKS). C OUTPUT IN ALL CASES BAND MATRIX TU WITH UPPER C CODIAGONALS ONLY, STORED IN COMPRESSED FORM C (THAT MEANS UNCHANGED IF IOP=-1,-2,-3). C M - INPUT VALUE SPECIFYING THE NUMBER OF ROWS AND C COLUMNS OF A AND THE NUMBER OF ROWS OF R. C N - INPUT VALUE SPECIFYING THE NUMBER OF COLUMNS OF R C (IRRELEVANT IN CASE IOP=0). C MUD - INPUT VALUE SPECIFYING THE NUMBER OF UPPER C CODIAGONALS OF A. C IOP - ONE OF THE VALUES -3,-2,-1,0,1,2,3 GIVEN AS INPUT C AND USED AS DECISION PARAMETER. C EPS - INPUT VALUE USED AS RELATIVE TOLERANCE FOR TEST ON C LOSS OF SIGNIFICANT DIGITS. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT C PARAMETERS M,MUD,IOP (SEE REMARKS), C OR BECAUSE OF A NONPOSITIVE RADICAND AT C SOME FACTORIZATION STEP, C OR BECAUSE OF A ZERO DIAGONAL ELEMENT C AT SOME DIVISION STEP. C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- C CANCE INDICATED AT FACTORIZATION STEP K+1 C WHERE RADICAND WAS NO LONGER GREATER C THAN EPS*A(K+1,K+1). C C REMARKS C UPPER PART OF SYMMETRIC BAND MATRIX A CONSISTING OF MAIN C DIAGONAL AND MUD UPPER CODIAGONALS (RESP. BAND MATRIX TU C CONSISTING OF MAIN DIAGONAL AND MUD UPPER CODIAGONALS) C IS ASSUMED TO BE STORED IN COMPRESSED FORM, I.E. ROWWISE C IN TOTALLY NEEDED M+MUD*(2M-MUD-1)/2 SUCCESSIVE STORAGE C LOCATIONS. ON RETURN UPPER BAND FACTOR TU (ON THE LOCATIONS C OF A) IS STORED IN THE SAME WAY. C RIGHT HAND SIDE MATRIX R IS ASSUMED TO BE STORED COLUMNWISE C IN N*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN RESULT MATRIX C INVERSE(A)*R OR INVERSE(TU)*R OR INVERSE(TRANSPOSE(TU))*R C IS STORED COLUMNWISE TOO ON THE LOCATIONS OF R. C INPUT PARAMETERS M, MUD, IOP SHOULD SATISFY THE FOLLOWING C RESTRICTIONS MUD NOT LESS THAN ZERO, C 1+MUD NOT GREATER THAN M, C ABS(IOP) NOT GREATER THAN 3. C NO ACTION BESIDES ERROR MESSAGE IER=-1 TAKES PLACE IF THESE C RESTRICTIONS ARE NOT SATISFIED. C THE PROCEDURE GIVES RESULTS IF THE RESTRICTIONS ON INPUT C PARAMETERS ARE SATISFIED, IF RADICANDS AT ALL FACTORIZATION C STEPS ARE POSITIVE AND/OR IF ALL DIAGONAL ELEMENTS OF C UPPER BAND FACTOR TU ARE NONZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C FACTORIZATION IS DONE USING CHOLESKY-S SQUARE-ROOT METHOD, C WHICH GENERATES THE UPPER BAND MATRIX TU SUCH THAT C TRANSPOSE(TU)*TU=A. TU IS RETURNED AS RESULT ON THE C LOCATIONS OF A. FURTHER, DEPENDENT ON THE ACTUAL VALUE OF C IOP, DIVISION OF R BY TRANSPOSE(TU) AND/OR TU IS PERFORMED C AND THE RESULT IS RETURNED ON THE LOCATIONS OF R. C FOR REFERENCE, SEE H. RUTISHAUSER, ALGORITHMUS 1 - LINEARES C GLEICHUNGSSYSTEM MIT SYMMETRISCHER POSITIV-DEFINITER C BANDMATRIX NACH CHOLESKY - , COMPUTING (ARCHIVES FOR C ELECTRONIC COMPUTING), VOL.1, ISS.1 (1966), PP.77-78. C C .................................................................. C SUBROUTINE MCHB(R,A,M,N,MUD,IOP,EPS,IER) C C DIMENSION R(1),A(1) DOUBLE PRECISION TOL,SUM,PIV C C TEST ON WRONG INPUT PARAMETERS IF(IABS(IOP)-3)1,1,43 1 IF(MUD)43,2,2 2 MC=MUD+1 IF(M-MC)43,3,3 3 MR=M-MUD IER=0 C C MC IS THE MAXIMUM NUMBER OF ELEMENTS IN THE ROWS OF ARRAY A C MR IS THE INDEX OF THE LAST ROW IN ARRAY A WITH MC ELEMENTS C C ****************************************************************** C C START FACTORIZATION OF MATRIX A IF(IOP)24,4,4 4 IEND=0 LLDST=MUD DO 23 K=1,M IST=IEND+1 IEND=IST+MUD J=K-MR IF(J)6,6,5 5 IEND=IEND-J 6 IF(J-1)8,8,7 7 LLDST=LLDST-1 8 LMAX=MUD J=MC-K IF(J)10,10,9 9 LMAX=LMAX-J 10 ID=0 TOL=A(IST)*EPS C C START FACTORIZATION-LOOP OVER K-TH ROW DO 23 I=IST,IEND SUM=0.D0 IF(LMAX)14,14,11 C C PREPARE INNER LOOP 11 LL=IST LLD=LLDST C C START INNER LOOP DO 13 L=1,LMAX LL=LL-LLD LLL=LL+ID SUM=SUM+A(LL)*A(LLL) IF(LLD-MUD)12,13,13 12 LLD=LLD+1 13 CONTINUE C END OF INNER LOOP C C TRANSFORM ELEMENT A(I) 14 SUM=DBLE(A(I))-SUM IF(I-IST)15,15,20 C C A(I) IS DIAGONAL ELEMENT. ERROR TEST. 15 IF(SUM)43,43,16 C C TEST ON LOSS OF SIGNIFICANT DIGITS AND WARNING 16 IF(SUM-TOL)17,17,19 17 IF(IER)18,18,19 18 IER=K-1 C C COMPUTATION OF PIVOT ELEMENT 19 PIV=DSQRT(SUM) A(I)=PIV PIV=1.D0/PIV GO TO 21 C C A(I) IS NOT DIAGONAL ELEMENT 20 A(I)=SUM*PIV C C UPDATE ID AND LMAX 21 ID=ID+1 IF(ID-J)23,23,22 22 LMAX=LMAX-1 23 CONTINUE C C END OF FACTORIZATION-LOOP OVER K-TH ROW C END OF FACTORIZATION OF MATRIX A C C ****************************************************************** C C PREPARE MATRIX DIVISIONS IF(IOP)24,44,24 24 ID=N*M IEND=IABS(IOP)-2 IF(IEND)25,35,25 C C ****************************************************************** C C START DIVISION BY TRANSPOSE OF MATRIX TU (TU IS STORED IN C LOCATIONS OF A) 25 IST=1 LMAX=0 J=-MR LLDST=MUD DO 34 K=1,M PIV=A(IST) IF(PIV)26,43,26 26 PIV=1.D0/PIV C C START BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R DO 30 I=K,ID,M SUM=0.D0 IF(LMAX)30,30,27 C C PREPARE INNER LOOP 27 LL=IST LLL=I LLD=LLDST C C START INNER LOOP DO 29 L=1,LMAX LL=LL-LLD LLL=LLL-1 SUM=SUM+A(LL)*R(LLL) IF(LLD-MUD)28,29,29 28 LLD=LLD+1 29 CONTINUE C END OF INNER LOOP C C TRANSFORM ELEMENT R(I) 30 R(I)=PIV*(DBLE(R(I))-SUM) C END OF BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R C C UPDATE PARAMETERS LMAX, IST AND LLDST IF(MC-K)32,32,31 31 LMAX=K 32 IST=IST+MC J=J+1 IF(J)34,34,33 33 IST=IST-J LLDST=LLDST-1 34 CONTINUE C C END OF DIVISION BY TRANSPOSE OF MATRIX TU C C ****************************************************************** C C START DIVISION BY MATRIX TU (TU IS STORED ON LOCATIONS OF A) IF(IEND)35,35,44 35 IST=M+(MUD*(M+M-MC))/2+1 LMAX=0 K=M 36 IEND=IST-1 IST=IEND-LMAX PIV=A(IST) IF(PIV)37,43,37 37 PIV=1.D0/PIV L=IST+1 C C START BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R DO 40 I=K,ID,M SUM=0.D0 IF(LMAX)40,40,38 38 LLL=I C C START INNER LOOP DO 39 LL=L,IEND LLL=LLL+1 39 SUM=SUM+A(LL)*R(LLL) C END OF INNER LOOP C C TRANSFORM ELEMENT R(I) 40 R(I)=PIV*(DBLE(R(I))-SUM) C END OF BACKSUBSTITUTION-LOOP FOR K-TH ROW OF MATRIX R C C C UPDATE PARAMETERS LMAX AND K IF(K-MR)42,42,41 41 LMAX=LMAX+1 42 K=K-1 IF(K)44,44,36 C C END OF DIVISION BY MATRIX TU C C ****************************************************************** C C ERROR EXIT IN CASE OF WRONG INPUT PARAMETERS OR PIVOT ELEMENT C LESS THAN OR EQUAL TO ZERO 43 IER=-1 44 RETURN END C C ............................................................... C C SUBROUTINE MCPY C C PURPOSE C COPY ENTIRE MATRIX C C USAGE C CALL MCPY (A,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A OR R C M - NUMBER OF COLUMNS IN A OR R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT OF MATRIX A IS MOVED TO THE CORRESPONDING C ELEMENT OF MATRIX R C C .................................................................. C SUBROUTINE MCPY(A,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C COPY MATRIX C DO 1 I=1,IT 1 R(I)=A(I) RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR DISCRIMINANT ANALYSIS - MDISC C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD AND DATA FOR DISCRIMI- C NANT ANALYSIS, (2) CALL THREE SUBROUTINES TO CALCULATE VARI- C ABLE MEANS IN EACH GROUP, POOLED DISPERSION MATRIX, COMMON C MEANS OF VARIABLES, GENERALIZED MAHALANOBIS D SQUARE, C COEFFICIENTS OF DISCRIMINANT FUNCTIONS, AND PROBABILITY C ASSOCIATED WITH LARGEST DISCRIMINANT FUNCTION OF EACH C CASE IN EACH GROUP, AND (3) PRINT THE RESULTS. C C REMARKS C THE NUMBER OF VARIABLES MUST BE GREATER THAN OR EQUAL TO C THE NUMBER OF GROUPS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C DMATX C MINV C DISCR C C METHOD C REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J. C DIXON, UCLA, 1964, AND T. W. ANDERSON, 'INTRODUCTION TO C MULTIVARIATE STATISTICAL ANALYSIS', JOHN WILEY AND SONS, C 1958, SECTION 6.6-6.8. C C .................................................................. C C THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE C NUMBER OF GROUPS, K.. cC c DIMENSION N(5) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC NUMBER OF VARIABLES, M.. cC c DIMENSION CMEAN(10) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*K.. cC c DIMENSION XBAR(50) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF (M+1)*K.. cC c DIMENSION C(55) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*M.. cC c DIMENSION D(100) cC cC THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE cC TOTAL OF SAMPLE SIZES OF K GROUPS COMBINED, T (T = N(1)+N(2)+... cC +N(K)).. cC c DIMENSION P(250),LG(250) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC TOTAL DATA POINTS WHICH IS EQUAL TO THE PRODUCT OF T*M.. cC c DIMENSION X(2500) cC cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION CMEAN,XBAR,D,DET,C,V,P cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC ............................................................... cC c1 FORMAT(A4,A2,2I2,12I5/(14I5)) c2 FORMAT(27H1DISCRIMINANT ANALYSIS.....,A4,A2/19H0 NUMBER OF GROUPS c 1,7X,I3/22H NUMBER OF VARIABLES,I7/17H SAMPLE SIZES../12X,5HGRO c 2UP) c3 FORMAT(12X,I3,8X,I4) c4 FORMAT(1H0) c5 FORMAT(12F6.0) c6 FORMAT(6H0GROUP,I3,7H MEANS/(8F15.5)) c7 FORMAT(1H0/25H POOLED DISPERSION MATRIX) c8 FORMAT(4H0ROW,I3/(8F15.5)) c9 FORMAT(1H0//13H COMMON MEANS/(8F15.5)) c10 FORMAT(1H///33H GENERALIZED MAHALANOBIS D-SQUARE,F15.5//) c11 FORMAT(22H0DISCRIMINANT FUNCTION,I3/1H ,6X,27HCONSTANT * COEFF c 1ICIENTS/1H F14.5,7H * ,7F14.5/(22X,7F14.5)) c12 FORMAT(1H0//60H EVALUATION OF CLASSIFICATION FUNCTIONS FOR EACH OB c 1SERVATION) c13 FORMAT(6H0GROUP,I3/19X,27HPROBABILITY ASSOCIATED WITH,11X,7HLARGES c 1T/13H OBSERVATION,5X,29HLARGEST DISCRIMINANT FUNCTION,8X,12HFUNCT c 2ION NO.) c14 FORMAT(1H ,I7,20X,F8.5,20X,I6) cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR,PR1,K,M,(N(I),I=1,K) c IF (EOF) GOTO 999 cC PR.......PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1......PROBLEM NUMBER (CONTINUED) cC K........NUMBER OF GROUPS cC M........NUMBER OF VARIABLES cC N........VECTOR OF LENGTH K CONTAINING SAMPLE SIZES cC c WRITE (6,2) PR,PR1,K,M c DO 110 I=1,K c110 WRITE (6,3) I,N(I) c WRITE (6,4) cC cC READ DATA cC c L=0 c DO 130 I=1,K c N1=N(I) c DO 120 J=1,N1 c READ (5,5) (CMEAN(IJ),IJ=1,M) c L=L+1 c N2=L-N1 c DO 120 IJ=1,M c N2=N2+N1 c120 X(N2)=CMEAN(IJ) c130 L=N2 cC c CALL DMATX (K,M,N,X,XBAR,D,CMEAN) cC cC PRINT MEANS AND POOLED DISPERSION MATRIX cC c L=0 c DO 150 I=1,K c DO 140 J=1,M c L=L+1 c140 CMEAN(J)=XBAR(L) c150 WRITE (6,6) I,(CMEAN(J),J=1,M) c WRITE (6,7) c DO 170 I=1,M c L=I-M c DO 160 J=1,M c L=L+M c160 CMEAN(J)=D(L) c170 WRITE (6,8) I,(CMEAN(J),J=1,M) cC c CALL MINV (D,M,DET,CMEAN,C) cC c CALL DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG) cC cC PRINT COMMON MEANS cC c WRITE (6,9) (CMEAN(I),I=1,M) cC cC PRINT GENERALIZED MAHALANOBIS D-SQUARE cC c WRITE (6,10) V cC cC PRINT CONSTANTS AND COEFFICIENTS OF DISCRIMINANT FUNCTIONS cC c N1=1 c N2=M+1 c DO 180 I=1,K c WRITE (6,11) I,(C(J),J=N1,N2) c N1=N1+(M+1) c180 N2=N2+(M+1) cC cC PRINT EVALUATION OF CALSSIFICATION FUNCTIONS FOR EACH OBSERVATION cC c WRITE (6,12) c N1=1 c N2=N(1) c DO 210 I=1,K c WRITE (6,13) I c L=0 c DO 190 J=N1,N2 c L=L+1 c190 WRITE (6,14) L,P(J),LG(J) c IF(I-K) 200, 100, 100 c200 N1=N1+N(I) c N2=N2+N(I+1) c210 CONTINUE c999 STOP c END C C .................................................................. C C SUBROUTINE MEANQ C C PURPOSE C COMPUTE SUM OF SQUARES, DEGREES OF FREEDOM, AND MEAN SQUARE C USING THE MEAN SQUARE OPERATOR. THIS SUBROUTINE NORMALLY C FOLLOWS CALLS TO AVDAT AND AVCAL SUBROUTINES IN THE PER- C FORMANCE OF ANALYSIS OF VARIANCE FOR A COMPLETE FACTORIAL C DESIGN. C C USAGE C CALL MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,MSTEP,KOUNT, C LASTS) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF VARIABLES (FACTORS). K MUST BE .GT. ONE. C LEVEL - INPUT VECTOR OF LENGTH K CONTAINING LEVELS (CATE- C GORIES) WITHIN EACH VARIABLE. C X - INPUT VECTOR CONTAINING THE RESULT OF THE SIGMA AND C DELTA OPERATORS. THE LENGTH OF X IS C (LEVEL(1)+1)*(LEVEL(2)+1)*...*(LEVEL(K)+1). C GMEAN - OUTPUT VARIABLE CONTAINING GRAND MEAN. C SUMSQ - OUTPUT VECTOR CONTAINING SUMS OF SQUARES. THE C LENGTH OF SUMSQ IS 2 TO THE K-TH POWER MINUS ONE, C (2**K)-1. C NDF - OUTPUT VECTOR CONTAINING DEGREES OF FREEDOM. THE C LENGTH OF NDF IS 2 TO THE K-TH POWER MINUS ONE, C (2**K)-1. C SMEAN - OUTPUT VECTOR CONTAINING MEAN SQUARES. THE C LENGTH OF SMEAN IS 2 TO THE K-TH POWER MINUS ONE, C (2**K)-1. C MSTEP - WORKING VECTOR OF LENGTH K. C KOUNT - WORKING VECTOR OF LENGTH K. C LASTS - WORKING VECTOR OF LENGTH K. C C REMARKS C THIS SUBROUTINE MUST FOLLOW SUBROUTINE AVCAL C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE METHOD IS BASED ON THE TECHNIQUE DISCUSSED BY H. O. C HARTLEY IN 'MATHEMATICAL METHODS FOR DIGITAL COMPUTERS', C EDITED BY A. RALSTON AND H. WILF, JOHN WILEY AND SONS, C 1962, CHAPTER 20. C C .................................................................. C SUBROUTINE MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,MSTEP,KOUNT, 1 LASTS) DIMENSION LEVEL(1),X(1),SUMSQ(1),NDF(1),SMEAN(1),MSTEP(1), 1 KOUNT(1),LASTS(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION X,GMEAN,SUMSQ,SMEAN,FN1 C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C CALCULATE TOTAL NUMBER OF DATA C N=LEVEL(1) DO 150 I=2,K 150 N=N*LEVEL(I) C C SET UP CONTROL FOR MEAN SQUARE OPERATOR C LASTS(1)=LEVEL(1) DO 178 I=2,K 178 LASTS(I)=LEVEL(I)+1 NN=1 C C CLEAR THE AREA TO STORE SUMS OF SQUARES C LL=(2**K)-1 MSTEP(1)=1 DO 180 I=2,K 180 MSTEP(I)=MSTEP(I-1)*2 DO 185 I=1,LL 185 SUMSQ(I)=0.0 C C PERFORM MEAN SQUARE OPERATOR C DO 190 I=1,K 190 KOUNT(I)=0 200 L=0 DO 260 I=1,K IF(KOUNT(I)-LASTS(I)) 210, 250, 210 210 IF(L) 220, 220, 240 220 KOUNT(I)=KOUNT(I)+1 IF(KOUNT(I)-LEVEL(I)) 230, 230, 250 230 L=L+MSTEP(I) GO TO 260 240 IF(KOUNT(I)-LEVEL(I)) 230, 260, 230 250 KOUNT(I)=0 260 CONTINUE IF(L) 285, 285, 270 270 SUMSQ(L)=SUMSQ(L)+X(NN)*X(NN) NN=NN+1 GO TO 200 C C CALCULATE THE GRAND MEAN C 285 FN=N GMEAN=X(NN)/FN C C CALCULATE FIRST DIVISOR REQUIRED TO FORM SUM OF SQUARES AND SECOND C DIVISOR, WHICH IS EQUAL TO DEGREES OF FREEDOM, REQUIRED TO FORM C MEAN SQUARES C DO 310 I=2,K 310 MSTEP(I)=0 NN=0 MSTEP(1)=1 320 ND1=1 ND2=1 DO 340 I=1,K IF(MSTEP(I)) 330, 340, 330 330 ND1=ND1*LEVEL(I) ND2=ND2*(LEVEL(I)-1) 340 CONTINUE FN1=N*ND1 FN2=ND2 NN=NN+1 SUMSQ(NN)=SUMSQ(NN)/FN1 NDF(NN)=ND2 SMEAN(NN)=SUMSQ(NN)/FN2 IF(NN-LL) 345, 370, 370 345 DO 360 I=1,K IF(MSTEP(I)) 347, 350, 347 347 MSTEP(I)=0 GO TO 360 350 MSTEP(I)=1 GO TO 320 360 CONTINUE 370 RETURN END C C .................................................................. C C SUBROUTINE MFGR C C PURPOSE C FOR A GIVEN M BY N MATRIX THE FOLLOWING CALCULATIONS C ARE PERFORMED C (1) DETERMINE RANK AND LINEARLY INDEPENDENT ROWS AND C COLUMNS (BASIS). C (2) FACTORIZE A SUBMATRIX OF MAXIMAL RANK. C (3) EXPRESS NON-BASIC ROWS IN TERMS OF BASIC ONES. C (4) EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES. C C USAGE C CALL MFGR(A,M,N,EPS,IRANK,IROW,ICOL) C C DESCRIPTION OF PARAMETERS C A - GIVEN MATRIX WITH M ROWS AND N COLUMNS. C ON RETURN A CONTAINS THE FIVE SUBMATRICES C L, R, H, D, O. C M - NUMBER OF ROWS OF MATRIX A. C N - NUMBER OF COLUMNS OF MATRIX A. C EPS - TESTVALUE FOR ZERO AFFECTED BY ROUNDOFF NOISE. C IRANK - RESULTANT RANK OF GIVEN MATRIX. C IROW - INTEGER VECTOR OF DIMENSION M CONTAINING THE C SUBSCRIPTS OF BASIC ROWS IN IROW(1),...,IROW(IRANK) C ICOL - INTEGER VECTOR OF DIMENSION N CONTAINING THE C SUBSCRIPTS OF BASIC COLUMNS IN ICOL(1) UP TO C ICOL(IRANK). C C REMARKS C THE LEFT HAND TRIANGULAR FACTOR IS NORMALIZED SUCH THAT C THE DIAGONAL CONTAINS ALL ONES THUS ALLOWING TO STORE ONLY C THE SUBDIAGONAL PART. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C GAUSSIAN ELIMINATION TECHNIQUE IS USED FOR CALCULATION C OF THE TRIANGULAR FACTORS OF A GIVEN MATRIX. C COMPLETE PIVOTING IS BUILT IN. C IN CASE OF A SINGULAR MATRIX ONLY THE TRIANGULAR FACTORS C OF A SUBMATRIX OF MAXIMAL RANK ARE RETAINED. C THE REMAINING PARTS OF THE RESULTANT MATRIX GIVE THE C DEPENDENCIES OF ROWS AND THE SOLUTION OF THE HOMOGENEOUS C MATRIX EQUATION A*X=0. C C .................................................................. C SUBROUTINE MFGR(A,M,N,EPS,IRANK,IROW,ICOL) C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),IROW(1),ICOL(1) C C TEST OF SPECIFIED DIMENSIONS IF(M)2,2,1 1 IF(N)2,2,4 2 IRANK=-1 3 RETURN C RETURN IN CASE OF FORMAL ERRORS C C C INITIALIZE COLUMN INDEX VECTOR C SEARCH FIRST PIVOT ELEMENT 4 IRANK=0 PIV=0. JJ=0 DO 6 J=1,N ICOL(J)=J DO 6 I=1,M JJ=JJ+1 HOLD=A(JJ) IF(ABS(PIV)-ABS(HOLD))5,6,6 5 PIV=HOLD IR=I IC=J 6 CONTINUE C C INITIALIZE ROW INDEX VECTOR DO 7 I=1,M 7 IROW(I)=I C C SET UP INTERNAL TOLERANCE TOL=ABS(EPS*PIV) C C INITIALIZE ELIMINATION LOOP NM=N*M DO 19 NCOL=M,NM,M C C TEST FOR FEASIBILITY OF PIVOT ELEMENT 8 IF(ABS(PIV)-TOL)20,20,9 C C UPDATE RANK 9 IRANK=IRANK+1 C C INTERCHANGE ROWS IF NECESSARY JJ=IR-IRANK IF(JJ)12,12,10 10 DO 11 J=IRANK,NM,M I=J+JJ SAVE=A(J) A(J)=A(I) 11 A(I)=SAVE C C UPDATE ROW INDEX VECTOR JJ=IROW(IR) IROW(IR)=IROW(IRANK) IROW(IRANK)=JJ C C INTERCHANGE COLUMNS IF NECESSARY 12 JJ=(IC-IRANK)*M IF(JJ)15,15,13 13 KK=NCOL DO 14 J=1,M I=KK+JJ SAVE=A(KK) A(KK)=A(I) KK=KK-1 14 A(I)=SAVE C C UPDATE COLUMN INDEX VECTOR JJ=ICOL(IC) ICOL(IC)=ICOL(IRANK) ICOL(IRANK)=JJ 15 KK=IRANK+1 MM=IRANK-M LL=NCOL+MM C C TEST FOR LAST ROW IF(MM)16,25,25 C C TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT 16 JJ=LL SAVE=PIV PIV=0. DO 19 J=KK,M JJ=JJ+1 HOLD=A(JJ)/SAVE A(JJ)=HOLD L=J-IRANK C C TEST FOR LAST COLUMN IF(IRANK-N)17,19,19 17 II=JJ DO 19 I=KK,N II=II+M MM=II-L A(II)=A(II)-HOLD*A(MM) IF(ABS(A(II))-ABS(PIV))19,19,18 18 PIV=A(II) IR=J IC=I 19 CONTINUE C C SET UP MATRIX EXPRESSING ROW DEPENDENCIES 20 IF(IRANK-1)3,25,21 21 IR=LL DO 24 J=2,IRANK II=J-1 IR=IR-M JJ=LL DO 23 I=KK,M HOLD=0. JJ=JJ+1 MM=JJ IC=IR DO 22 L=1,II HOLD=HOLD+A(MM)*A(IC) IC=IC-1 22 MM=MM-M 23 A(MM)=A(MM)-HOLD 24 CONTINUE C C TEST FOR COLUMN REGULARITY 25 IF(N-IRANK)3,3,26 C C SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE C PARAMETERS (HOMOGENEOUS SOLUTION). 26 IR=LL KK=LL+M DO 30 J=1,IRANK DO 29 I=KK,NM,M JJ=IR LL=I HOLD=0. II=J 27 II=II-1 IF(II)29,29,28 28 HOLD=HOLD-A(JJ)*A(LL) JJ=JJ-M LL=LL-1 GOTO 27 29 A(LL)=(HOLD-A(LL))/A(JJ) 30 IR=IR-1 RETURN END C C .................................................................. C C SUBROUTINE MFSD C C PURPOSE C FACTOR A GIVEN SYMMETRIC POSITIVE DEFINITE MATRIX C C USAGE C CALL MFSD(A,N,EPS,IER) C C DESCRIPTION OF PARAMETERS C A - UPPER TRIANGULAR PART OF THE GIVEN SYMMETRIC C POSITIVE DEFINITE N BY N COEFFICIENT MATRIX. C ON RETURN A CONTAINS THE RESULTANT UPPER C TRIANGULAR MATRIX. C N - THE NUMBER OF ROWS (COLUMNS) IN GIVEN MATRIX. C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR C IER=-1 - NO RESULT BECAUSE OF WRONG INPUT PARAME- C TER N OR BECAUSE SOME RADICAND IS NON- C POSITIVE (MATRIX A IS NOT POSITIVE C DEFINITE, POSSIBLY DUE TO LOSS OF SIGNI- C FICANCE) C IER=K - WARNING WHICH INDICATES LOSS OF SIGNIFI- C CANCE. THE RADICAND FORMED AT FACTORIZA- C TION STEP K+1 WAS STILL POSITIVE BUT NO C LONGER GREATER THAN ABS(EPS*A(K+1,K+1)). C C REMARKS C THE UPPER TRIANGULAR PART OF GIVEN MATRIX IS ASSUMED TO BE C STORED COLUMNWISE IN N*(N+1)/2 SUCCESSIVE STORAGE LOCATIONS. C IN THE SAME STORAGE LOCATIONS THE RESULTING UPPER TRIANGU- C LAR MATRIX IS STORED COLUMNWISE TOO. C THE PROCEDURE GIVES RESULTS IF N IS GREATER THAN 0 AND ALL C CALCULATED RADICANDS ARE POSITIVE. C THE PRODUCT OF RETURNED DIAGONAL TERMS IS EQUAL TO THE C SQUARE-ROOT OF THE DETERMINANT OF THE GIVEN MATRIX. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SOLUTION IS DONE USING THE SQUARE-ROOT METHOD OF CHOLESKY. C THE GIVEN MATRIX IS REPRESENTED AS PRODUCT OF TWO TRIANGULAR C MATRICES, WHERE THE LEFT HAND FACTOR IS THE TRANSPOSE OF C THE RETURNED RIGHT HAND FACTOR. C C .................................................................. C SUBROUTINE MFSD(A,N,EPS,IER) C C DIMENSION A(1) DOUBLE PRECISION DPIV,DSUM C C TEST ON WRONG INPUT PARAMETER N IF(N-1) 12,1,1 1 IER=0 C C INITIALIZE DIAGONAL-LOOP KPIV=0 DO 11 K=1,N KPIV=KPIV+K IND=KPIV LEND=K-1 C C CALCULATE TOLERANCE TOL=ABS(EPS*A(KPIV)) C C START FACTORIZATION-LOOP OVER K-TH ROW DO 11 I=K,N DSUM=0.D0 IF(LEND) 2,4,2 C C START INNER LOOP 2 DO 3 L=1,LEND LANF=KPIV-L LIND=IND-L 3 DSUM=DSUM+DBLE(A(LANF)*A(LIND)) C END OF INNER LOOP C C TRANSFORM ELEMENT A(IND) 4 DSUM=DBLE(A(IND))-DSUM IF(I-K) 10,5,10 C C TEST FOR NEGATIVE PIVOT ELEMENT AND FOR LOSS OF SIGNIFICANCE 5 IF(SNGL(DSUM)-TOL) 6,6,9 6 IF(DSUM) 12,12,7 7 IF(IER) 8,8,9 8 IER=K-1 C C COMPUTE PIVOT ELEMENT 9 DPIV=DSQRT(DSUM) A(KPIV)=DPIV DPIV=1.D0/DPIV GO TO 11 C C CALCULATE TERMS IN ROW 10 A(IND)=DSUM*DPIV 11 IND=IND+I C C END OF DIAGONAL-LOOP RETURN 12 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE MFSS C C PURPOSE C GIVEN A SYMMETRIC POSITIVE SEMI DEFINITE MATRIX , MFSS WILL C (1) DETERMINE THE RANK AND LINEARLY INDEPENDENT ROWS AND C COLUMNS C (2) FACTOR A SYMMETRIC SUBMATRIX OF MAXIMAL RANK C (3) EXPRESS NONBASIC ROWS IN TERMS OF BASIC ONES, C EXPRESS NONBASIC COLUMNS IN TERMS OF BASIC ONES C EXPRESS BASIC VARIABLES IN TERMS OF FREE ONES C SUBROUTINE MFSS MAY BE USED AS A PREPARATORY STEP FOR THE C CALCULATION OF THE LEAST SQUARES SOLUTION OF MINIMAL C LENGTH OF A SYSTEM OF LINEAR EQUATIONS WITH SYMMETRIC C POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX C C USAGE C CALL MFSS(A,N,EPS,IRANK,TRAC) C C DESCRIPTION OF PARAMETERS C A - UPPER TRIANGULAR PART OF GIVEN SYMMETRIC SEMI- C DEFINITE MATRIX STORED COLUMNWISE IN COMPRESSED FORM C ON RETURN A CONTAINS THE MATRIX T AND, IF IRANK IS C LESS THAN N, THE MATRICES U AND TU C N - DIMENSION OF GIVEN MATRIX A C EPS - TESTVALUE FOR ZERO AFFECTED BY ROUND-OFF NOISE C IRANK - RESULTANT VARIABLE, CONTAINING THE RANK OF GIVEN C MATRIX A IF A IS SEMI-DEFINITE C IRANK = 0 MEANS A HAS NO POSITIVE DIAGONAL ELEMENT C AND/OR EPS IS NOT ABSOLUTELY LESS THAN ONE C IRANK =-1 MEANS DIMENSION N IS NOT POSITIVE C IRANK =-2 MEANS COMPLETE FAILURE, POSSIBLY DUE TO C INADEQUATE RELATIVE TOLERANCE EPS C TRAC - VECTOR OF DIMENSION N CONTAINING THE C SOURCE INDEX OF THE I-TH PIVOT ROW IN ITS I-TH C LOCATION, THIS MEANS THAT TRAC CONTAINS THE C PRODUCT REPRESENTATION OF THE PERMUTATION WHICH C IS APPLIED TO ROWS AND COLUMNS OF A IN TERMS OF C TRANSPOSITIONS C C REMARKS C EPS MUST BE ABSOLUTELY LESS THAN ONE. A SENSIBLE VALUE IS C SOMEWHERE IN BETWEEN 10**(-4) AND 10**(-6) C THE ABSOLUTE VALUE OF INPUT PARAMETER EPS IS USED AS C RELATIVE TOLERANCE. C IN ORDER TO PRESERVE SYMMETRY ONLY PIVOTING ALONG THE C DIAGONAL IS BUILT IN. C ALL PIVOTELEMENTS MUST BE GREATER THAN THE ABSOLUTE VALUE C OF EPS TIMES ORIGINAL DIAGONAL ELEMENT C OTHERWISE THEY ARE TREATED AS IF THEY WERE ZERO C MATRIX A REMAINS UNCHANGED IF THE RESULTANT VALUE IRANK C EQUALS ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE SQUARE ROOT METHOD WITH DIAGONAL PIVOTING IS USED FOR C CALCULATION OF THE RIGHT HAND TRIANGULAR FACTOR. C IN CASE OF AN ONLY SEMI-DEFINITE MATRIX THE SUBROUTINE C RETURNS THE IRANK X IRANK UPPER TRIANGULAR FACTOR T OF A C SUBMATRIX OF MAXIMAL RANK, THE IRANK X (N-IRANK) MATRIX U C AND THE (N-IRANK) X (N-IRANK) UPPER TRIANGULAR TU SUCH C THAT TRANSPOSE(TU)*TU=I+TRANSPOSE(U)*U C C .................................................................. C SUBROUTINE MFSS(A,N,EPS,IRANK,TRAC) C C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),TRAC(1) DOUBLE PRECISION SUM C C TEST OF SPECIFIED DIMENSION IF(N)36,36,1 C C INITIALIZE TRIANGULAR FACTORIZATION 1 IRANK=0 ISUB=0 KPIV=0 J=0 PIV=0. C C SEARCH FIRST PIVOT ELEMENT DO 3 K=1,N J=J+K TRAC(K)=A(J) IF(A(J)-PIV)3,3,2 2 PIV=A(J) KSUB=J KPIV=K 3 CONTINUE C C START LOOP OVER ALL ROWS OF A DO 32 I=1,N ISUB=ISUB+I IM1=I-1 4 KMI=KPIV-I IF(KMI)35,9,5 C C PERFORM PARTIAL COLUMN INTERCHANGE 5 JI=KSUB-KMI IDC=JI-ISUB JJ=ISUB-IM1 DO 6 K=JJ,ISUB KK=K+IDC HOLD=A(K) A(K)=A(KK) 6 A(KK)=HOLD C C PERFORM PARTIAL ROW INTERCHANGE KK=KSUB DO 7 K=KPIV,N II=KK-KMI HOLD=A(KK) A(KK)=A(II) A(II)=HOLD 7 KK=KK+K C C PERFORM REMAINING INTERCHANGE JJ=KPIV-1 II=ISUB DO 8 K=I,JJ HOLD=A(II) A(II)=A(JI) A(JI)=HOLD II=II+K 8 JI=JI+1 9 IF(IRANK)22,10,10 C C RECORD INTERCHANGE IN TRANSPOSITION VECTOR 10 TRAC(KPIV)=TRAC(I) TRAC(I)=KPIV C C MODIFY CURRENT PIVOT ROW KK=IM1-IRANK KMI=ISUB-KK PIV=0. IDC=IRANK+1 JI=ISUB-1 JK=KMI JJ=ISUB-I DO 19 K=I,N SUM=0.D0 C C BUILD UP SCALAR PRODUCT IF NECESSARY IF(KK)13,13,11 11 DO 12 J=KMI,JI SUM=SUM-A(J)*A(JK) 12 JK=JK+1 13 JJ=JJ+K IF(K-I)14,14,16 14 SUM=A(ISUB)+SUM C C TEST RADICAND FOR LOSS OF SIGNIFICANCE IF(SUM-ABS(A(ISUB)*EPS))20,20,15 15 A(ISUB)=DSQRT(SUM) KPIV=I+1 GOTO 19 16 SUM=(A(JK)+SUM)/A(ISUB) A(JK)=SUM C C SEARCH FOR NEXT PIVOT ROW IF(A(JJ))19,19,17 17 TRAC(K)=TRAC(K)-SUM*SUM HOLD=TRAC(K)/A(JJ) IF(PIV-HOLD)18,19,19 18 PIV=HOLD KPIV=K KSUB=JJ 19 JK=JJ+IDC GOTO 32 C C CALCULATE MATRIX OF DEPENDENCIES U 20 IF(IRANK)21,21,37 21 IRANK=-1 GOTO 4 22 IRANK=IM1 II=ISUB-IRANK JI=II DO 26 K=1,IRANK JI=JI-1 JK=ISUB-1 JJ=K-1 DO 26 J=I,N IDC=IRANK SUM=0.D0 KMI=JI KK=JK IF(JJ)25,25,23 23 DO 24 L=1,JJ IDC=IDC-1 SUM=SUM-A(KMI)*A(KK) KMI=KMI-IDC 24 KK=KK-1 25 A(KK)=(SUM+A(KK))/A(KMI) 26 JK=JK+J C C CALCULATE I+TRANSPOSE(U)*U JJ=ISUB-I PIV=0. KK=ISUB-1 DO 31 K=I,N JJ=JJ+K IDC=0 DO 28 J=K,N SUM=0.D0 KMI=JJ+IDC DO 27 L=II,KK JK=L+IDC 27 SUM=SUM+A(L)*A(JK) A(KMI)=SUM 28 IDC=IDC+J A(JJ)=A(JJ)+1.D0 TRAC(K)=A(JJ) C C SEARCH NEXT DIAGONAL ELEMENT IF(PIV-A(JJ))29,30,30 29 KPIV=K KSUB=JJ PIV=A(JJ) 30 II=II+K KK=KK+K 31 CONTINUE GOTO 4 32 CONTINUE 33 IF(IRANK)35,34,35 34 IRANK=N 35 RETURN C C ERROR RETURNS C C RETURN IN CASE OF ILLEGAL DIMENSION 36 IRANK=-1 RETURN C C INSTABLE FACTORIZATION OF I+TRANSPOSE(U)*U 37 IRANK=-2 RETURN END C C .................................................................. C C SUBROUTINE MFUN C C PURPOSE C APPLY A FUNCTION TO EACH ELEMENT OF A MATRIX TO FORM A C RESULTANT MATRIX C C USAGE C CALL MFUN (A,F,R,N,M,MS) C AN EXTERNAL STATEMENT MUST PRECEDE CALL STATEMENT IN ORDER C TO IDENTIFY PARAMETER F AS THE NAME OF A FUNCTION C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C F - NAME OF FORTRAN-FURNISHED OR USER FUNCTION SUBPROGRAM C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN MATRIX A AND R C M - NUMBER OF COLUMNS IN MATRIX A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C PRECISION IS DEPENDENT UPON PRECISION OF FUNCTION USED C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C FUNCTION F IS APPLIED TO EACH ELEMENT OF MATRIX A C TO FORM MATRIX R C C .................................................................. C SUBROUTINE MFUN(A,F,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C BUILD MATRIX R FOR ANY STORAGE MODE C DO 5 I=1,IT 5 R(I)=F(A(I)) RETURN END C C .................................................................. C C SUBROUTINE MINV C C PURPOSE C INVERT A MATRIX C C USAGE C CALL MINV(A,N,D,L,M) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY C RESULTANT INVERSE. C N - ORDER OF MATRIX A C D - RESULTANT DETERMINANT C L - WORK VECTOR OF LENGTH N C M - WORK VECTOR OF LENGTH N C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT C IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT C THE MATRIX IS SINGULAR. C C .................................................................. C SUBROUTINE MINV(A,N,D,L,M) DIMENSION A(1),L(1),M(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,D,BIGA,HOLD C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. ABS IN STATEMENT C 10 MUST BE CHANGED TO DABS. C C ............................................................... C C SEARCH FOR LARGEST ELEMENT C D=1.0 NK=-N DO 80 K=1,N NK=NK+N L(K)=K M(K)=K KK=NK+K BIGA=A(KK) DO 20 J=K,N IZ=N*(J-1) DO 20 I=K,N IJ=IZ+I 10 IF( ABS(BIGA)- ABS(A(IJ))) 15,20,20 15 BIGA=A(IJ) L(K)=I M(K)=J 20 CONTINUE C C INTERCHANGE ROWS C J=L(K) IF(J-K) 35,35,25 25 KI=K-N DO 30 I=1,N KI=KI+N HOLD=-A(KI) JI=KI-K+J A(KI)=A(JI) 30 A(JI) =HOLD C C INTERCHANGE COLUMNS C 35 I=M(K) IF(I-K) 45,45,38 38 JP=N*(I-1) DO 40 J=1,N JK=NK+J JI=JP+J HOLD=-A(JK) A(JK)=A(JI) 40 A(JI) =HOLD C C DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS C CONTAINED IN BIGA) C 45 IF(BIGA) 48,46,48 46 D=0.0 RETURN 48 DO 55 I=1,N IF(I-K) 50,55,50 50 IK=NK+I A(IK)=A(IK)/(-BIGA) 55 CONTINUE C C REDUCE MATRIX C DO 65 I=1,N IK=NK+I HOLD=A(IK) IJ=I-N DO 65 J=1,N IJ=IJ+N IF(I-K) 60,65,60 60 IF(J-K) 62,65,62 62 KJ=IJ-I+K A(IJ)=HOLD*A(KJ)+A(IJ) 65 CONTINUE C C DIVIDE ROW BY PIVOT C KJ=K-N DO 75 J=1,N KJ=KJ+N IF(J-K) 70,75,70 70 A(KJ)=A(KJ)/BIGA 75 CONTINUE C C PRODUCT OF PIVOTS C D=D*BIGA C C REPLACE PIVOT BY RECIPROCAL C A(KK)=1.0/BIGA 80 CONTINUE C C FINAL ROW AND COLUMN INTERCHANGE C K=N 100 K=(K-1) IF(K) 150,150,105 105 I=L(K) IF(I-K) 120,120,108 108 JQ=N*(K-1) JR=N*(I-1) DO 110 J=1,N JK=JQ+J HOLD=A(JK) JI=JR+J A(JK)=-A(JI) 110 A(JI) =HOLD 120 J=M(K) IF(J-K) 100,100,125 125 KI=K-N DO 130 I=1,N KI=KI+N HOLD=A(KI) JI=KI-K+J A(KI)=-A(JI) 130 A(JI) =HOLD GO TO 100 150 RETURN END C C .................................................................. C C SUBROUTINE MISR C C PURPOSE C COMPUTE MEANS, STANDARD DEVIATIONS, SKEWNESS AND KURTOSIS, C CORRELATION COEFFICIENTS, REGRESSION COEFFICIENTS, AND C STANDARD ERRORS OF REGRESSION COEFFICIENTS WHEN THERE ARE C MISSING DATA POINTS. THE USER IDENTIFIES THE MISSING DATA C BY MEANS OF A NUMERIC CODE. THOSE VALUES HAVING THIS CODE C ARE SKIPPED IN COMPUTING THE STATISTICS. IN THE CASE OF THE C CORRELATION COEFFICIENTS, ANY PAIR OF VALUES ARE SKIPPED IF C EITHER ONE OF THEM ARE MISSING. C C USAGE C CALL MISR (NO,M,X,CODE,XBAR,STD,SKEW,CURT,R,N,A,B,S,IER) C C DESCRIPTION OF PARAMETERS C NO - NUMBER OF OBSERVATIONS C M - NUMBER OF VARIABLES C X - INPUT DATA MATRIX OF SIZE NO X M. C CODE - INPUT VECTOR OF LENGTH M, WHICH CONTAINS A NUMERIC C MISSING DATA CODE FOR EACH VARIABLE. ANY OBSERVATION C FOR A GIVEN VARIABLE HAVING A VALUE EQUAL TO THE CODE C WILL BE DROPPED FOR THE COMPUTATIONS. C XBAR - OUTPUT VECTOR OF LENGTH M CONTAINING MEANS C STD - OUTPUT VECTOR OF LENGTH M CONTAINING STANDARD DEVI- C ATIONS C SKEW - OUTPUT VECTOR OF LENGTH M CONTAINING SKEWNESS C CURT - OUTPUT VECTOR OF LENGTH M CONTAINING KURTOSIS C R - OUTPUT MATRIX OF PRODUCT-MOMENT CORRELATION C COEFFICIENTS. THIS WILL BE THE UPPER TRIANGULAR C MATRIX ONLY, SINCE THE M X M MATRIX OF COEFFICIENTS C IS SYMMETRIC. (STORAGE MODE 1) C N - OUTPUT MATRIX OF NUMBER OF PAIRS OF OBSERVATIONS USED C IN COMPUTING THE CORRELATION COEFFICIENTS. ONLY THE C UPPER TRIANGULAR PORTION OF THE MATRIX IS GIVEN. C (STORAGE MODE 1) C A - OUTPUT MATRIX (M BY M) CONTAINING INTERCEPTS OF C REGRESSION LINES (A) OF THE FORM Y=A+BX. THE FIRST C SUBSCRIPT OF THIS MATRIX REFERS TO THE INDEPENDENT C VARIABLE AND THE SECOND TO THE DEPENDENT VARIABLE. C FOR EXAMPLE, A(1,3) CONTAINS THE INTERCEPT OF THE C REGRESSION LINE FOR TWO VARIABLES WHERE VARIABLE 1 C IS INDEPENDENT AND VARIABLE 3 IS DEPENDENT. NOTE C THAT MATRIX A IS STORED IN A VECTOR FORM. C B - OUTPUT MATRIX (M BY M) CONTAINING REGRESSION C COEFFICIENTS (B) CORRESPONDING TO THE VALUES OF C INTERCEPTS CONTAINED IN THE OUTPUT MATRIX A. C S - OUTPUT MATRIX (M BY M) CONTAINING STANDARD ERRORS C OF REGRESSION COEFFICIENTS CORRESPONDING TO THE C COEFFICIENTS CONTAINED IN THE OUTPUT MATRIX B. C IER - 0, NO ERROR. C 1, IF NUMBER OF NON-MISSING DATA ELEMENTS FOR J-TH C VARIABLE IS TWO OR LESS. IN THIS CASE, STD(J), C SKEW(J), AND CURT(J) ARE SET TO 10**75. ALL C VALUES OF R, A, B, AND S RELATED TO THIS VARIABLE C ARE ALSO SET TO 10**75. C 2, IF VARIANCE OF J-TH VARIABLE IS LESS THAN C 10**(-20). IN THIS CASE, STD(J), SKEW(J), AND C CURT(J) ARE SET TO 10**75. ALL VALUES OF R, A, C B, AND S RELATED TO THIS VARIABLE ARE ALSO SET TO C 10**75. C C REMARKS C THIS SUBROUTINE CANNOT DISTINGUISH A BLANK AND A ZERO. C THEREFORE, IF A BLANK IS SPECIFIED AS A MISSING DATA CODE IN C INPUT CARDS, IT WILL BE TREATED AS 0 (ZERO). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C LEAST SQUARES REGRESSION LINES AND PRODUCT-MOMENT CORRE- C LATION COEFFICIENTS ARE COMPUTED. C C .................................................................. C SUBROUTINE MISR (NO,M,X,CODE,XBAR,STD,SKEW,CURT,R,N,A,B,S,IER) C DIMENSION X(1),CODE(1),XBAR(1),STD(1),SKEW(1),CURT(1),R(1),N(1) DIMENSION A(1),B(1),S(1) C C COMPUTE MEANS C IER=0 L=0 DO 20 J=1,M FN=0.0 XBAR(J)=0.0 DO 15 I=1,NO L=L+1 IF(X(L)-CODE(J)) 12, 15, 12 12 FN=FN+1.0 XBAR(J)=XBAR(J)+X(L) 15 CONTINUE IF(FN) 16, 16, 17 16 XBAR(J)=0.0 GO TO 20 17 XBAR(J)=XBAR(J)/FN 20 CONTINUE C C SET-UP WORK AREAS AND TEST WHETHER DATA IS MISSING C L=0 DO 55 J=1,M LJJ=NO*(J-1) SKEW(J)=0.0 CURT(J)=0.0 KI=M*(J-1) KJ=J-M DO 54 I=1,J KI=KI+1 KJ=KJ+M SUMX=0.0 SUMY=0.0 TI=0.0 TJ=0.0 TII=0.0 TJJ=0.0 TIJ=0.0 NIJ=0 LI=NO*(I-1) LJ=LJJ L=L+1 DO 38 K=1,NO LI=LI+1 LJ=LJ+1 IF(X(LI)-CODE(I)) 30, 38, 30 30 IF(X(LJ)-CODE(J)) 35, 38, 35 C C BOTH DATA ARE PRESENT C 35 XX=X(LI)-XBAR(I) YY=X(LJ)-XBAR(J) TI=TI+XX TII=TII+XX**2 TJ=TJ+YY TJJ=TJJ+YY**2 TIJ=TIJ+XX*YY NIJ=NIJ+1 SUMX=SUMX+X(LI) SUMY=SUMY+X(LJ) IF(I-J) 38, 37, 37 37 SKEW(J)=SKEW(J)+YY**3 CURT(J)=CURT(J)+YY**4 38 CONTINUE C C COMPUTE SUM OF CROSS-PRODUCTS OF DEVIATIONS C IF(NIJ) 40, 40, 39 39 FN=NIJ R(L)=TIJ-TI*TJ/FN N(L)=NIJ TII=TII-TI*TI/FN TJJ=TJJ-TJ*TJ/FN C C COMPUTE STANDARD DEVIATION, SKEWNESS, AND KURTOSIS C 40 IF(I-J) 47, 41, 47 41 IF(NIJ-2) 42,42,43 42 IER=1 R(L)=1.7E38 A(KI)=1.7E38 B(KI)=1.7E38 S(KI)=1.7E38 GO TO 45 C 43 STD(J)=R(L) R(L)=1.0 A(KI)=0.0 B(KI)=1.0 S(KI)=0.0 C IF(STD(J)-(1.0E-20)) 44,44,46 44 IER=2 45 STD(J)=1.7E38 SKEW(J)=1.7E38 CURT(J)=1.7E38 GO TO 55 C 46 WORK=STD(J)/FN SKEW(J)=(SKEW(J)/FN)/(WORK*SQRT(WORK)) CURT(J)=((CURT(J)/FN)/WORK**2)-3.0 STD(J)=SQRT(STD(J)/(FN-1.0)) GO TO 55 C C COMPUTE REGRESSION COEFFICIENTS C 47 IF(NIJ-2) 48,48,50 48 IER=1 49 R(L)=1.7E38 A(KI)=1.7E38 B(KI)=1.7E38 S(KI)=1.7E38 A(KJ)=1.7E38 B(KJ)=1.7E38 S(KJ)=1.7E38 GO TO 54 C 50 IF(TII-(1.0E-20)) 52,52,51 51 IF(TJJ-(1.0E-20)) 52,52,53 52 IER=2 GO TO 49 C 53 SUMX=SUMX/FN SUMY=SUMY/FN B(KI)=R(L)/TII A(KI)=SUMY-B(KI)*SUMX B(KJ)=R(L)/TJJ A(KJ)=SUMX-B(KJ)*SUMY C C COMPUTE CORRELATION COEFFICIENTS C R(L)=R(L)/(SQRT(TII)*SQRT(TJJ)) C C COMPUTE STANDARD ERRORS OF REGRESSION COEFFICIENTS C RR=R(L)**2 SUMX=(TJJ-TJJ*RR)/(FN-2) S(KI)=SQRT(SUMX/TII) SUMY=(TII-TII*RR)/(FN-2) S(KJ)=SQRT(SUMY/TJJ) C 54 CONTINUE 55 CONTINUE C RETURN END C C .................................................................. C C SUBROUTINE MLSS C C PURPOSE C SUBROUTINE MLSS IS THE SECOND STEP IN THE PROCEDURE FOR C CALCULATING THE LEAST SQUARES SOLUTION OF MINIMAL LENGTH C OF A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH SYMMETRIC C POSITIVE SEMI-DEFINITE COEFFICIENT MATRIX. C C USAGE C CALL MLSS(A,N,IRANK,TRAC,INC,RHS,IER) C C DESCRIPTION OF PARAMETERS C A - COEFFICIENT MATRIX IN FACTORED FORM AS GENERATED C BY SUBROUTINE MFSS FROM INITIALLY GIVEN SYMMETRIC C COEFFICIENT MATRIX A STORED IN N*(N+1)/2 LOCATIONS C A REMAINS UNCHANGED C N - DIMENSION OF COEFFICIENT MATRIX C IRANK - RANK OF COEFFICIENT MATRIX, CALCULATED BY MEANS OF C SUBROUTINE MFSS C TRAC - VECTOR OF DIMENSION N CONTAINING THE C SUBSCRIPTS OF PIVOT ROWS AND COLUMNS, I.E. THE C PRODUCT REPRESENTATION IN TRANSPOSITIONS OF THE C PERMUTATION WHICH WAS APPLIED TO ROWS AND COLUMNS C OF A IN THE FACTORIZATION PROCESS C TRAC IS A RESULTANT ARRAY OF SUBROUTINE MFSS C INC - INPUT VARIABLE WHICH SHOULD CONTAIN THE VALUE ZERO C IF THE SYSTEM OF SIMULTANEOUS EQUATIONS IS KNOWN C TO BE COMPATIBLE AND A NONZERO VALUE OTHERWISE C RHS - VECTOR OF DIMENSION N CONTAINING THE RIGHT HAND SIDE C ON RETURN RHS CONTAINS THE MINIMAL LENGTH SOLUTION C IER - RESULTANT ERROR PARAMETER C IER = 0 MEANS NO ERRORS C IER =-1 MEANS N AND/OR IRANK IS NOT POSITIVE AND/OR C IRANK IS GREATER THAN N C IER = 1 MEANS THE FACTORIZATION CONTAINED IN A HAS C ZERO DIVISORS AND/OR TRAC CONTAINS C VALUES OUTSIDE THE FEASIBLE RANGE 1 UP TO N C C REMARKS C THE MINIMAL LENGTH SOLUTION IS PRODUCED IN THE STORAGE C LOCATIONS OCCUPIED BY THE RIGHT HAND SIDE. C SUBROUTINE MLSS DOES TAKE CARE OF THE PERMUTATION C WHICH WAS APPLIED TO ROWS AND COLUMNS OF A. C OPERATION IS BYPASSED IN CASE OF A NON POSITIVE VALUE C OF IRANK C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C LET T, U, TU BE THE COMPONENTS OF THE FACTORIZATION OF A, C AND LET THE RIGHT HAND SIDE BE PARTITIONED INTO A FIRST C PART X1 OF DIMENSION IRANK AND A SECOND PART X2 OF DIMENSION C N-IRANK. THEN THE FOLLOWING OPERATIONS ARE APPLIED IN C SEQUENCE C (1) INTERCHANGE RIGHT HAND SIDE C (2) X1 = X1 + U * X2 C (3) X2 =-TRANSPOSE(U) * X1 C (4) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2 C (5) X1 = X1 + U * X2 C (6) X1 = INVERSE(T) * INVERSE(TRANSPOSE(T)) * X1 C (7) X2 =-TRANSPOSE(U) * X1 C (8) X2 = INVERSE(TU) * INVERSE(TRANSPOSE(TU)) * X2 C (9) X1 = X1 + U * X2 C (10)X2 = TRANSPOSE(U) * X1 C (11) REINTERCHANGE CALCULATED SOLUTION C IF THE SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS IS SPECIFIED C TO BE COMPATIBLE THEN STEPS (2), (3), (4) AND (5) ARE C CANCELLED. C IF THE COEFFICIENT MATRIX HAS RANK N, THEN THE ONLY STEPS C PERFORMED ARE (1), (6) AND (11). C C .................................................................. C SUBROUTINE MLSS(A,N,IRANK,TRAC,INC,RHS,IER) C C C DIMENSIONED DUMMY VARIABLES DIMENSION A(1),TRAC(1),RHS(1) DOUBLE PRECISION SUM C C TEST OF SPECIFIED DIMENSIONS IDEF=N-IRANK IF(N)33,33,1 1 IF(IRANK)33,33,2 2 IF(IDEF)33,3,3 C C CALCULATE AUXILIARY VALUES 3 ITE=IRANK*(IRANK+1)/2 IX2=IRANK+1 NP1=N+1 IER=0 C C INTERCHANGE RIGHT HAND SIDE JJ=1 II=1 4 DO 6 I=1,N J=TRAC(II) IF(J)31,31,5 5 HOLD=RHS(II) RHS(II)=RHS(J) RHS(J)=HOLD 6 II=II+JJ IF(JJ)32,7,7 C C PERFORM STEP 2 IF NECESSARY 7 ISW=1 IF(INC*IDEF)8,28,8 C C CALCULATE X1 = X1 + U * X2 8 ISTA=ITE DO 10 I=1,IRANK ISTA=ISTA+1 JJ=ISTA SUM=0.D0 DO 9 J=IX2,N SUM=SUM+A(JJ)*RHS(J) 9 JJ=JJ+J 10 RHS(I)=RHS(I)+SUM GOTO(11,28,11),ISW C C CALCULATE X2 = TRANSPOSE(U) * X1 11 ISTA=ITE DO 15 I=IX2,N JJ=ISTA SUM=0.D0 DO 12 J=1,IRANK JJ=JJ+1 12 SUM=SUM+A(JJ)*RHS(J) GOTO(13,13,14),ISW 13 SUM=-SUM 14 RHS(I)=SUM 15 ISTA=ISTA+I GOTO(16,29,30),ISW C C INITIALIZE STEP (4) OR STEP (8) 16 ISTA=IX2 IEND=N JJ=ITE+ISTA C C DIVISION OF X1 BY TRANSPOSE OF TRIANGULAR MATRIX 17 SUM=0.D0 DO 20 I=ISTA,IEND IF(A(JJ))18,31,18 18 RHS(I)=(RHS(I)-SUM)/A(JJ) IF(I-IEND)19,21,21 19 JJ=JJ+ISTA SUM=0.D0 DO 20 J=ISTA,I SUM=SUM+A(JJ)*RHS(J) 20 JJ=JJ+1 C C DIVISION OF X1 BY TRIANGULAR MATRIX 21 SUM=0.D0 II=IEND DO 24 I=ISTA,IEND RHS(II)=(RHS(II)-SUM)/A(JJ) IF(II-ISTA)25,25,22 22 KK=JJ-1 SUM=0.D0 DO 23 J=II,IEND SUM=SUM+A(KK)*RHS(J) 23 KK=KK+J JJ=JJ-II 24 II=II-1 25 IF(IDEF)26,30,26 26 GOTO(27,11,8),ISW C C PERFORM STEP (5) 27 ISW=2 GOTO 8 C C PERFORM STEP (6) 28 ISTA=1 IEND=IRANK JJ=1 ISW=2 GOTO 17 C C PERFORM STEP (8) 29 ISW=3 GOTO 16 C C REINTERCHANGE CALCULATED SOLUTION 30 II=N JJ=-1 GOTO 4 C C ERROR RETURN IN CASE OF ZERO DIVISOR 31 IER=1 32 RETURN C C ERROR RETURN IN CASE OF ILLEGAL DIMENSION 33 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE MOMEN C C PURPOSE C TO FIND THE THE FIRST FOUR MOMENTS FOR GROUPED DATA ON C EQUAL CLASS INTERVALS. C C USAGE C CALL MOMEN (F,UBO,NOP,ANS) C C DESCRIPTION OF PARAMETERS C F - GROUPED DATA (FREQUENCIES). GIVEN AS A VECTOR OF C LENGTH (UBO(3)-UBO(1))/UBO(2) C UBO - 3 CELL VECTOR, UBO(1) IS LOWER BOUND AND UBO(3) UPPER C BOUND ON DATA. UBO(2) IS CLASS INTERVAL. NOTE THAT C UBO(3) MUST BE GREATER THAN UBO(1). C NOP - OPTION PARAMETER. IF NOP = 1, ANS(1) = MEAN. IF C NOP = 2, ANS(2) = SECOND MOMENT. IF NOP = 3, ANS(3) = C THIRD MOMENT. IF NOP = 4, ANS(4) = FOURTH MOMENT. C IF NOP = 5, ALL FOUR MOMENTS ARE FILLED IN. C ANS - OUTPUT VECTOR OF LENGTH 4 INTO WHICH MOMENTS ARE PUT. C C REMARKS C NOTE THAT THE FIRST MOMENT IS NOT CENTRAL BUT THE VALUE OF C THE MEAN ITSELF. THE MEAN IS ALWAYS CALCULATED. MOMENTS C ARE BIASED AND NOT CORRECTED FOR GROUPING. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO M. G. KENDALL, 'THE ADVANCED THEORY OF STATISTICS', C V.1, HAFNER PUBLISHING COMPANY, 1958, CHAPTER 3. C C .................................................................. C SUBROUTINE MOMEN (F,UBO,NOP,ANS) DIMENSION F(1),UBO(1),ANS(1) C DO 100 I=1,4 100 ANS(I)=0.0 C C CALCULATE THE NUMBER OF CLASS INTERVALS C N=(UBO(3)-UBO(1))/UBO(2)+0.5 C C CALCULATE TOTAL FREQUENCY C T=0.0 DO 110 I=1,N 110 T=T+F(I) C IF(NOP-5) 130, 120, 115 115 NOP=5 120 JUMP=1 GO TO 150 130 JUMP=2 C C FIRST MOMENT C 150 DO 160 I=1,N FI=I 160 ANS(1)=ANS(1)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)) ANS(1)=ANS(1)/T C GO TO (350,200,250,300,200), NOP C C SECOND MOMENT C 200 DO 210 I=1,N FI=I 210 ANS(2)=ANS(2)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**2 ANS(2)=ANS(2)/T GO TO (250,350), JUMP C C THIRD MOMENT C 250 DO 260 I=1,N FI=I 260 ANS(3)=ANS(3)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**3 ANS(3)=ANS(3)/T GO TO (300,350), JUMP C C FOURTH MOMENT C 300 DO 310 I=1,N FI=I 310 ANS(4)=ANS(4)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**4 ANS(4)=ANS(4)/T 350 RETURN END C C .................................................................. C C SUBROUTINE MPAIR C C PURPOSE C PERFORM THE WILCOXON MATCHED-PAIRS SIGNED-RANKS TEST, GIVEN C TWO VECTORS OF N OBSERVATIONS OF THE MATCHED SAMPLES. C C USAGE C CALL MPAIR (N,A,B,K,T,Z,P,D,E,L,IE) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS IN THE VECTORS A AND B C A - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE FIRST C SAMPLE C B - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE SECOND C SAMPLE C K - OUTPUT VARIABLE CONTAINING THE NUMBER OF PAIRS OF THE C MATCHED SAMPLES WHOSE DIFFERENCES ARE NON ZERO (0) C T - OUTPUT VARIABLE CONTAINING THE SUM OF THE RANKS OF PLUS C OR MINUS DIFFERENCES, WHICHEVER IS SMALLER C Z - VALUE OF THE STANDARDIZED NORMAL SCORE COMPUTED FOR THE C WILCOXON MATCHED-PAIRS SIGNED-RANKS TEST C P - COMPUTED PROBABILITY OF OBTAINING A VALUE OF Z AS C EXTREME AS THE ONE FOUND BY THE TEST C D - WORKING VECTOR OF LENGTH N C E - WORKING VECTOR OF LENGTH N C L - WORKING VECTOR OF LENGTH N C IE- 1, IF SAMPLES A AND B ARE IDENTICAL. C 0 OTHERWISE. IF IE=1, THEN T=P=0, AND Z=-10**75 C C REMARKS C THE COMPUTED PROBABILTY IS FOR A ONE-TAILED TEST. C MULTIPLYING P BY 2 WILL GIVE THE VALUE FOR A TWO-TAILED C TEST. C C SUBROUTINES AND FUNCTIONS SUBPROGRAMS REQUIRED C RANK C NDTR C C METHOD C REFER TO DIXON AND MASSEY, AN INTRODUCTION TO STATISTICAL C ANALYSIS (MC GRAW-HILL, 1957) C C .................................................................. C SUBROUTINE MPAIR (N,A,B,K,T,Z,P,D,E,L,IE) C DIMENSION A(1),B(1),D(1),E(1),L(1) C IE=0 K=N C C FIND DIFFERENCES OF MATCHED-PAIRS C BIG=0.0 DO 55 I=1,N DIF=A(I)-B(I) IF(DIF) 10, 20, 30 C C DIFFERENCE HAS A NEGATIVE SIGN (-) C 10 L(I)=1 GO TO 40 C C DIFFERENCE IS ZERO (0) C 20 L(I)=2 K=K-1 GO TO 40 C C DIFFERENCE HAS A POSITIVE SIGN (+) C 30 L(I)=3 C 40 DIF= ABS(DIF) IF(BIG-DIF) 45, 50, 50 45 BIG=DIF 50 D(I)=DIF C 55 CONTINUE IF(K) 57,57,59 57 IE=1 T=0.0 Z=-1.7E38 P=0 GO TO 100 C C STORE A LARGE VALUE IN PLACE OF 0 DIFFERENCE IN ORDER TO C ASSIGN A LARGE RANK (LARGER THAN K), SO THAT ABSOLUTE VALUES C OF SIGNED DIFFERENCES WILL BE PROPERLY RANKED C 59 BIG=BIG*2.0 DO 65 I=1,N IF(L(I)-2) 65, 60, 65 60 D(I)=BIG 65 CONTINUE C CALL RANK (D,E,N) C C FIND SUMS OF RANKS OF (+) DIFFERENCES AND (-) DIFFERENCES C SUMP=0.0 SUMM=0.0 DO 80 I=1,N IF(L(I)-2) 70, 80, 75 70 SUMM=SUMM+E(I) GO TO 80 75 SUMP=SUMP+E(I) 80 CONTINUE C C SET T = SMALLER SUM C IF(SUMP-SUMM) 85, 85, 90 85 T=SUMP GO TO 95 90 T=SUMM C C COMPUTE MEAN, STANDARD DEVIATION, AND Z C 95 FK=K U=FK*(FK+1.0)/4.0 S= SQRT((FK*(FK+1.0)*(2.0*FK+1.0))/24.0) Z=(T-U)/S C C COMPUTE THE PROBABILITY OF A VALUE AS EXTREME AS Z C CALL NDTR (Z,P,BIG) C 100 RETURN END C C .................................................................. C C SUBROUTINE MPRC C C PURPOSE C TO PERMUTE THE ROWS OR COLUMNS OF A GIVEN MATRIX ACCORDING C TO A GIVEN TRANSPOSITION VECTOR OR ITS INVERSE. (SEE THE C DISCUSSION ON PERMUTATIONS FOR DEFINITIONS AND NOTATION.) C C USAGE C CALL MPRC(A,M,N,ITRA,INV,IROCO,IER) C C DESCRIPTION OF PARAMETERS C A - GIVEN M BY N MATRIX AND RESULTING PERMUTED MATRIX C M - NUMBER OF ROWS OF A C N - NUMBER OF COLUMNS OF A C ITRA - GIVEN TRANSPOSITION VECTOR (DIMENSION M IF ROWS ARE C PERMUTED, N IF COLUMNS ARE PERMUTED) C INV - INPUT PARAMETER C INV NON-ZERO - PERMUTE ACCORDING TO ITRA C INV = 0 - PERMUTE ACCORDING TO ITRA INVERSE C IROCO - INPUT PARAMETER C IROCO NON-ZERO - PERMUTE THE COLUMNS OF A C IROCO = 0 - PERMUTE THE ROWS OF A C IER - RESULTING ERROR PARAMETER C IER = -1 - M AND N ARE NOT BOTH POSITIVE C IER = 0 - NO ERROR C IER = 1 - ITRA IS NOT A TRANSPOSITION VECTOR ON C 1,...,M IF ROWS ARE PERMUTED, 1,...,N C IF COLUMNS ARE PERMUTED C C REMARKS C (1) IF IER=-1 THERE IS NO COMPUTATION. C (2) IF IER= 1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE C TO ERROR, BUT THE MATRIX A WILL REFLECT THE ROW OR C COLUMN INTERCHANGES PERFORMED BEFORE THE ERROR WAS C DETECTED. C (3) THE MATRIX A IS ASSUMED TO BE STORED COLUMNWISE. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C THE ROWS OR COLUMNS ARE PERMUTED ELEMENTWISE, INTERCHANGING C ROW OR COLUMN 1 AND ITRA(1),...,ROW OR COLUMN K AND ITRA(K) C IN THAT ORDER IF INV=0, AND OTHERWISE INTERCHANGING ROW OR C COLUMN K AND ITRA(K),...,ROW OR COLUMN 1 AND ITRA(1), WHERE C K IS M OR N DEPENDING ON WHETHER WE PERMUTE ROWS OR COLUMNS. C C .................................................................. C SUBROUTINE MPRC(A,M,N,ITRA,INV,IROCO,IER) C C DIMENSION A(1),ITRA(1) C C TEST OF DIMENSIONS IF(M)14,14,1 1 IF(N)14,14,2 C C DETERMINE WHICH ARE TO BE PERMUTED-THE ROWS OR THE COLUMNS 2 IF(IROCO)3,4,3 C C INITIALIZE FOR COLUMN INTERCHANGES 3 MM=M MMM=-1 L=M LL=N GO TO 5 C C INITIALIZE FOR ROW INTERCHANGES 4 MM=1 MMM=M L=N LL=M C C INITIALIZE LOOP OVER ALL ROWS OR COLUMNS 5 IA=1 ID=1 C C TEST FOR INVERSE OPERATION IF(INV)6,7,6 6 IA=LL ID=-1 7 DO 12 I=1,LL K=ITRA(IA) IF(K-IA)8,12,9 8 IF(K)13,13,10 9 IF(LL-K)13,10,10 C C INITIALIZE ROW OR COLUMN INTERCHANGE 10 IL=IA*MM K=K*MM C C PERFORM ROW OR COLUMN INTERCHANGE DO 11 J=1,L SAVE=A(IL) A(IL)=A(K) A(K)=SAVE K=K+MMM 11 IL=IL+MMM C C ADDRESS NEXT INTERCHANGE STEP 12 IA=IA+ID C C NORMAL EXIT IER=0 RETURN C C ERROR RETURN IN CASE ITRA IS NOT A TRANSPOSITION VECTOR 13 IER=1 RETURN C C ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS 14 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE MPRD C C PURPOSE C MULTIPLY TWO MATRICES TO FORM A RESULTANT MATRIX C C USAGE C CALL MPRD(A,B,R,N,M,MSA,MSB,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A AND R C M - NUMBER OF COLUMNS IN A AND ROWS IN B C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C L - NUMBER OF COLUMNS IN B AND R C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B C NUMBER OF COLUMNS OF MATRIX A MUST BE EQUAL TO NUMBER OF ROW C OF MATRIX B C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C THE M BY L MATRIX B IS PREMULTIPLIED BY THE N BY M MATRIX A C AND THE RESULT IS STORED IN THE N BY L MATRIX R. THIS IS A C ROW INTO COLUMN PRODUCT. C THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT C MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES C A B R C GENERAL GENERAL GENERAL C GENERAL SYMMETRIC GENERAL C GENERAL DIAGONAL GENERAL C SYMMETRIC GENERAL GENERAL C SYMMETRIC SYMMETRIC GENERAL C SYMMETRIC DIAGONAL GENERAL C DIAGONAL GENERAL GENERAL C DIAGONAL SYMMETRIC GENERAL C DIAGONAL DIAGONAL DIAGONAL C C .................................................................. C SUBROUTINE MPRD(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) C C SPECIAL CASE FOR DIAGONAL BY DIAGONAL C MS=MSA*10+MSB IF(MS-22) 30,10,30 10 DO 20 I=1,N 20 R(I)=A(I)*B(I) RETURN C C ALL OTHER CASES C 30 IR=1 DO 90 K=1,L DO 90 J=1,N R(IR)=0 DO 80 I=1,M IF(MS) 40,60,40 40 CALL LOC(J,I,IA,N,M,MSA) CALL LOC(I,K,IB,M,L,MSB) IF(IA) 50,80,50 50 IF(IB) 70,80,70 60 IA=N*(I-1)+J IB=M*(K-1)+I 70 R(IR)=R(IR)+A(IA)*B(IB) 80 CONTINUE 90 IR=IR+1 RETURN END C C .................................................................. C C SUBROUTINE MSTR C C PURPOSE C CHANGE STORAGE MODE OF A MATRIX C C USAGE C CALL MSTR(A,R,N,MSA,MSR) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS AND COLUMNS IN A AND R C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSR - SAME AS MSA EXCEPT FOR MATRIX R C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX A MUST BE A SQUARE MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C MATRIX A IS RESTRUCTURED TO FORM MATRIX R. C MSA MSR C 0 0 MATRIX A IS MOVED TO MATRIX R C 0 1 THE UPPER TRIANGLE ELEMENTS OF A GENERAL MATRIX C ARE USED TO FORM A SYMMETRIC MATRIX C 0 2 THE DIAGONAL ELEMENTS OF A GENERAL MATRIX ARE USED C TO FORM A DIAGONAL MATRIX C 1 0 A SYMMETRIC MATRIX IS EXPANDED TO FORM A GENERAL C MATRIX C 1 1 MATRIX A IS MOVED TO MATRIX R C 1 2 THE DIAGONAL ELEMENTS OF A SYMMETRIC MATRIX ARE C USED TO FORM A DIAGONAL MATRIX C 2 0 A DIAGONAL MATRIX IS EXPANDED BY INSERTING MISSING C ZERO ELEMENTS TO FORM A GENERAL MATRIX C 2 1 A DIAGONAL MATRIX IS EXPANDED BY INSERTING MISSING C ZERO ELEMENTS TO FORM A SYMMETRIC MATRIX C 2 2 MATRIX A IS MOVED TO MATRIX R C C .................................................................. C SUBROUTINE MSTR(A,R,N,MSA,MSR) DIMENSION A(1),R(1) C C .................................................................. C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,R C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C .................................................................. C DO 20 I=1,N DO 20 J=1,N C C IF R IS GENERAL, FORM ELEMENT C IF(MSR) 5,10,5 C C IF IN LOWER TRIANGLE OF SYMMETRIC OR DIAGONAL R, BYPASS C 5 IF(I-J) 10,10,20 10 CALL LOC(I,J,IR,N,N,MSR) C C IF IN UPPER AND OFF DIAGONAL OF DIAGONAL R, BYPASS C IF(IR) 20,20,15 C C OTHERWISE, FORM R(I,J) C 15 R(IR)=0.0 CALL LOC(I,J,IA,N,N,MSA) C C IF THERE IS NO A(I,J), LEAVE R(I,J) AT 0.0 C IF(IA) 20,20,18 18 R(IR)=A(IA) 20 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE MSUB C C PURPOSE C SUBTRACT TWO MATRICES ELEMENT BY ELEMENT TO FORM RESULTANT C MATRIX C C USAGE C CALL MSUB(A,B,R,N,M,MSA,MSB) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C B - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A,B,R C M - NUMBER OF COLUMNS IN A,B,R C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C STRUCTURE OF OUTPUT MATRIX IS FIRST DETERMINED. SUBTRACTION C OF MATRIX B ELEMENTS FROM CORRESPONDING MATRIX A ELEMENTS C IS THEN PERFORMED. C THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT C MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES C A B R C GENERAL GENERAL GENERAL C GENERAL SYMMETRIC GENERAL C GENERAL DIAGONAL GENERAL C SYMMETRIC GENERAL GENERAL C SYMMETRIC SYMMETRIC SYMMETRIC C SYMMETRIC DIAGONAL SYMMETRIC C DIAGONAL GENERAL GENERAL C DIAGONAL SYMMETRIC SYMMETRIC C DIAGONAL DIAGONAL DIAGONAL C C .................................................................. C SUBROUTINE MSUB(A,B,R,N,M,MSA,MSB) DIMENSION A(1),B(1),R(1) C C DETERMINE STORAGE MODE OF OUTPUT MATRIX C IF(MSA-MSB) 7,5,7 5 CALL LOC(N,M,NM,N,M,MSA) GO TO 100 7 MTEST=MSA*MSB MSR=0 IF(MTEST) 20,20,10 10 MSR=1 20 IF(MTEST-2) 35,35,30 30 MSR=2 C C LOCATE ELEMENTS AND PERFORM SUBTRACTION C 35 DO 90 J=1,M DO 90 I=1,N CALL LOC(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL LOC(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL LOC(I,J,IJB,N,M,MSB) BEL=0.0 IF(IJB) 70,80,70 70 BEL=B(IJB) 80 R(IJR)=AEL-BEL 90 CONTINUE RETURN C C SUBTRACT MATRICES FOR OTHER CASES C 100 DO 110 I=1,NM 110 R(I)=A(I)-B(I) RETURN END C C .................................................................. C C SUBROUTINE MTDS C C PURPOSE C MULTIPLY A GENERAL MATRIX A ON THE LEFT OR RIGHT BY C INVERSE(T),INVERSE(TRANSPOSE(T)) OR INVERSE(TRANSPOSE(T*T)) C THE TRIANGULAR MATRIX T IS STORED COLUMNWISE IN COMPRESSED C FORM, I.E. UPPER TRIANGULAR PART ONLY. C C USAGE C CALL MTDS(A,M,N,T,IOP,IER) C C DESCRIPTION OF PARAMETERS C A - GIVEN GENERAL MATRIX WHITH M ROWS AND N COLUMNS. C M - NUMBER OF ROWS OF MATRIX A C N - NUMBER OF COLUMNS OF MATRIX A C T - GIVEN TRIANGULAR MATRIX STORED COLUMNWISE UPPER C TRIANGULAR PART ONLY. ITS NUMBER OF ROWS AND C COLUMNS K IS IMPLIED BY COMPATIBILITY. C K = M IF IOP IS POSITIVE, C K = N IF IOP IS NEGATIVE. C T OCCUPIES K*(K+1)/2 STORAGE POSITIONS. C IOP - INPUT VARIABLE FOR SELECTION OF OPERATION C IOP = 1 - A IS REPLACED BY INVERSE(T)*A C IOP =-1 - A IS REPLACED BY A*INVERSE(T) C IOP = 2 - A IS REPLACED BY INVERSE(TRANSPOSE(T))*A C IOP =-2 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)) C IOP = 3 - A IS REPLACED BY INVERSE(TRANSPOSE(T)*T)*A C IOP =-3 - A IS REPLACED BY A*INVERSE(TRANSPOSE(T)*T) C IER - RESULTING ERROR PARAMETER C IER =-1 MEANS M AND N ARE NOT BOTH POSITIVE C AND/OR IOP IS ILLEGAL C IER = 0 MEANS OPERATION WAS SUCCESSFUL C IER = 1 MEANS TRIANGULAR MATRIX T IS SINGULAR C C REMARKS C SUBROUTINE MTDS MAY BE USED TO CALCULATE THE SOLUTION OF C A SYSTEM OF EQUATIONS WITH SYMMETRIC POSITIVE DEFINITE C COEFFICIENT MATRIX. THE FIRST STEP TOWARDS THE SOLUTION C IS TRIANGULAR FACTORIZATION BY MEANS OF MFSD, THE SECOND C STEP IS APPLICATION OF MTDS. C SUBROUTINES MFSD AND MTDS MAY BE USED IN ORDER TO CALCULATE C THE PRODUCT TRANSPOSE(A)*INVERSE(B)*A WITH GIVEN SYMMETRIC C POSITIVE DEFINITE B AND GIVEN A EFFICIENTLY IN THREE STEPS C 1) TRIANGULAR FACTORIZATION OF B (B=TRANSPOSE(T)*T) C 2) MULTIPLICATION OF A ON THE LEFT BY INVERSE(TRANSPOSE(T)) C A IS REPLACED BY C=INVERSE(TRANSPOSE(T))*A C 3) CALCULATION OF THE RESULT FORMING TRANSPOSE(C)*C C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C CALCULATION OF X = INVERSE(T)*A IS DONE USING BACKWARD C SUBSTITUTION TO OBTAIN X FROM T*X = A. C CALCULATION OF Y = INVERSE(TRANSPOSE(T))*A IS DONE USING C FORWARD SUBSTITUTION TO OBTAIN Y FROM TRANSPOSE(T)*Y = A. C CALCULATION OF Z = INVERSE(TRANSPOSE(T)*T)*A IS DONE C SOLVING FIRST TRANSPOSE(T)*Y = A AND THEN T*Z = Y, IE. C USING THE ABOVE TWO STEPS IN REVERSE ORDER C C .................................................................. C SUBROUTINE MTDS(A,M,N,T,IOP,IER) C C DIMENSION A(1),T(1) DOUBLE PRECISION DSUM C C TEST OF DIMENSION IF(M)2,2,1 1 IF(N)2,2,4 C C ERROR RETURN IN CASE OF ILLEGAL DIMENSIONS 2 IER=-1 RETURN C C ERROR RETURN IN CASE OF SINGULAR MATRIX T 3 IER=1 RETURN C C INITIALIZE DIVISION PROCESS 4 MN=M*N MM=M*(M+1)/2 MM1=M-1 IER=0 ICS=M IRS=1 IMEND=M C C TEST SPECIFIED OPERATION IF(IOP)5,2,6 5 MM=N*(N+1)/2 MM1=N-1 IRS=M ICS=1 IMEND=MN-M+1 MN=M 6 IOPE=MOD(IOP+3,3) IF(IABS(IOP)-3)7,7,2 7 IF(IOPE-1)8,18,8 C C INITIALIZE SOLUTION OF TRANSPOSE(T)*X = A 8 MEND=1 LLD=IRS MSTA=1 MDEL=1 MX=1 LD=1 LX=0 C C TEST FOR NONZERO DIAGONAL TERM IN T 9 IF(T(MSTA))10,3,10 10 DO 11 I=MEND,MN,ICS 11 A(I)=A(I)/DBLE(T(MSTA)) C C IS M EQUAL 1 IF(MM1)2,15,12 12 DO 14 J=1,MM1 MSTA=MSTA+MDEL MDEL=MDEL+MX DO 14 I=MEND,MN,ICS DSUM=0.D0 L=MSTA LDX=LD LL=I DO 13 K=1,J DSUM=DSUM-T(L)*A(LL) LL=LL+LLD L=L+LDX 13 LDX=LDX+LX IF(T(L))14,3,14 14 A(LL)=(DSUM+A(LL))/T(L) C C TEST END OF OPERATION 15 IF(IER)16,17,16 16 IER=0 RETURN 17 IF(IOPE)18,18,16 C C INITIALIZE SOLUTION OF T*X = A 18 IER=1 MEND=IMEND MN=M*N LLD=-IRS MSTA=MM MDEL=-1 MX=0 LD=-MM1 LX=1 GOTO 9 END C C .................................................................. C C SUBROUTINE MTRA C C PURPOSE C TRANSPOSE A MATRIX C C USAGE C CALL MTRA(A,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX TO BE TRANSPOSED C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS OF A AND COLUMNS OF R C M - NUMBER OF COLUMNS OF A AND ROWS OF R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C MCPY C C METHOD C TRANSPOSE N BY M MATRIX A TO FORM M BY N MATRIX R BY MOVING C EACH ROW OF A INTO THE CORRESPONDING COLUMN OF R. IF MATRIX C A IS SYMMETRIC OR DIAGONAL, MATRIX R IS THE SAME AS A. C C .................................................................. C SUBROUTINE MTRA(A,R,N,M,MS) DIMENSION A(1),R(1) C C IF MS IS 1 OR 2, COPY A C IF(MS) 10,20,10 10 CALL MCPY(A,R,N,N,MS) RETURN C C TRANSPOSE GENERAL MATRIX C 20 IR=0 DO 30 I=1,N IJ=I-N DO 30 J=1,M IJ=IJ+N IR=IR+1 30 R(IR)=A(IJ) RETURN END C C .................................................................. C C SUBROUTINE MULTR C C PURPOSE C PERFORM A MULTIPLE LINEAR REGRESSION ANALYSIS FOR A C DEPENDENT VARIABLE AND A SET OF INDEPENDENT VARIABLES. THIS C SUBROUTINE IS NORMALLY USED IN THE PERFORMANCE OF MULTIPLE C AND POLYNOMIAL REGRESSION ANALYSES. C C USAGE C CALL MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS. C K - NUMBER OF INDEPENDENT VARIABLES IN THIS REGRESSION. C XBAR - INPUT VECTOR OF LENGTH M CONTAINING MEANS OF ALL C VARIABLES. M IS NUMBER OF VARIABLES IN OBSERVATIONS. C STD - INPUT VECTOR OF LENGTH M CONTAINING STANDARD DEVI- C ATIONS OF ALL VARIABLES. C D - INPUT VECTOR OF LENGTH M CONTAINING THE DIAGONAL OF C THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS C FROM MEANS FOR ALL VARIABLES. C RX - INPUT MATRIX (K X K) CONTAINING THE INVERSE OF C INTERCORRELATIONS AMONG INDEPENDENT VARIABLES. C RY - INPUT VECTOR OF LENGTH K CONTAINING INTERCORRELA- C TIONS OF INDEPENDENT VARIABLES WITH DEPENDENT C VARIABLE. C ISAVE - INPUT VECTOR OF LENGTH K+1 CONTAINING SUBSCRIPTS OF C INDEPENDENT VARIABLES IN ASCENDING ORDER. THE C SUBSCRIPT OF THE DEPENDENT VARIABLE IS STORED IN C THE LAST, K+1, POSITION. C B - OUTPUT VECTOR OF LENGTH K CONTAINING REGRESSION C COEFFICIENTS. C SB - OUTPUT VECTOR OF LENGTH K CONTAINING STANDARD C DEVIATIONS OF REGRESSION COEFFICIENTS. C T - OUTPUT VECTOR OF LENGTH K CONTAINING T-VALUES. C ANS - OUTPUT VECTOR OF LENGTH 10 CONTAINING THE FOLLOWING C INFORMATION.. C ANS(1) INTERCEPT C ANS(2) MULTIPLE CORRELATION COEFFICIENT C ANS(3) STANDARD ERROR OF ESTIMATE C ANS(4) SUM OF SQUARES ATTRIBUTABLE TO REGRES- C SION (SSAR) C ANS(5) DEGREES OF FREEDOM ASSOCIATED WITH SSAR C ANS(6) MEAN SQUARE OF SSAR C ANS(7) SUM OF SQUARES OF DEVIATIONS FROM REGRES- C SION (SSDR) C ANS(8) DEGREES OF FREEDOM ASSOCIATED WITH SSDR C ANS(9) MEAN SQUARE OF SSDR C ANS(10) F-VALUE C C REMARKS C N MUST BE GREATER THAN K+1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE GAUSS-JORDAN METHOD IS USED IN THE SOLUTION OF THE C NORMAL EQUATIONS. REFER TO W. W. COOLEY AND P. R. LOHNES, C 'MULTIVARIATE PROCEDURES FOR THE BEHAVIORAL SCIENCES', C JOHN WILEY AND SONS, 1962, CHAPTER 3, AND B. OSTLE, C 'STATISTICS IN RESEARCH', THE IOWA STATE COLLEGE PRESS, C 1954, CHAPTER 8. C C .................................................................. C SUBROUTINE MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS) DIMENSION XBAR(1),STD(1),D(1),RX(1),RY(1),ISAVE(1),B(1),SB(1), 1 T(1),ANS(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION XBAR,STD,D,RX,RY,B,SB,T,ANS,RM,BO,SSAR,SSDR,SY, C 1 FN,FK,SSARM,SSDRM,F C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT AND ABS IN C STATEMENTS 122, 125, AND 135 MUST BE CHANGED TO DSQRT AND DABS. C C ............................................................... C MM=K+1 C C BETA WEIGHTS C DO 100 J=1,K 100 B(J)=0.0 DO 110 J=1,K L1=K*(J-1) DO 110 I=1,K L=L1+I 110 B(J)=B(J)+RY(I)*RX(L) RM=0.0 BO=0.0 L1=ISAVE(MM) C C COEFFICIENT OF DETERMINATION C DO 120 I=1,K RM=RM+B(I)*RY(I) C C REGRESSION COEFFICIENTS C L=ISAVE(I) B(I)=B(I)*(STD(L1)/STD(L)) C C INTERCEPT C 120 BO=BO+B(I)*XBAR(L) BO=XBAR(L1)-BO C C SUM OF SQUARES ATTRIBUTABLE TO REGRESSION C SSAR=RM*D(L1) C C MULTIPLE CORRELATION COEFFICIENT C 122 RM= SQRT( ABS(RM)) C C SUM OF SQUARES OF DEVIATIONS FROM REGRESSION C SSDR=D(L1)-SSAR C C VARIANCE OF ESTIMATE C FN=N-K-1 SY=SSDR/FN C C STANDARD DEVIATIONS OF REGRESSION COEFFICIENTS C DO 130 J=1,K L1=K*(J-1)+J L=ISAVE(J) 125 SB(J)= SQRT( ABS((RX(L1)/D(L))*SY)) C C COMPUTED T-VALUES C 130 T(J)=B(J)/SB(J) C C STANDARD ERROR OF ESTIMATE C 135 SY= SQRT( ABS(SY)) C C F VALUE C FK=K SSARM=SSAR/FK SSDRM=SSDR/FN F=SSARM/SSDRM C ANS(1)=BO ANS(2)=RM ANS(3)=SY ANS(4)=SSAR ANS(5)=FK ANS(6)=SSARM ANS(7)=SSDR ANS(8)=FN ANS(9)=SSDRM ANS(10)=F RETURN END C C .................................................................. C C SUBROUTINE MXOUT C C PURPOSE C PRODUCES AN OUTPUT LISTING OF ANY SIZED ARRAY ON C LOGICAL UNIT 6 C C USAGE C CALL MXOUT(ICODE,A,N,M,MS,LINS,IPOS,ISP) C C DESCRIPTION OF PARAMETERS C ICODE- INPUT CODE NUMBER TO BE PRINTED ON EACH OUTPUT PAGE C A-NAME OF OUTPUT MATRIX C N-NUMBER OF ROWS IN A C M-NUMBER OF COLUMNS IN A C MS-STORAGE MODE OF A WHERE MS= C 0-GENERAL C 1-SYMMETRIC C 2-DIAGONAL C LINS-NUMBER OF PRINT LINES ON THE PAGE (USUALLY 60) C IPOS-NUMBER OF PRINT POSITIONS ACROSS THE PAGE (USUALLY 132) C ISP-LINE SPACING CODE, 1 FOR SINGLE SPACE, 2 FOR DOUBLE C SPACE C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C THIS SUBROUTINE CREATES A STANDARD OUTPUT LISTING OF ANY C SIZED ARRAY WITH ANY STORAGE MODE. EACH PAGE IS HEADED WITH C THE CODE NUMBER,DIMENSIONS AND STORAGE MODE OF THE ARRAY. C EACH COLUMN AND ROW IS ALSO HEADED WITH ITS RESPECTIVE C NUMBER. C C .................................................................. C SUBROUTINE MXOUT (ICODE,A,N,M,MS,LINS,IPOS,ISP) DIMENSION A(1),B(8) 1 FORMAT(1H1,5X, 7HMATRIX ,I5,6X,I3,5H ROWS,6X,I3,8H COLUMNS, 18X,13HSTORAGE MODE ,I1,8X,5HPAGE ,I2,/) 2 FORMAT(12X,8HCOLUMN ,7(3X,I3,10X)) 3 FORMAT(1H ) 4 FORMAT(1H ,7X,4HROW ,I3,7(E16.6)) 5 FORMAT(1H0,7X,4HROW ,I3,7(E16.6)) C J=1 C C WRITE HEADING C NEND=IPOS/16-1 LEND=(LINS/ISP)-2 IPAGE=1 10 LSTRT=1 20 WRITE(6,1)ICODE,N,M,MS,IPAGE JNT=J+NEND-1 IPAGE=IPAGE+1 31 IF(JNT-M)33,33,32 32 JNT=M 33 CONTINUE WRITE(6,2)(JCUR,JCUR=J,JNT) IF(ISP-1) 35,35,40 35 WRITE(6,3) 40 LTEND=LSTRT+LEND-1 DO 80 L=LSTRT,LTEND C C FORM OUTPUT ROW LINE C DO 55 K=1,NEND KK=K JT = J+K-1 CALL LOC(L,JT,IJNT,N,M,MS) B(K)=0.0 IF(IJNT)50,50,45 45 B(K)=A(IJNT) 50 CONTINUE C C CHECK IF LAST COLUMN. IF YES GO TO 60 C IF(JT-M) 55,60,60 55 CONTINUE C C END OF LINE, NOW WRITE C 60 IF(ISP-1)65,65,70 65 WRITE(6,4)L,(B(JW),JW=1,KK) GO TO 75 70 WRITE(6,5)L,(B(JW),JW=1,KK) C C IF END OF ROWS,GO CHECK COLUMNS C 75 IF(N-L)85,85,80 80 CONTINUE C C END OF PAGE, NOW CHECK FOR MORE OUTPUT C LSTRT=LSTRT+LEND GO TO 20 C C END OF COLUMNS, THEN RETURN C 85 IF(JT-M)90,95,95 90 J=JT+1 GO TO 10 95 RETURN END C C....................................................................... C C SUBROUTINE NDTR C C PURPOSE C COMPUTES Y = P(X) = PROBABILITY THAT THE RANDOM VARIABLE U, C DISTRIBUTED NORMALLY(0,1), IS LESS THAN OR EQUAL TO X. C F(X), THE ORDINATE OF THE NORMAL DENSITY AT X, IS ALSO C COMPUTED. C C USAGE C CALL NDTR(X,P,D) C C DESCRIPTION OF PARAMETERS C X--INPUT SCALAR FOR WHICH P(X) IS COMPUTED. C P--OUTPUT PROBABILITY. C D--OUTPUT DENSITY. C C REMARKS C MAXIMUM ERROR IS 0.0000007. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C BASED ON APPROXIMATIONS IN C. HASTINGS, APPROXIMATIONS FOR C DIGITAL COMPUTERS, PRINCETON UNIV. PRESS, PRINCETON, N.J., C 1955. SEE EQUATION 26.2.17, HANDBOOK OF MATHEMATICAL C FUNCTIONS, ABRAMOWITZ AND STEGUN, DOVER PUBLICATIONS, INC., C NEW YORK. C C....................................................................... C SUBROUTINE NDTR(X,P,D) C AX=ABS(X) T=1.0/(1.0+.2316419*AX) D=0.3989423*EXP(-X*X/2.0) P = 1.0 - D*T*((((1.330274*T - 1.821256)*T + 1.781478)*T - 1 0.3565638)*T + 0.3193815) IF(X)1,2,2 1 P=1.0-P 2 RETURN END C C....................................................................... C C SUBROUTINE NDTRI C C PURPOSE C COMPUTES X = P**(-1)(Y), THE ARGUMENT X SUCH THAT Y= P(X) = C THE PROBABILITY THAT THE RANDOM VARIABLE U, DISTRIBUTED C NORMALLY(0,1), IS LESS THAN OR EQUAL TO X. F(X), THE C ORDINATE OF THE NORMAL DENSITY, AT X, IS ALSO COMPUTED. C C USAGE C CALL NDTRI(P,X,D,IER) C C DESCRIPTION OF PARAMETERS C P - INPUT PROBABILITY. C X - OUTPUT ARGUMENT SUCH THAT P = Y = THE PROBABILITY THAT C U, THE RANDOM VARIABLE, IS LESS THAN OR EQUAL TO X. C D - OUTPUT DENSITY, F(X). C IER - OUTPUT ERROR CODE C = -1 IF P IS NOT IN THE INTERVAL (0,1), INCLUSIVE. C X=D=.99999E38 IN THIS CASE N C = 0 IF THERE IS NO ERROR. SEE REMARKS, BELOW. C C REMARKS C MAXIMUM ERROR IS 0.00045. C IF P = 0, X IS SET TO -(10)**74. D IS SET TO 0. C IF P = 1, X IS SET TO (10)**74. D IS SET TO 0. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C BASED ON APPROXIMATIONS IN C. HASTINGS, APPROXIMATIONS FOR C DIGITAL COMPUTERS, PRINCETON UNIV. PRESS, PRINCETON, N.J., C 1955. SEE EQUATION 26.2.23, HANDBOOK OF MATHEMATICAL C FUNCTIONS, ABRAMOWITZ AND STEGUN, DOVER PUBLICATIONS, INC., C NEW YORK. C C....................................................................... C SUBROUTINE NDTRI(P,X,D,IE) C IE=0 X=.99999E38 D=X IF(P)1,4,2 1 IE=-1 GO TO 12 2 IF (P-1.0)7,5,1 4 X=-.999999E38 5 D=0.0 GO TO 12 C C 7 D=P IF(D-0.5)9,9,8 8 D=1.0-D 9 T2=ALOG(1.0/(D*D)) T=SQRT(T2) X=T-(2.515517+0.802853*T+0.010328*T2)/(1.0+1.432788*T+0.189269*T2 1 +0.001308*T*T2) IF(P-0.5)10,10,11 10 X=-X 11 D=0.3989423*EXP(-X*X/2.0) 12 RETURN END C C .................................................................. C C SUBROUTINE NROOT C C PURPOSE C COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL NONSYMMETRIC C MATRIX OF THE FORM B-INVERSE TIMES A. THIS SUBROUTINE IS C NORMALLY CALLED BY SUBROUTINE CANOR IN PERFORMING A C CANONICAL CORRELATION ANALYSIS. C C USAGE C CALL NROOT (M,A,B,XL,X) C C DESCRIPTION OF PARAMETERS C M - ORDER OF SQUARE MATRICES A, B, AND X. C A - INPUT MATRIX (M X M). C B - INPUT MATRIX (M X M). C XL - OUTPUT VECTOR OF LENGTH M CONTAINING EIGENVALUES OF C B-INVERSE TIMES A. C X - OUTPUT MATRIX (M X M) CONTAINING EIGENVECTORS COLUMN- C WISE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C EIGEN C C METHOD C REFER TO W. W. COOLEY AND P. R. LOHNES, 'MULTIVARIATE PRO- C CEDURES FOR THE BEHAVIORAL SCIENCES', JOHN WILEY AND SONS, C 1962, CHAPTER 3. C C .................................................................. C SUBROUTINE NROOT (M,A,B,XL,X) DIMENSION A(1),B(1),XL(1),X(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,B,XL,X,SUMV C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS C 110 AND 175 MUST BE CHANGED TO DSQRT. ABS IN STATEMENT 110 C MUST BE CHANGED TO DABS. C C ............................................................... C C COMPUTE EIGENVALUES AND EIGENVECTORS OF B C K=1 DO 100 J=2,M L=M*(J-1) DO 100 I=1,J L=L+1 K=K+1 100 B(K)=B(L) C C THE MATRIX B IS A REAL SYMMETRIC MATRIX. C MV=0 CALL EIGEN (B,X,M,MV) C C FORM RECIPROCALS OF SQUARE ROOT OF EIGENVALUES. THE RESULTS C ARE PREMULTIPLIED BY THE ASSOCIATED EIGENVECTORS. C L=0 DO 110 J=1,M L=L+J 110 XL(J)=1.0/ SQRT( ABS(B(L))) K=0 DO 115 J=1,M DO 115 I=1,M K=K+1 115 B(K)=X(K)*XL(J) C C FORM (B**(-1/2))PRIME * A * (B**(-1/2)) C DO 120 I=1,M N2=0 DO 120 J=1,M N1=M*(I-1) L=M*(J-1)+I X(L)=0.0 DO 120 K=1,M N1=N1+1 N2=N2+1 120 X(L)=X(L)+B(N1)*A(N2) L=0 DO 130 J=1,M DO 130 I=1,J N1=I-M N2=M*(J-1) L=L+1 A(L)=0.0 DO 130 K=1,M N1=N1+M N2=N2+1 130 A(L)=A(L)+X(N1)*B(N2) C C COMPUTE EIGENVALUES AND EIGENVECTORS OF A C CALL EIGEN (A,X,M,MV) L=0 DO 140 I=1,M L=L+I 140 XL(I)=A(L) C C COMPUTE THE NORMALIZED EIGENVECTORS C DO 150 I=1,M N2=0 DO 150 J=1,M N1=I-M L=M*(J-1)+I A(L)=0.0 DO 150 K=1,M N1=N1+M N2=N2+1 150 A(L)=A(L)+B(N1)*X(N2) L=0 K=0 DO 180 J=1,M SUMV=0.0 DO 170 I=1,M L=L+1 170 SUMV=SUMV+A(L)*A(L) 175 SUMV= SQRT(SUMV) DO 180 I=1,M K=K+1 180 X(K)=A(K)/SUMV RETURN END C NUMINT C NUMERICAL INTEGRATION BY OVERLAPPING PARABOLAS C AS MODIFIED FOR PROGRAMMA BY REA C ARGUMENTS C N NUMBER OF POINTS IN THE VECTORS C A OUTPUT VECTOR OF INTEGRALS (A(2)=INT(X(1)-X(2)) ETC C X INPUT X-VALUES C Y INPUT Y VALUES C C MARS 74 C LIMITED TO POSITIVE AREAS SUBROUTINE NUMINT(N,X,Y,A) DIMENSION X(1),Y(1),A(1) N1=N-1 DO 100 I=2,N1 HI1=(Y(I+1)-Y(I))/(X(I+1)-X(I)) HI=(Y(I)-Y(I-1))/(X(I)-X(I-1)) A(I)=(HI1-HI)/(X(I+1)-X(I-1)) 100 CONTINUE DO 200 I=2,N J=N-I+2 IF(J.EQ.N)AI=A(N-1) IF(J.EQ.2)AI=A(2) IF(J.NE.N.AND.J.NE.2)AI=0.5*(A(J)+A(J-1)) 160 D=X(J)-X(J-1) A(J)=D*(0.5*(Y(J)+Y(J-1))-D*D*AI/6.) 200 IF(A(J).LT.0)A(J)=0 A(1)=0. RETURN END C C .................................................................. C C SUBROUTINE ORDER C C PURPOSE C CONSTRUCT FROM A LARGER MATRIX OF CORRELATION COEFFICIENTS C A SUBSET MATRIX OF INTERCORRELATIONS AMONG INDEPENDENT C VARIABLES AND A VECTOR OF INTERCORRELATIONS OF INDEPENDENT C VARIABLES WITH DEPENDENT VARIABLE. THIS SUBROUTINE IS C NORMALLY USED IN THE PERFORMANCE OF MULTIPLE AND POLYNOMIAL C REGRESSION ANALYSES. C C USAGE C CALL ORDER (M,R,NDEP,K,ISAVE,RX,RY) C C DESCRIPTION OF PARAMETERS C M - NUMBER OF VARIABLES AND ORDER OF MATRIX R. C R - INPUT MATRIX CONTAINING CORRELATION COEFFICIENTS. C THIS SUBROUTINE EXPECTS ONLY UPPER TRIANGULAR C PORTION OF THE SYMMETRIC MATRIX TO BE STORED (BY C COLUMN) IN R. (STORAGE MODE OF 1) C NDEP - THE SUBSCRIPT NUMBER OF THE DEPENDENT VARIABLE. C K - NUMBER OF INDEPENDENT VARIABLES TO BE INCLUDED C IN THE FORTHCOMING REGRESSION. K MUST BE GREATER C THAN OR EQUAL TO 1. C ISAVE - INPUT VECTOR OF LENGTH K+1 CONTAINING, IN ASCENDING C ORDER, THE SUBSCRIPT NUMBERS OF K INDEPENDENT C VARIABLES TO BE INCLUDED IN THE FORTHCOMING REGRES- C SION. C UPON RETURNING TO THE CALLING ROUTINE, THIS VECTOR C CONTAINS, IN ADDITION, THE SUBSCRIPT NUMBER OF C THE DEPENDENT VARIABLE IN K+1 POSITION. C RX - OUTPUT MATRIX (K X K) CONTAINING INTERCORRELATIONS C AMONG INDEPENDENT VARIABLES TO BE USED IN FORTH- C COMING REGRESSION. C RY - OUTPUT VECTOR OF LENGTH K CONTAINING INTERCORRELA- C TIONS OF INDEPENDENT VARIABLES WITH DEPENDENT C VARIABLES. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C FROM THE SUBSCRIPT NUMBERS OF THE VARIABLES TO BE INCLUDED C IN THE FORTHCOMING REGRESSION, THE SUBROUTINE CONSTRUCTS THE C MATRIX RX AND THE VECTOR RY. C C .................................................................. C SUBROUTINE ORDER (M,R,NDEP,K,ISAVE,RX,RY) DIMENSION R(1),ISAVE(1),RX(1),RY(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION R,RX,RY C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C COPY INTERCORRELATIONS OF INDEPENDENT VARIABLES C WITH DEPENDENT VARIABLE C MM=0 DO 130 J=1,K L2=ISAVE(J) IF(NDEP-L2) 122, 123, 123 122 L=NDEP+(L2*L2-L2)/2 GO TO 125 123 L=L2+(NDEP*NDEP-NDEP)/2 125 RY(J)=R(L) C C COPY A SUBSET MATRIX OF INTERCORRELATIONS AMONG C INDEPENDENT VARIABLES C DO 130 I=1,K L1=ISAVE(I) IF(L1-L2) 127, 128, 128 127 L=L1+(L2*L2-L2)/2 GO TO 129 128 L=L2+(L1*L1-L1)/2 129 MM=MM+1 130 RX(MM)=R(L) C C PLACE THE SUBSCRIPT NUMBER OF THE DEPENDENT C VARIABLE IN ISAVE(K+1) C ISAVE(K+1)=NDEP RETURN END C C .................................................................. C C SUBROUTINE PADD C C PURPOSE C ADD TWO POLYNOMIALS C C USAGE C CALL PADD(Z,IDIMZ,X,IDIMX,Y,IDIMY) C C DESCRIPTION OF PARAMETERS C Z - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMZ - DIMENSION OF Z (CALCULATED) C X - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1) C Y - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1) C C REMARKS C VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR C VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS C THAN THE OTHER INPUT VECTOR C THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE C LARGER OF THE TWO INPUT VECTOR DIMENSIONS. CORRESPONDING C COEFFICIENTS ARE THEN ADDED TO FORM Z. C C .................................................................. C SUBROUTINE PADD(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) C C TEST DIMENSIONS OF SUMMANDS C NDIM=IDIMX IF (IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF(NDIM) 90,90,30 30 DO 80 I=1,NDIM IF(I-IDIMX) 40,40,60 40 IF(I-IDIMY) 50,50,70 50 Z(I)=X(I)+Y(I) GO TO 80 60 Z(I)=Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END C C .................................................................. C C SUBROUTINE PADDM C C PURPOSE C ADD COEFFICIENTS OF ONE POLYNOMIAL TO THE PRODUCT OF A C FACTOR BY COEFFICIENTS OF ANOTHER POLYNOMIAL C C USAGE C CALL PADDM(Z,IDIMZ,X,IDIMX,FACT,Y,IDIMY) C C DESCRIPTION OF PARAMETERS C Z - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMZ - DIMENSION OF Z (CALCULATED) C X - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1) C FACT - FACTOR TO BE MULTIPLIED BY VECTOR Y C Y - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1) C C REMARKS C VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR C VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS C THAN THE OTHER INPUT VECTOR C THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE C LARGER OF THE TWO INPUT VECTOR DIMENSIONS. COEFFICIENT IN C VECTOR X IS THEN ADDED TO COEFFICIENT IN VECTOR Y MULTIPLIED C BY FACTOR TO FORM Z. C C .................................................................. C SUBROUTINE PADDM(Z,IDIMZ,X,IDIMX,FACT,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) C C TEST DIMENSIONS OF SUMMANDS C NDIM=IDIMX IF(IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF(NDIM) 90,90,30 30 DO 80 I=1,NDIM IF(I-IDIMX) 40,40,60 40 IF(I-IDIMY) 50,50,70 50 Z(I)=FACT*Y(I)+X(I) GO TO 80 60 Z(I)=FACT*Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END C C .................................................................. C C SUBROUTINE PCLA C C PURPOSE C MOVE POLYNOMIAL X TO Y C C USAGE C CALL PCLA(Y,IDIMY,X,IDIMX) C C DESCRIPTION OF PARAMETERS C Y - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y C X - VECTOR OF COEFFICIENTS FOR POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IDIMY IS REPLACED BY IDIMX AND VECTOR X IS MOVED TO Y C C .................................................................. C SUBROUTINE PCLA (Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) C IDIMY=IDIMX IF(IDIMX) 30,30,10 10 DO 20 I=1,IDIMX 20 Y(I)=X(I) 30 RETURN END C C .................................................................. C C SUBROUTINE PCLD C C PURPOSE C SHIFT OF ORIGIN (COMPLETE LINEAR SYNTHETIC DIVISION) C C USAGE C CALL PCLD(X,IDIMX,U) C C DESCRIPTION OF PARAMETERS C X - VECTOR OF COEFFICIENTS, ORDERED FROM SMALLEST TO C LARGEST POWER. IT IS REPLACED BY VECTOR OF C TRANSFORMED COEFFICIENTS. C IDIMX - DIMENSION OF X C U - SHIFT PARAMETER C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C COEFFICIENT VECTOR X(I) OF POLYNOMIAL P(Z) IS TRANSFORMED C SUCH THAT Q(Z)=P(Z-U) WHERE Q(Z) DENOTES THE POLYNOMIAL C WITH TRANSFORMED COEFFICIENT VECTOR. C C .................................................................. C SUBROUTINE PCLD (X,IDIMX,U) DIMENSION X(1) C K=1 1 J=IDIMX 2 IF (J-K) 4,4,3 3 X(J-1)=X(J-1)+U*X(J) J=J-1 GO TO 2 4 K=K+1 IF (IDIMX-K) 5,5,1 5 RETURN END C C .................................................................. C C SUBROUTINE PDER C C PURPOSE C FIND DERIVATIVE OF A POLYNOMIAL C C USAGE C CALL PDER(Y,IDIMY,X,IDIMX) C C DESCRIPTION OF PARAMETERS C Y - VECTOR OF COEFFICIENTS FOR DERIVATIVE, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (EQUAL TO IDIMX-1) C X - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF Y IS SET AT DIMENSION OF X LESS ONE. DERIVATIVE C IS THEN CALCULATED BY MULTIPLYING COEFFICIENTS BY THEIR C RESPECTIVE EXPONENTS. C C .................................................................. C SUBROUTINE PDER(Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) C C TEST OF DIMENSION IF (IDIMX-1) 3,3,1 1 IDIMY=IDIMX-1 EXPT=0. DO 2 I=1,IDIMY EXPT=EXPT+1. 2 Y(I)=X(I+1)*EXPT GO TO 4 3 IDIMY=0 4 RETURN END C C .................................................................. C C SUBROUTINE PDIV C C PURPOSE C DIVIDE ONE POLYNOMIAL BY ANOTHER C C USAGE C CALL PDIV(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER) C C DESCRIPTION OF PARAMETERS C P - RESULTANT VECTOR OF INTEGRAL PART C IDIMP - DIMENSION OF P C X - VECTOR OF COEFFICIENTS FOR DIVIDEND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER. IT IS C REPLACED BY REMAINDER AFTER DIVISION. C IDIMX - DIMENSION OF X C Y - VECTOR OF COEFFICIENTS FOR DIVISOR POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y C TOL - TOLERANCE VALUE BELOW WHICH COEFFICIENTS ARE C ELIMINATED DURING NORMALIZATION C IER - ERROR CODE. 0 IS NORMAL, 1 IS FOR ZERO DIVISOR C C REMARKS C THE REMAINDER R REPLACES X. C THE DIVISOR Y REMAINS UNCHANGED. C IF DIMENSION OF Y EXCEEDS DIMENSION OF X, IDIMP IS SET TO C ZERO AND CALCULATION IS BYPASSED C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C PNORM C C METHOD C POLYNOMIAL X IS DIVIDED BY POLYNOMIAL Y GIVING INTEGER PART C P AND REMAINDER R SUCH THAT X = P*Y + R. C DIVISOR Y AND REMAINDER VECTOR GET NORMALIZED. C C .................................................................. C SUBROUTINE PDIV(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER) DIMENSION P(1),X(1),Y(1) C CALL PNORM (Y,IDIMY,TOL) IF(IDIMY) 50,50,10 10 IDIMP=IDIMX-IDIMY+1 IF(IDIMP) 20,30,60 C C DEGREE OF DIVISOR WAS GREATER THAN DEGREE OF DIVIDEND C 20 IDIMP=0 30 IER=0 40 RETURN C C Y IS ZERO POLYNOMIAL C 50 IER=1 GO TO 40 C C START REDUCTION C 60 IDIMX=IDIMY-1 I=IDIMP 70 II=I+IDIMX P(I)=X(II)/Y(IDIMY) C C SUBTRACT MULTIPLE OF DIVISOR C DO 80 K=1,IDIMX J=K-1+I X(J)=X(J)-P(I)*Y(K) 80 CONTINUE I=I-1 IF(I) 90,90,70 C C NORMALIZE REMAINDER POLYNOMIAL C 90 CALL PNORM(X,IDIMX,TOL) GO TO 30 END C C .................................................................. C C SUBROUTINE PECN C C PURPOSE C ECONOMIZE A POLYNOMIAL FOR SYMMETRIC RANGE C C USAGE C CALL PECN (P,N,BOUND,EPS,TOL,WORK) C C DESCRIPTION OF PARAMETERS C P - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL C ON RETURN P CONTAINS THE ECONOMIZED POLYNOMIAL C N - DIMENSION OF COEFFICIENT VECTOR P C ON RETURN N CONTAINS DIMENSION OF ECONOMIZED C POLYNOMIAL C BOUND - RIGHT HAND BOUNDARY OF RANGE C EPS - INITIAL ERROR BOUND C ON RETURN EPS CONTAINS AN ERROR BOUND FOR THE C ECONOMIZED POLYNOMIAL C TOL - TOLERANCE FOR ERROR C FINAL VALUE OF EPS MUST BE LESS THAN TOL C WORK - WORKING STORAGE OF DIMENSION N (STARTING VALUE C OF N RATHER THAN FINAL VALUE) C C REMARKS C THE OPERATION IS BYPASSED IN CASE OF N LESS THAN 1. C IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY C FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL C WITH ARGUMENT X IN POWERS OF T = (X-(XR-XL)/2). C THIS IS ACCOMPLISHED THROUGH SUBROUTINE PCLD. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SUBROUTINE PECN TAKES AN (N-1)ST DEGREE POLYNOMIAL C APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE C EPS OVER THE INTERVAL (-BOUND,BOUND) AND REDUCES IT IF C POSSIBLE TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN C THE GIVEN TOLERANCE TOL. C THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE FINAL C VECTOR. THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL C ERROR BOUND. C N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL. C THE COEFFICIENT VECTOR OF THE N-TH CHEBYSHEV POLYNOMIAL C IS CALCULATED FROM THE RECURSION FORMULA C A(K-1)=-A(K+1)*K*L*L*(K-1)/((N+K-2)*(N-K+2)) C REFERENCE C K. A. BRONS, ALGORITHM 38, TELESCOPE 2, CACM VOL. 4, 1961, C NO. 3, PP. 151-152. C C .................................................................. C SUBROUTINE PECN(P,N,BOUND,EPS,TOL,WORK) C DIMENSION P(1),WORK(1) FL=BOUND*BOUND C C TEST OF DIMENSION C 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(P(1))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(P(1)) 5 RETURN C C CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL C 6 NEND=N-2 WORK(N)=-P(N) DO 7 J=1,NEND,2 K=N-J FN=(NEND-1+K)*(NEND+3-K) FK=K*(K-1) 7 WORK(K-1)=-WORK(K+1)*FK*FL/FN C C TEST FOR FEASIBILITY OF REDUCTION C IF(K-2)8,8,9 8 FN=ABS(WORK(1)) GOTO 10 9 FN=N-1 FN=ABS(WORK(2)/FN) 10 IF(EPS+FN-TOL)11,11,5 C C REDUCE POLYNOMIAL C 11 EPS=EPS+FN N=N-1 DO 12 J=K,N,2 12 P(J-1)=P(J-1)+WORK(J-1) GOTO 1 END C C .................................................................. C C SUBROUTINE PECS C C PURPOSE C ECONOMIZATION OF A POLYNOMIAL FOR UNSYMMETRIC RANGE C C USAGE C CALL PECS (P,N,BOUND,EPS,TOL,WORK) C C DESCRIPTION OF PARAMETERS C P - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL C N - DIMENSION OF COEFFICIENT VECTOR C BOUND - RIGHT HAND BOUNDARY OF INTERVAL C EPS - INITIAL ERROR BOUND C TOL - TOLERANCE FOR ERROR C WORK - WORKING STORAGE OF DIMENSION N C C REMARKS C THE INITIAL COEFFICIENT VECTOR P IS REPLACED BY THE C ECONOMIZED VECTOR. C THE INITIAL ERROR BOUND EPS IS REPLACED BY A FINAL C ERROR BOUND. C N IS REPLACED BY THE DIMENSION OF THE REDUCED POLYNOMIAL. C IN CASE OF AN ARBITRARY INTERVAL (XL,XR) IT IS NECESSARY C FIRST TO CALCULATE THE EXPANSION OF THE GIVEN POLYNOMIAL C WITH ARGUMENT X IN POWERS OF T = (X-XL). C THIS IS ACCOMPLISHED THROUGH SUBROUTINE PCLD. C OPERATION IS BYPASSED IN CASE OF N LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C SUBROUTINE PECS TAKES AN (N-1)ST DEGREE POLYNOMIAL C APPROXIMATION TO A FUNCTION F(X) VALID WITHIN A TOLERANCE C EPS OVER THE INTERVAL (0,BOUND) AND REDUCES IT IF POSSIBLE C TO A POLYNOMIAL OF LOWER DEGREE VALID WITHIN TOLERANCE C TOL. C THE COEFFICIENT VECTOR OF THE N-TH SHIFTED CHEBYSHEV C POLYNOMIAL IS CALCULATED FROM THE RECURSION FORMULA C A(K) = -A(K+1)*K*L*(2*K-1)/(2*(N+K-1)*(N-K+1)). C REFERENCE C K. A. BRONS, ALGORITHM 37, TELESCOPE 1, CACM VOL. 4, 1961, C NO. 3, PP. 151. C C .................................................................. C SUBROUTINE PECS(P,N,BOUND,EPS,TOL,WORK) C DIMENSION P(1),WORK(1) FL=BOUND*0.5 C C TEST OF DIMENSION C 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(P(1))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(P(1)) 5 RETURN C C CALCULATE EXPANSION OF CHEBYSHEV POLYNOMIAL C 6 NEND=N-1 WORK(N)=-P(N) DO 7 J=1,NEND K=N-J FN=(NEND-1+K)*(N-K) FK=K*(K+K-1) 7 WORK(K)=-WORK(K+1)*FK*FL/FN C C TEST FOR FEASIBILITY OF REDUCTION C FN=ABS(WORK(1)) IF(EPS+FN-TOL)8,8,5 C C REDUCE POLYNOMIAL C 8 EPS=EPS+FN N=NEND DO 9 J=1,NEND 9 P(J)=P(J)+WORK(J) GOTO 1 END C C .................................................................. C C SUBROUTINE PERM C C PURPOSE C TO COMPUTE THE PERMUTATION VECTOR THAT IS INVERSE TO A GIVEN C PERMUTATION VECTOR, THE PERMUTATION VECTOR THAT IS EQUIVA- C LENT TO A GIVEN TRANSPOSITION VECTOR AND A TRANSPOSITION C VECTOR THAT IS EQUIVALENT TO A GIVEN PERMUTATION VECTOR. C (SEE THE GENERAL DISCUSSION FOR DEFINITIONS AND NOTATION.) C C USAGE C CALL PERM(IP1,IP2,N,IPAR,IER) C C DESCRIPTION OF PARAMETERS C IP1 - GIVEN PERMUTATION OR TRANSPOSITION VECTOR C (DIMENSION N) C IP2 - RESULTING PERMUTATION OR TRANSPOSITION VECTOR C (DIMENSION N) C N - DIMENSION OF VECTORS IP1 AND IP2 C IPAR - INPUT PARAMETER C IPAR NEGATIVE - COMPUTE THE PERMUTATION VECTOR IP2 C THAT IS THE INVERSE OF THE PERMUTA- C TION VECTOR IP1 C IPAR = ZERO - COMPUTE THE PERMUTATION VECTOR IP2 C THAT IS EQUIVALENT TO THE TRANSPOSI- C TION VECTOR IP1 C IPAR POSITIVE - COMPUTE A TRANSPOSITION VECTOR IP2 C THAT IS EQUIVALENT TO THE PERMUTATION C VECTOR IP1 C IER - RESULTING ERROR PARAMETER C IER=-1 - N IS NOT POSITIVE C IER= 0 - NO ERROR C IER= 1 - IP1 IS EITHER NOT A PERMUTATION VECTOR OR C NOT A TRANSPOSITION VECTOR ON 1,...,N, C DEPENDING ON WHETHER IPAR IS NON-ZERO OR C ZERO, RESPECTIVELY C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) IF IER=1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE TO C ERROR AND THE PARTIAL RESULTS FOUND IN IP2 ARE USELESS. C (3) IP2 CANNOT HAVE THE SAME STORAGE ALLOCATION AS IP1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C (1) IPAR NEGATIVE - FOR EACH I, I=1,...,N, IP2(IP1(I)) IS C SET TO I. C (2) IPAR = ZERO - INITIALLY IP2(I) IS SET TO I FOR C I=1,...,N. THEN, FOR I=1,...,N IN THAT C ORDER, IP2(I) AND IP2(IP1(I)) ARE C INTERCHANGED. C (3) IPAR POSITIVE - INITIALLY IP1 IS MOVED TO IP2. THEN C THE FOLLOWING TWO STEPS ARE REPEATED C FOR I SUCCESSIVELY EQUAL TO 1,...,N. C (A) FIND THE SMALLEST J GREATER THAN OR C EQUAL TO I SUCH THAT IP2(J)=I. C (B) SET IP2(J) TO IP2(I). C C .................................................................. C SUBROUTINE PERM(IP1,IP2,N,IPAR,IER) C C DIMENSION IP1(1),IP2(1) C C TEST DIMENSION IF(N)19,19,1 C C TEST IPAR TO DETERMINE WHETHER IP1 IS TO BE INTERPRETED AS C A PERMUTATION VECTOR OR AS A TRANSPOSITION VECTOR 1 IF(IPAR)2,13,2 C C CHECK THAT IP1 IS A PERMUTATION VECTOR AND COMPUTE IP1 INVERSE 2 DO 3 I=1,N 3 IP2(I)=0 DO 6 I=1,N K=IP1(I) IF(K-N)4,5,20 4 IF(K)20,20,5 5 IF(IP2(K))20,6,20 6 IP2(K)=I C C TEST IPAR FOR THE DESIRED OPERATION IF(IPAR)12,7,7 C C COMPUTE TRANSPOSITION VECTOR IP2 FOR PERMUTATION VECTOR IP1 7 DO 8 I=1,N 8 IP2(I)=IP1(I) NN=N-1 IF(NN)12,12,9 9 DO 11 I=1,NN DO 10 J=1,NN IF(IP2(J)-I)10,11,10 10 CONTINUE J=N 11 IP2(J)=IP2(I) C C NORMAL RETURN - NO ERROR 12 IER=0 RETURN C C COMPUTE PERMUTATION VECTOR IP2 FOR TRANSPOSITION VECTOR IP1 13 DO 14 I=1,N 14 IP2(I)=I DO 18 I=1,N K=IP1(I) IF(K-I)15,18,16 15 IF(K)20,20,17 16 IF(N-K)20,17,17 17 J=IP2(I) IP2(I)=IP2(K) IP2(K)=J 18 CONTINUE GO TO 12 C C ERROR RETURN - N IS NOT POSITIVE 19 IER=-1 RETURN C C ERROR RETURN - IP1 IS EITHER NOT A PERMUTATION VECTOR C OR NOT A TRANSPOSITION VECTOR 20 IER=1 RETURN END C C .................................................................. C C SUBROUTINE PGCD C C PURPOSE C DETERMINE GREATEST COMMON DIVISOR OF TWO POLYNOMIALS C C USAGE C CALL PGCD(X,IDIMX,Y,IDIMY,WORK,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C Y - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER. C THIS IS REPLACED BY GREATEST COMMON DIVISOR C IDIMY - DIMENSION OF Y C WORK - WORKING STORAGE ARRAY C EPS - TOLERANCE VALUE BELOW WHICH COEFFICIENT IS C ELIMINATED DURING NORMALIZATION C IER - RESULTANT ERROR CODE WHERE C IER=0 NO ERROR C IER=1 X OR Y IS ZERO POLYNOMIAL C C REMARKS C IDIMX MUST BE GREATER THAN IDIMY C IDIMY=1 ON RETURN MEANS X AND Y ARE PRIME, THE GCD IS A C CONSTANT. IDIMX IS DESTROYED DURING COMPUTATION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C PDIV C PNORM C C METHOD C GREATEST COMMON DIVISOR OF TWO POLYNOMIALS X AND Y IS C DETERMINED BY MEANS OF EUCLIDEAN ALGORITHM. COEFFICIENT C VECTORS X AND Y ARE DESTROYED AND GREATEST COMMON C DIVISOR IS GENERATED IN Y. C C .................................................................. C SUBROUTINE PGCD(X,IDIMX,Y,IDIMY,WORK,EPS,IER) DIMENSION X(1),Y(1),WORK(1) C C DIMENSION REQUIRED FOR VECTOR NAMED WORK IS IDIMX-IDIMY+1 C 1 CALL PDIV(WORK,NDIM,X,IDIMX,Y,IDIMY,EPS,IER) IF(IER) 5,2,5 2 IF(IDIMX) 5,5,3 C C INTERCHANGE X AND Y C 3 DO 4 J=1,IDIMY WORK(1)=X(J) X(J)=Y(J) 4 Y(J)=WORK(1) NDIM=IDIMX IDIMX=IDIMY IDIMY=NDIM GO TO 1 5 RETURN END C C .................................................................. C C SUBROUTINE PHI C C PURPOSE C TO COMPUTE THE PHI COEFFICIENT BETWEEN TWO VARIABLES WHICH C ARE DICHOTOMOUS. C C USAGE C CALL PHI (N,U,V,HU,HV,P,CH,XP,IE) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS C U - INPUT VECTOR OF LENGTH N CONTAINING THE FIRST DICHOTO- C MOUS VARIABLE C V - INPUT VECTOR OF LENGTH N CONTAINING THE SECOND DICHOTO- C MOUS VARIABLE C HU - INPUT NUMERICAL CODE WHICH INDICATES THE HIGHER C CATEGORY OF THE FIRST VARIABLE. ANY OBSERVATION IN C VECTOR U WHICH HAS A VALUE EQUAL TO OR GREATER THAN HU C WILL BE CLASSIFIED IN THE HIGHER CATEGORY. C HV - INPUT NUMERICAL CODE FOR VECTOR V, SIMILAR TO HU C P - PHI COEFFICIENT COMPUTED C CH - CHI-SQUARE COMPUTED AS A FUNCTION OF PHI COEFFICIENT C (DEGREES OF FREEDOM FOR CHI-SQUARE = 1) C XP - COMPUTED VALUE OF THE MAXIMAL PHI COEFFICIENT THAT C CAN BE ATTAINED IN THE PROBLEM C IE - IF IE IS NON-ZERO, SOME CELL IN THE 2 BY 2 TABLE IS C NULL. IF SO, P, CH, AND XP ARE SET TO 10**75. C C REMARKS C VARIABLES U AND V MUST BE SPECIFIED NUMERIC. C THE PHI COEFFICIENT IS A SPECIAL CASE OF THE C PEARSON PRODUCT-MOMENT CORRELATION WHEN BOTH VARIABLES ARE C BINARY. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO P. HORST, 'PYSCHOLOGICAL MEASUREMENT AND C PREDICTION', P. 94 (WADSWORTH, 1966). C C .................................................................. C SUBROUTINE PHI (N,U,V,HU,HV,P,CH,XP,IE) C DIMENSION U(1),V(1) C C CONSTRUCT A 2X2 CONTINGENCY TABLE C IE=0 A=0.0 B=0.0 C=0.0 D=0.0 C DO 40 I=1,N IF(U(I)-HU) 10,25,25 10 IF(V(I)-HV) 15,20,20 15 D=D+1.0 GO TO 40 20 B=B+1.0 GO TO 40 25 IF(V(I)-HV) 30,35,35 30 C=C+1.0 GO TO 40 35 A=A+1.0 40 CONTINUE IF(A) 100,100,41 41 IF(B) 100,100,42 42 IF(C) 100,100,43 43 IF(D) 100,100,44 C C COMPUTE THE PHI COEFFICIENT C 44 P=(A*D-B*C)/ SQRT((A+B)*(C+D)*(A+C)*(B+D)) C C COMPUTE CHI-SQURE C T=N CH=T*P*P C C COMPUTE THE MAXIMAL PHI COEFFICIENT C P1=(A+C)/T P2=(B+D)/T P3=(A+B)/T P4=(C+D)/T IF(P1-P2) 75, 45, 45 45 IF(P3-P4) 65, 50, 50 50 IF(P1-P3) 60, 55, 55 55 XP=SQRT((P3/P4)*(P2/P1)) GO TO 95 60 XP=SQRT((P1/P2)*(P4/P3)) GO TO 95 65 IF(P1-P4) 70, 55, 55 70 XP=SQRT((P2/P1)*(P3/P4)) GO TO 95 75 IF(P3-P4) 90, 80, 80 80 IF(P2-P3) 60, 85, 85 85 XP=SQRT((P4/P3)*(P1/P2)) GO TO 95 90 IF(P2-P4) 70, 85, 85 C 95 RETURN 100 IE=1 P=1.7E38 0 CH=1.7E38 0 XP=1.7E38 0 GO TO 95 END C C .................................................................. C C SUBROUTINE PILD C C PURPOSE C EVALUATE POLYNOMIAL AND ITS FIRST DERIVATIVE FOR A GIVEN C ARGUMENT C C USAGE C CALL PILD(POLY,DVAL,ARGUM,X,IDIMX) C C DESCRIPTION OF PARAMETERS C POLY - VALUE OF POLYNOMIAL C DVAL - DERIVATIVE C ARGUM - ARGUMENT C X - VECTOR OF COEFFICIENTS FOR POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C PQSD C C METHOD C EVALUATION IS DONE BY MEANS OF SUBROUTINE PQSD (QUADRATIC C SYNTHETIC DIVISION) C C .................................................................. C SUBROUTINE PILD (POLY,DVAL,ARGUM,X,IDIMX) DIMENSION X(1) C P=ARGUM+ARGUM Q=-ARGUM*ARGUM C CALL PQSD (DVAL,POLY,P,Q,X,IDIMX) C POLY=ARGUM*DVAL+POLY C RETURN END C C .................................................................. C C SUBROUTINE PINT C C PURPOSE C FIND INTEGRAL OF A POLYNOMIAL WITH CONSTANT OF INTEGRATION C EQUAL TO ZERO C C USAGE C CALL PINT(Y,IDIMY,X,IDIMX) C C DESCRIPTION OF PARAMETERS C Y - VECTOR OF COEFFICIENTS FOR INTEGRAL, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (EQUAL TO IDIMX+1) C X - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF Y IS SET AT DIMENSION OF X PLUS ONE, AND THE C CONSTANT TERM IS SET TO ZERO. INTEGRAL IS THEN CALCULATED C BY DIVIDING COEFFICIENTS BY THEIR RESPECTIVE EXPONENTS. C C .................................................................. C SUBROUTINE PINT(Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) C IDIMY=IDIMX+1 Y(1)=0. IF(IDIMX)1,1,2 1 RETURN 2 EXPT=1. DO 3 I=2,IDIMY Y(I)=X(I-1)/EXPT 3 EXPT=EXPT+1. GO TO 1 END C C .................................................................. C C SUBROUTINE PLOT C C PURPOSE C PLOT SEVERAL CROSS-VARIABLES VERSUS A BASE VARIABLE C C USAGE C CALL PLOT (NO,A,N,M,NL,NS) C C DESCRIPTION OF PARAMETERS C NO - CHART NUMBER (3 DIGITS MAXIMUM) C A - MATRIX OF DATA TO BE PLOTTED. FIRST COLUMN REPRESENTS C BASE VARIABLE AND SUCCESSIVE COLUMNS ARE THE CROSS- C VARIABLES (MAXIMUM IS 9). C N - NUMBER OF ROWS IN MATRIX A C M - NUMBER OF COLUMNS IN MATRIX A (EQUAL TO THE TOTAL C NUMBER OF VARIABLES). MAXIMUM IS 10. C NL - NUMBER OF LINES IN THE PLOT. IF 0 IS SPECIFIED, 50 C LINES ARE USED. C NS - CODE FOR SORTING THE BASE VARIABLE DATA IN ASCENDING C ORDER C 0 SORTING IS NOT NECESSARY (ALREADY IN ASCENDING C ORDER). C 1 SORTING IS NECESSARY. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C .................................................................. C SUBROUTINE PLOT(NO,A,N,M,NL,NS) DIMENSION OUT(101),YPR(11),ANG(9),A(1) C 1 FORMAT(1H1,60X,7H CHART ,I3,//) 2 FORMAT(1H ,F11.4,5X,101A1) 3 FORMAT(1H ) 4 FORMAT(10H 123456789) 5 FORMAT(10A1) 7 FORMAT(1H ,16X,101H. . . . . 1 . . . . . .) 8 FORMAT(1H0,9X,11F10.4) C C .................................................................. C NLL=NL C IF(NS) 16, 16, 10 C C SORT BASE VARIABLE DATA IN ASCENDING ORDER C 10 DO 15 I=1,N DO 14 J=I,N IF(A(I)-A(J)) 14, 14, 11 11 L=I-N LL=J-N DO 12 K=1,M L=L+N LL=LL+N F=A(L) A(L)=A(LL) 12 A(LL)=F 14 CONTINUE 15 CONTINUE C C TEST NLL C 16 IF(NLL) 20, 18, 20 18 NLL=50 C C PRINT TITLE C 20 WRITE(6,1)NO C C DEVELOP BLANK AND DIGITS FOR PRINTING C REWIND 13 WRITE (13,4) REWIND 13 READ (13,5) BLANK,(ANG(I),I=1,9) REWIND 13 C C FIND SCALE FOR BASE VARIABLE C XSCAL=(A(N)-A(1))/(FLOAT(NLL-1)) C C FIND SCALE FOR CROSS-VARIABLES C M1=N+1 YMIN=A(M1) YMAX=YMIN M2=M*N DO 40 J=M1,M2 IF(A(J)-YMIN) 28,26,26 26 IF(A(J)-YMAX) 40,40,30 28 YMIN=A(J) GO TO 40 30 YMAX=A(J) 40 CONTINUE YSCAL=(YMAX-YMIN)/100.0 C C FIND BASE VARIABLE PRINT POSITION C XB=A(1) L=1 MY=M-1 I=1 45 F=I-1 XPR=XB+F*XSCAL IF(A(L)-XPR) 50,50,70 C C FIND CROSS-VARIABLES C 50 DO 55 IX=1,101 55 OUT(IX)=BLANK DO 60 J=1,MY LL=L+J*N JP=((A(LL)-YMIN)/YSCAL)+1.0 OUT(JP)=ANG(J) 60 CONTINUE C C PRINT LINE AND CLEAR, OR SKIP C WRITE(6,2)XPR,(OUT(IZ),IZ=1,101) L=L+1 GO TO 80 70 WRITE(6,3) 80 I=I+1 IF(I-NLL) 45, 84, 86 84 XPR=A(N) GO TO 50 C C PRINT CROSS-VARIABLES NUMBERS C 86 WRITE(6,7) YPR(1)=YMIN DO 90 KN=1,9 90 YPR(KN+1)=YPR(KN)+YSCAL*10.0 YPR(11)=YMAX WRITE(6,8)(YPR(IP),IP=1,11) RETURN END C C .................................................................. C C SUBROUTINE PMPY C C PURPOSE C MULTIPLY TWO POLYNOMIALS C C USAGE C CALL PMPY(Z,IDIMZ,X,IDIMX,Y,IDIMY) C C DESCRIPTION OF PARAMETERS C Z - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMZ - DIMENSION OF Z (CALCULATED) C X - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1) C Y - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1) C C REMARKS C Z CANNOT BE IN THE SAME LOCATION AS X C Z CANNOT BE IN THE SAME LOCATION AS Y C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF Z IS CALCULATED AS IDIMX+IDIMY-1 C THE COEFFICIENTS OF Z ARE CALCULATED AS SUM OF PRODUCTS C OF COEFFICIENTS OF X AND Y , WHOSE EXPONENTS ADD UP TO THE C CORRESPONDING EXPONENT OF Z. C C .................................................................. C SUBROUTINE PMPY(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) C IF(IDIMX*IDIMY)10,10,20 10 IDIMZ=0 GO TO 50 20 IDIMZ=IDIMX+IDIMY-1 DO 30 I=1,IDIMZ 30 Z(I)=0. DO 40 I=1,IDIMX DO 40 J=1,IDIMY K=I+J-1 40 Z(K)=X(I)*Y(J)+Z(K) 50 RETURN END C C .................................................................. C C SUBROUTINE PNORM C C PURPOSE C NORMALIZE COEFFICIENT VECTOR OF A POLYNOMIAL C C USAGE C CALL PNORM(X,IDIMX,EPS) C C DESCRIPTION OF PARAMETERS C X - VECTOR OF ORIGINAL COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER. IT REMAINS UNCHANGED C IDIMX - DIMENSION OF X. IT IS REPLACED BY FINAL DIMENSION C EPS - TOLERANCE BELOW WHICH COEFFICIENT IS ELIMINATED C C REMARKS C IF ALL COEFFICIENTS ARE LESS THAN EPS, RESULT IS A ZERO C POLYNOMIAL WITH IDIMX=0 BUT VECTOR X REMAINS INTACT C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF VECTOR X IS REDUCED BY ONE FOR EACH TRAILING C COEFFICIENT WITH AN ABSOLUTE VALUE LESS THAN OR EQUAL TO EPS C C .................................................................. C SUBROUTINE PNORM(X,IDIMX,EPS) DIMENSION X(1) C 1 IF(IDIMX) 4,4,2 2 IF(ABS(X(IDIMX))-EPS) 3,3,4 3 IDIMX=IDIMX-1 GO TO 1 4 RETURN END C C .................................................................. C C SUBROUTINE POINT C C PURPOSE C TO COMPUTE THE POINT-BISERIAL CORRELATION COEFFICIENT C BETWEEN TWO VARIABLES, WHEN ONE OF THE VARIABLES IS A BINARY C VARIABLE AND ONE IS CONTINUOUS. THIS IS A SPECIAL CASE OF C THE PEARSON PRODUCT-MOMENT CORRELATION COEFFICIENT. C C USAGE C CALL POINT (N,A,B,HI,ANS,IER) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS C A - INPUT VECTOR OF LENGTH N CONTAINING THE CONTINUOUS C VARIABLE C B - INPUT VECTOR OF LENGTH N CONTAINING THE DICHOTOMOUS C (BINARY) VARIABLE C HI - INPUT NUMERICAL CODE TO INDICATE THE HIGHER CATEGORY. C ANY VALUE OF THE BINARY VARIABLE NOT LESS THAN HI WILL C BE CLASSIFIED IN THE HIGHER OF THE TWO CATEGORIES. C ANS - OUTPUT VECTOR OF LENGTH 9 CONTAINING THE FOLLOWING C RESULTS C ANS(1)- MEAN OF VARIABLE A C ANS(2)- STANDARD DEVIATION OF VARIABLE A C ANS(3)- NUMBER OF OBSERVATIONS IN THE HIGHER C CATEGORY OF VARIABLE B C ANS(4)- NUMBER OF OBSERVATIONS IN THE LOWER C CATEGORY OF VARIABLE B C ANS(5)- MEAN OF VARIABLE A FOR ONLY THOSE C OBSERVATIONS IN THE HIGHER CATEGORY OF C VARIABLE B C ANS(6)- MEAN OF VARIABLE A FOR ONLY THOSE C OBSERVATIONS IN THE LOWER CATEGORY OF C VARIABLE B C ANS(7)- POINT-BISERIAL CORRELATION COEFFICIENT C ANS(8)- T-TEST FOR THE SIGNIFICANCE OF THE C DIFFERENCE BETWEEN THE MEANS OF VARIABLE A C FOR THE HIGHER AND LOWER CATEGORIES C RESPECTIVELY. C ANS(9)- DEGREES OF FREEDOM FOR THE T-TEST C IER- 1, IF ALL ELEMENTS OF B ARE NOT LESS THAN HI. C -1, IF ALL ELEMENTS OF B ARE LESS THAN HI. C 0, OTHERWISE. IF IER IS NON-ZERO, ANS(I), I=5,...,9, C IS SET TO 10**75. C C REMARKS C THE SYMBOLS USED TO IDENTFY THE VALUES OF THE TWO CATEGORIES C OF VARIABLE B MUST BE NUMERIC. ALPHABETIC OR SPECIAL C CHARACTERS CANNOT BE USED. C THE T-TEST(ANS(8)) IS A TEST OF WHETHER THE POINT-BISERIAL C COEFFICIENT DIFFERS SIGNIFICANTLY FROM ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO P. HORST, 'PSYCHOLOGICAL MEASUREMENT AND C PREDICTION', P. 91 (WADSWORTH, 1966). C C .................................................................. C SUBROUTINE POINT (N,A,B,HI,ANS,IER) C DIMENSION A(1),B(1),ANS(1) C C COMPUTE MEAN AND STANDARD DEVIATION OF VARIABLE A C IER=0 SUM=0.0 SUM2=0.0 DO 10 I=1,N SUM=SUM+A(I) 10 SUM2=SUM2+A(I)*A(I) FN=N ANS(1)=SUM/FN ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0) ANS(2)= SQRT(ANS(2)) C C FIND NUMBERS OF CASES IN THE HIGHER AND LOWER CATEGORIES C P=0.0 SUM=0.0 SUM2=0.0 DO 30 I=1,N IF(B(I)-HI) 20, 25, 25 20 SUM2=SUM2+A(I) GO TO 30 25 P=P+1.0 SUM=SUM+A(I) 30 CONTINUE C Q=FN-P ANS(3)=P ANS(4)=Q IF (P) 35,35,40 35 IER=-1 GO TO 50 40 ANS(5)=SUM/P IF (Q) 45,45,60 45 IER=1 50 DO 55 I=5,9 55 ANS(I)=1.7E38 0 GO TO 65 60 ANS(6)=SUM2/Q C C COMPUTE THE POINT-BISERIAL CORRELATION C R=((ANS(5)-ANS(1))/ANS(2))* SQRT(P/Q) ANS(7)=R C C COMPUTE T RATIO USED TO TEST THE HYPOTHESIS OF ZERO CORRELATION C T=R* SQRT((FN-2.0)/(1.0-R*R)) ANS(8)=T C C COMPUTE DEGREES OF FREEDOM C ANS(9)=FN-2 C 65 RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR POLYNOMIAL REGRESSION - POLRG C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD FOR A POLYNOMIAL REGRES- C SION, (2) CALL SUBROUTINES TO PERFORM THE ANALYSIS, (3) C PRINT THE REGRESSION COEFFICIENTS AND ANALYSIS OF VARIANCE C TABLE FOR POLYNOMIALS OF SUCCESSIVELY INCREASING DEGREES, C AND (4) OPTIONALLY PRINT THE TABLE OF RESIDUALS AND A PLOT C OF Y VALUES AND Y ESTIMATES. C C REMARKS C THE NUMBER OF OBSERVATIONS, N, MUST BE GREATER THAN M+1, C WHERE M IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED. C IF THERE IS NO REDUCTION IN THE RESIDUAL SUM OF SQUARES C BETWEEN TWO SUCCESSIVE DEGREES OF THE POLYNOMIALS, THE C PROGRAM TERMINATES THE PROBLEM BEFORE COMPLETING THE ANALY- C SIS FOR THE HIGHEST DEGREE POLYNOMIAL SPECIFIED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C GDATA C ORDER C MINV C MULTR C PLOT (A SPECIAL PLOT SUBROUTINE PROVIDED FOR THE SAMPLE C PROGRAM.) C C METHOD C REFER TO B. OSTLE, 'STATISTICS IN RESEARCH', THE IOWA STATE C COLLEGE PRESS', 1954, CHAPTER 6. C C .................................................................. C C THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE C PRODUCT OF N*(M+1), WHERE N IS THE NUMBER OF OBSERVATIONS AND M C IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED.. cC c DIMENSION X(1100) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*M.. cC c DIMENSION DI(100) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO cC (M+2)*(M+1)/2.. cC c DIMENSION D(66) cC cC THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO M.. cC c DIMENSION B(10),E(10),SB(10),T(10) cC cC THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO (M+1).. cC c DIMENSION XBAR(11),STD(11),COE(11),SUMSQ(11),ISAVE(11) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 10.. cC c DIMENSION ANS(10) cC cC THE FOLLOWING DIMENSION WILL BE USED IF THE PLOT OF OBSERVED DATA cC AND ESTIMATES IS DESIRED. THE SIZE OF THE DIMENSION, IN THIS cC CASE, MUST BE GREATER THAN OR EQUAL TO N*3. OTHERWISE, THE SIZE cC OF DIMENSION MAY BE SET TO 1. cC c DIMENSION P(300) cC cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION X,XBAR,STD,D,SUMSQ,DI,E,B,SB,T,ANS,DET,COE cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC ............................................................... cC c1 FORMAT(A4,A2,I5,I2,I1) c2 FORMAT(2F6.0) c3 FORMAT(27H1POLYNOMIAL REGRESSION.....,A4,A2/) c4 FORMAT(23H0NUMBER OF OBSERVATIONS,I6//) c5 FORMAT(32H0POLYNOMIAL REGRESSION OF DEGREE,I3) c6 FORMAT(12H0 INTERCEPT,E20.7) c7 FORMAT(26H0 REGRESSION COEFFICIENTS/(6E20.7)) c8 FORMAT(1H0/24X,24HANALYSIS OF VARIANCE FOR,I4,19H DEGREE POLYNOMI c 1AL/) c9 FORMAT(1H0,5X,19HSOURCE OF VARIATION,7X,9HDEGREE OF,7X,6HSUM OF,9X c 1,4HMEAN,10X,1HF,9X,20HIMPROVEMENT IN TERMS/33X,7HFREEDOM,8X,7HSQUA c 2RES,7X,6HSQUARE,7X,5HVALUE,8X,17HOF SUM OF SQUARES) c10 FORMAT(20H0 DUE TO REGRESSION,12X,I6,F17.5,F14.5,F13.5,F20.5) c11 FORMAT(32H DEVIATION ABOUT REGRESSION ,I6,F17.5,F14.5) c12 FORMAT(8X,5HTOTAL,19X,I6,F17.5///) c13 FORMAT(17H0 NO IMPROVEMENT) c14 FORMAT(1H0//27X,18HTABLE OF RESIDUALS//16H OBSERVATION NO.,5X,7HX c 1VALUE,7X,7HY VALUE,7X,10HY ESTIMATE,7X,8HRESIDUAL/) c15 FORMAT(1H0,3X,I6,F18.5,F14.5,F17.5,F15.5) cC DOUBLE PRECISION TMPFIL,FILE cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC FILE = TMPFIL('SSP') cC OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT', cC 1 DISPOSE='DELETE') cC cC .................................................................. cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR,PR1,N,M,NPLOT c IF (EOF) GOTO 999 cC cC PR....PROBLEM NUMBER (MAY BE ALPHAMERIC) cC PR1...PROBLEM NUMBER (CONTINUED) cC N.....NUMBER OF OBSERVATIONS cC M.....HIGHEST DEGREE POLYNOMIAL SPECIFIED cC NPLOT.OPTION CODE FOR PLOTTING cC 0 IF PLOT IS NOT DESIRED. cC 1 IF PLOT IS DESIRED. cC cC PRINT PROBLEM NUMBER AND N. cC c WRITE (6,3) PR,PR1 c WRITE (6,4) N cC cC READ INPUT DATA cC c L=N*M c DO 110 I=1,N c J=L+I cC cC X(I) IS THE INDEPENDENT VARIABLE, AND X(J) IS THE DEPENDENT cC VARIABLE. cC c110 READ (5,2) X(I),X(J) cC c CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ) cC c MM=M+1 cc SUM=0.0 c NT=N-1 cC c DO 200 I=1,M c ISAVE(I)=I cC cC FORM SUBSET OF CORRELATION COEFFICIENT MATRIX cC c CALL ORDER (MM,D,MM,I,ISAVE,DI,E) cC cC INVERT THE SUBMATRIX OF CORRELATION COEFFICIENTS cC c CALL MINV (DI,I,DET,B,T) cC c CALL MULTR (N,I,XBAR,STD,SUMSQ,DI,E,ISAVE,B,SB,T,ANS) cC cC PRINT THE RESULT OF CALCULATION cC c WRITE (6,5) I c IF(ANS(7)) 140,130,130 c130 SUMIP=ANS(4)-SUM c IF(SUMIP) 140, 140, 150 c140 WRITE (6,13) c GO TO 210 c150 WRITE (6,6) ANS(1) c WRITE (6,7) (B(J),J=1,I) c WRITE (6,8) I c WRITE (6,9) c SUM=ANS(4) c WRITE (6,10) I,ANS(4),ANS(6),ANS(10),SUMIP c NI=ANS(8) c WRITE (6,11) NI,ANS(7),ANS(9) c WRITE (6,12) NT,SUMSQ(MM) cC cC SAVE COEFFICIENTS FOR CALCULATION OF Y ESTIMATES cC c COE(1)=ANS(1) c DO 160 J=1,I c160 COE(J+1)=B(J) c LA=I c200 CONTINUE cC cC TEST WHETHER PLOT IS DESIRED cC c210 IF(NPLOT) 100, 100, 220 cC cC CALCULATE ESTIMATES cC c220 NP3=N+N c DO 230 I=1,N c NP3=NP3+1 c P(NP3)=COE(1) c L=I c DO 230 J=1,LA c P(NP3)=P(NP3)+X(L)*COE(J+1) c230 L=L+N cC cC COPY OBSERVED DATA cC c N2=N c L=N*M c DO 240 I=1,N c P(I)=X(I) c N2=N2+1 c L=L+1 c240 P(N2)=X(L) cC cC PRINT TABLE OF RESIDUALS cC c WRITE (6,3) PR,PR1 c WRITE (6,5) LA c WRITE (6,14) c NP2=N c NP3=N+N c DO 250 I=1,N c NP2=NP2+1 c NP3=NP3+1 c RESID=P(NP2)-P(NP3) c250 WRITE (6,15) I,P(I),P(NP2),P(NP3),RESID cC c CALL PLOT (LA,P,N,3,0,1) cC c GO TO 100 c999 STOP c END C C .................................................................. C C SUBROUTINE POLRT C C PURPOSE C COMPUTES THE REAL AND COMPLEX ROOTS OF A REAL POLYNOMIAL C C USAGE C CALL POLRT(XCOF,COF,M,ROOTR,ROOTI,IER) C C DESCRIPTION OF PARAMETERS C XCOF -VECTOR OF M+1 COEFFICIENTS OF THE POLYNOMIAL C ORDERED FROM SMALLEST TO LARGEST POWER C COF -WORKING VECTOR OF LENGTH M+1 C M -ORDER OF POLYNOMIAL C ROOTR-RESULTANT VECTOR OF LENGTH M CONTAINING REAL ROOTS C OF THE POLYNOMIAL C ROOTI-RESULTANT VECTOR OF LENGTH M CONTAINING THE C CORRESPONDING IMAGINARY ROOTS OF THE POLYNOMIAL C IER -ERROR CODE WHERE C IER=0 NO ERROR C IER=1 M LESS THAN ONE C IER=2 M GREATER THAN 36 C IER=3 UNABLE TO DETERMINE ROOT WITH 500 INTERATIONS C ON 5 STARTING VALUES C IER=4 HIGH ORDER COEFFICIENT IS ZERO C C REMARKS C LIMITED TO 36TH ORDER POLYNOMIAL OR LESS. C FLOATING POINT OVERFLOW MAY OCCUR FOR HIGH ORDER C POLYNOMIALS BUT WILL NOT AFFECT THE ACCURACY OF THE RESULTS. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C NEWTON-RAPHSON ITERATIVE TECHNIQUE. THE FINAL ITERATIONS C ON EACH ROOT ARE PERFORMED USING THE ORIGINAL POLYNOMIAL C RATHER THAN THE REDUCED POLYNOMIAL TO AVOID ACCUMULATED C ERRORS IN THE REDUCED POLYNOMIAL. C C .................................................................. C SUBROUTINE POLRT(XCOF,COF,M,ROOTR,ROOTI,IER) DIMENSION XCOF(1),COF(1),ROOTR(1),ROOTI(1) DOUBLE PRECISION XO,YO,X,Y,XPR,YPR,UX,UY,V,YT,XT,U,XT2,YT2,SUMSQ, 1 DX,DY,TEMP,ALPHA C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION XCOF,COF,ROOTR,ROOTI C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C THE DOUBLE PRECISION VERSION MAY BE MODIFIED BY CHANGING THE C CONSTANT IN STATEMENT 78 TO 1.0D-12 AND IN STATEMENT 122 TO C 1.0D-10. THIS WILL PROVIDE HIGHER PRECISION RESULTS AT THE C COST OF EXECUTION TIME C C ............................................................... C IFIT=0 N=M IER=0 IF(XCOF(N+1))10,25,10 10 IF(N) 15,15,32 C C SET ERROR CODE TO 1 C 15 IER=1 20 RETURN C C SET ERROR CODE TO 4 C 25 IER=4 GO TO 20 C C SET ERROR CODE TO 2 C 30 IER=2 GO TO 20 32 IF(N-36) 35,35,30 35 NX=N NXX=N+1 N2=1 KJ1 = N+1 DO 40 L=1,KJ1 MT=KJ1-L+1 40 COF(MT)=XCOF(L) C C SET INITIAL VALUES C 45 XO=.00500101 YO=0.01000101 C C ZERO INITIAL VALUE COUNTER C IN=0 50 X=XO C C INCREMENT INITIAL VALUES AND COUNTER C XO=-10.0*YO YO=-10.0*X C C SET X AND Y TO CURRENT VALUE C X=XO Y=YO IN=IN+1 GO TO 59 55 IFIT=1 XPR=X YPR=Y C C EVALUATE POLYNOMIAL AND DERIVATIVES C 59 ICT=0 60 UX=0.0 UY=0.0 V =0.0 YT=0.0 XT=1.0 U=COF(N+1) IF(U) 65,130,65 65 DO 70 I=1,N L =N-I+1 TEMP=COF(L) XT2=X*XT-Y*YT YT2=X*YT+Y*XT U=U+TEMP*XT2 V=V+TEMP*YT2 FI=I UX=UX+FI*XT*TEMP UY=UY-FI*YT*TEMP XT=XT2 70 YT=YT2 SUMSQ=UX*UX+UY*UY IF(SUMSQ) 75,110,75 75 DX=(V*UY-U*UX)/SUMSQ X=X+DX DY=-(U*UY+V*UX)/SUMSQ Y=Y+DY 78 IF(DABS(DY)+DABS(DX)-1.0D-05) 100,80,80 C C STEP ITERATION COUNTER C 80 ICT=ICT+1 IF(ICT-500) 60,85,85 85 IF(IFIT)100,90,100 90 IF(IN-5) 50,95,95 C C SET ERROR CODE TO 3 C 95 IER=3 GO TO 20 100 DO 105 L=1,NXX MT=KJ1-L+1 TEMP=XCOF(MT) XCOF(MT)=COF(L) 105 COF(L)=TEMP ITEMP=N N=NX NX=ITEMP IF(IFIT) 120,55,120 110 IF(IFIT) 115,50,115 115 X=XPR Y=YPR 120 IFIT=0 122 IF(DABS(Y)-1.0D-4*DABS(X)) 135,125,125 125 ALPHA=X+X SUMSQ=X*X+Y*Y N=N-2 GO TO 140 130 X=0.0 NX=NX-1 NXX=NXX-1 135 Y=0.0 SUMSQ=0.0 ALPHA=X N=N-1 140 COF(2)=COF(2)+ALPHA*COF(1) 145 DO 150 L=2,N 150 COF(L+1)=COF(L+1)+ALPHA*COF(L)-SUMSQ*COF(L-1) 155 ROOTI(N2)=Y ROOTR(N2)=X N2=N2+1 IF(SUMSQ) 160,165,160 160 Y=-Y SUMSQ=0.0 GO TO 155 165 IF(N) 20,20,45 END C C .................................................................. C C SUBROUTINE PPRCN C C PURPOSE C TO COMPUTE, GIVEN TWO PERMUTATION VECTORS IP1 AND IP2, THE C COMPOSITION IP2(IP1) AND THE CONJUGATE IP1(IP2(IP1 INVERSE)) C OF IP2 BY IP1. (SEE THE GENERAL DISCUSSION FOR DEFINITIONS C AND NOTATION.) C C USAGE C CALL PPRCN(IP1,IP2,IP3,N,IPAR,IER) C C DESCRIPTION OF PARAMETERS C IP1 - GIVEN PERMUTATION VECTOR (DIMENSION N) C IP2 - GIVEN PERMUTATION VECTOR (DIMENSION N) C IP3 - RESULTING PERMUTATION VECTOR (DIMENSION N) C N - DIMENSION OF VECTORS IP1, IP2 AND IP3 C IPAR - INPUT PARAMETER C IPAR NON-NEGATIVE - COMPUTE IP2(IP1) C IPAR NEGATIVE - COMPUTE IP1(IP2(IP1 INVERSE)) C IER - RESULTING ERROR PARAMETER C IER=-1 - N IS NOT POSITIVE C IER= 0 - NO ERROR C IER= 1 - IP1 AND IP2 ARE NOT BOTH PERMUTATION C VECTORS ON 1,...,N C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) IF IER=1, THEN COMPUTATION HAS BEEN UNSUCCESSFUL DUE TO C ERROR AND THE PARTIAL RESULTS FOUND IN IP2 ARE USELESS. C (3) IP3 CANNOT HAVE THE SAME STORAGE ALLOCATION AS IP1 OR C IP2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C PERM C C METHOD C SUBROUTINE PERM IS USED TO CHECK THAT IP1 AND IP2 ARE PERMU- C TATION VECTORS. IF IP2(IP1) IS COMPUTED, IP3(I) IS SET TO C IP2(IP1(I)) FOR I=1,...,N. IF IP1(IP2(IP1 INVERSE)) IS C COMPUTED, FIRST IP3 IS SET TO IP1 INVERSE BY SUBROUTINE PERM C AND THEN IP3(I) IS SET TO IP1(IP2(IP3(I))) FOR I=1,...,N. C C .................................................................. C SUBROUTINE PPRCN(IP1,IP2,IP3,N,IPAR,IER) C C DIMENSION IP1(1),IP2(1),IP3(1) C C CHECK THAT N IS POSITIVE AND THAT IP2 IS A PERMUTATION VECTOR CALL PERM(IP2,IP3,N,-1,IER) C C TEST IER TO SEE IF THERE IS AN ERROR IF(IER)7,1,7 C C CHECK THAT IP1 IS A PERMUTATION VECTOR AND COMPUTE IP1 INVERSE 1 CALL PERM(IP1,IP3,N,-1,IER) C C TEST IER TO SEE IF THERE IS AN ERROR IF(IER)7,2,7 C C TEST IPAR FOR THE DESIRED OPERATION 2 IF(IPAR)3,5,5 C C COMPUTE IP1(IP2(IP1 INVERSE)) 3 DO 4 I=1,N K=IP3(I) J=IP2(K) 4 IP3(I)=IP1(J) RETURN C C COMPUTE IP2(IP1) 5 DO 6 I=1,N K=IP1(I) 6 IP3(I)=IP2(K) 7 RETURN END C C .................................................................. C C SUBROUTINE PQFB C C PURPOSE C TO FIND AN APPROXIMATION Q(X)=Q1+Q2*X+X*X TO A QUADRATIC C FACTOR OF A GIVEN POLYNOMIAL P(X) WITH REAL COEFFICIENTS. C C USAGE C CALL PQFB(C,IC,Q,LIM,IER) C C DESCRIPTION OF PARAMETERS C C - INPUT VECTOR CONTAINING THE COEFFICIENTS OF P(X) - C C(1) IS THE CONSTANT TERM (DIMENSION IC) C IC - DIMENSION OF C C Q - VECTOR OF DIMENSION 4 - ON INPUT Q(1) AND Q(2) MUST C CONTAIN INITIAL GUESSES FOR Q1 AND Q2 - ON RETURN Q(1) C AND Q(2) CONTAIN THE REFINED COEFFICIENTS Q1 AND Q2 OF C Q(X), WHILE Q(3) AND Q(4) CONTAIN THE COEFFICIENTS A C AND B OF A+B*X, WHICH IS THE REMAINDER OF THE QUOTIENT C OF P(X) BY Q(X) C LIM - INPUT VALUE SPECIFYING THE MAXIMUM NUMBER OF C ITERATIONS TO BE PERFORMED C IER - RESULTING ERROR PARAMETER (SEE REMARKS) C IER= 0 - NO ERROR C IER= 1 - NO CONVERGENCE WITHIN LIM ITERATIONS C IER=-1 - THE POLYNOMIAL P(X) IS CONSTANT OR UNDEFINED C - OR OVERFLOW OCCURRED IN NORMALIZING P(X) C IER=-2 - THE POLYNOMIAL P(X) IS OF DEGREE 1 C IER=-3 - NO FURTHER REFINEMENT OF THE APPROXIMATION TO C A QUADRATIC FACTOR IS FEASIBLE, DUE TO EITHER C DIVISION BY 0, OVERFLOW OR AN INITIAL GUESS C THAT IS NOT SUFFICIENTLY CLOSE TO A FACTOR OF C P(X) C C REMARKS C (1) IF IER=-1 THERE IS NO COMPUTATION OTHER THAN THE C POSSIBLE NORMALIZATION OF C. C (2) IF IER=-2 THERE IS NO COMPUTATION OTHER THAN THE C NORMALIZATION OF C. C (3) IF IER =-3 IT IS SUGGESTED THAT A NEW INITIAL GUESS BE C MADE FOR A QUADRATIC FACTOR. Q, HOWEVER, WILL CONTAIN C THE VALUES ASSOCIATED WITH THE ITERATION THAT YIELDED C THE SMALLEST NORM OF THE MODIFIED LINEAR REMAINDER. C (4) IF IER=1, THEN, ALTHOUGH THE NUMBER OF ITERATIONS LIM C WAS TOO SMALL TO INDICATE CONVERGENCE, NO OTHER PROB- C LEMS HAVE BEEN DETECTED, AND Q WILL CONTAIN THE VALUES C ASSOCIATED WITH THE ITERATION THAT YIELDED THE SMALLEST C NORM OF THE MODIFIED LINEAR REMAINDER. C (5) FOR COMPLETE DETAIL SEE THE DOCUMENTATION FOR C SUBROUTINES PQFB AND DPQFB. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C COMPUTATION IS BASED ON BAIRSTOW'S ITERATIVE METHOD. (SEE C WILKINSON, J.H., THE EVALUATION OF THE ZEROS OF ILL-CON- C DITIONED POLYNOMIALS (PART ONE AND TWO), NUMERISCHE MATHE- C MATIK, VOL.1 (1959), PP. 150-180, OR HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP. 472-476.) C C .................................................................. C SUBROUTINE PQFB(C,IC,Q,LIM,IER) C C DIMENSION C(1),Q(1) C C TEST ON LEADING ZERO COEFFICIENTS IER=0 J=IC+1 1 J=J-1 IF(J-1)40,40,2 2 IF(C(J))3,1,3 C C NORMALIZATION OF REMAINING COEFFICIENTS 3 A=C(J) IF(A-1.)4,6,4 4 DO 5 I=1,J C(I)=C(I)/A CALL OVERFL(N) IF(N-2)40,5,5 5 CONTINUE C C TEST ON NECESSITY OF BAIRSTOW ITERATION 6 IF(J-3)41,38,7 C C PREPARE BAIRSTOW ITERATION 7 EPS=1.E-6 EPS1=1.E-3 L=0 LL=0 Q1=Q(1) Q2=Q(2) QQ1=0. QQ2=0. AA=C(1) BB=C(2) CB=ABS(AA) CA=ABS(BB) IF(CB-CA)8,9,10 8 CC=CB+CB CB=CB/CA CA=1. GO TO 11 9 CC=CA+CA CA=1. CB=1. GO TO 11 10 CC=CA+CA CA=CA/CB CB=1. 11 CD=CC*.1 C C START BAIRSTOW ITERATION C PREPARE NESTED MULTIPLICATION 12 A=0. B=A A1=A B1=A I=J QQQ1=Q1 QQQ2=Q2 DQ1=HH DQ2=H C C START NESTED MULTIPLICATION 13 H=-Q1*B-Q2*A+C(I) CALL OVERFL(N) IF(N-2)42,14,14 14 B=A A=H I=I-1 IF(I-1)18,15,16 15 H=0. 16 H=-Q1*B1-Q2*A1+H CALL OVERFL(N) IF(N-2)42,17,17 17 C1=B1 B1=A1 A1=H GO TO 13 C END OF NESTED MULTIPLICATION C C TEST ON SATISFACTORY ACCURACY 18 H=CA*ABS(A)+CB*ABS(B) IF(LL)19,19,39 19 L=L+1 IF(ABS(A)-EPS*ABS(C(1)))20,20,21 20 IF(ABS(B)-EPS*ABS(C(2)))39,39,21 C C TEST ON LINEAR REMAINDER OF MINIMUM NORM 21 IF(H-CC)22,22,23 22 AA=A BB=B CC=H QQ1=Q1 QQ2=Q2 C C TEST ON LAST ITERATION STEP 23 IF(L-LIM)28,28,24 C C TEST ON RESTART OF BAIRSTOW ITERATION WITH ZERO INITIAL GUESS 24 IF(H-CD)43,43,25 25 IF(Q(1))27,26,27 26 IF(Q(2))27,42,27 27 Q(1)=0. Q(2)=0. GO TO 7 C C PERFORM ITERATION STEP 28 HH=AMAX1(ABS(A1),ABS(B1),ABS(C1)) IF(HH)42,42,29 29 A1=A1/HH B1=B1/HH C1=C1/HH H=A1*C1-B1*B1 IF(H)30,42,30 30 A=A/HH B=B/HH HH=(B*A1-A*B1)/H H=(A*C1-B*B1)/H Q1=Q1+HH Q2=Q2+H C END OF ITERATION STEP C C TEST ON SATISFACTORY RELATIVE ERROR OF ITERATED VALUES IF(ABS(HH)-EPS*ABS(Q1))31,31,33 31 IF(ABS(H)-EPS*ABS(Q2))32,32,33 32 LL=1 GO TO 12 C C TEST ON DECREASING RELATIVE ERRORS 33 IF(L-1)12,12,34 34 IF(ABS(HH)-EPS1*ABS(Q1))35,35,12 35 IF(ABS(H)-EPS1*ABS(Q2))36,36,12 36 IF(ABS(QQQ1*HH)-ABS(Q1*DQ1))37,44,44 37 IF(ABS(QQQ2*H)-ABS(Q2*DQ2))12,44,44 C END OF BAIRSTOW ITERATION C C EXIT IN CASE OF QUADRATIC POLYNOMIAL 38 Q(1)=C(1) Q(2)=C(2) Q(3)=0. Q(4)=0. RETURN C C EXIT IN CASE OF SUFFICIENT ACCURACY 39 Q(1)=Q1 Q(2)=Q2 Q(3)=A Q(4)=B RETURN C C ERROR EXIT IN CASE OF ZERO OR CONSTANT POLYNOMIAL 40 IER=-1 RETURN C C ERROR EXIT IN CASE OF LINEAR POLYNOMIAL 41 IER=-2 RETURN C C ERROR EXIT IN CASE OF NONREFINED QUADRATIC FACTOR 42 IER=-3 GO TO 44 C C ERROR EXIT IN CASE OF UNSATISFACTORY ACCURACY 43 IER=1 44 Q(1)=QQ1 Q(2)=QQ2 Q(3)=AA Q(4)=BB RETURN END C C .................................................................. C C SUBROUTINE PQSD C C PURPOSE C PERFORM QUADRATIC SYNTHETIC DIVISION C C USAGE C CALL PQSD(A,B,P,Q,X,IDIMX) C C DESCRIPTION OF PARAMETERS C A - COEFFICIENT OF Z IN REMAINDER (CALCULATED) C B - CONSTANT TERM IN REMAINDER (CALCULATED) C P - COEFFICIENT OF Z IN QUADRATIC POLYNOMIAL C Q - CONSTANT TERM IN QUADRATIC POLYNOMIAL C X - COEFFICIENT VECTOR FOR GIVEN POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C POLYNOMIAL IS DIVIDED BY THE QUADRATIC Z**2-P*Z-Q GIVING C THE LINEAR REMAINDER A*Z+B C C .................................................................. C SUBROUTINE PQSD(A,B,P,Q,X,IDIMX) DIMENSION X(1) C A=0. B=0. J=IDIMX 1 IF(J)3,3,2 2 Z=P*A+B B=Q*A+X(J) A=Z J=J-1 GO TO 1 3 RETURN END C C .................................................................. C C SUBROUTINE PRBM C C PURPOSE C TO CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN C POLYNOMIAL WITH REAL COEFFICIENTS. C C USAGE C CALL PRBM (C,IC,RR,RC,POL,IR,IER) C C DESCRIPTION OF PARAMETERS C C - INPUT VECTOR CONTAINING THE COEFFICIENTS OF THE C GIVEN POLYNOMIAL. COEFFICIENTS ARE ORDERED FROM C LOW TO HIGH. ON RETURN COEFFICIENTS ARE DIVIDED C BY THE LAST NONZERO TERM. C IC - DIMENSION OF VECTORS C, RR, RC, AND POL. C RR - RESULTANT VECTOR OF REAL PARTS OF THE ROOTS. C RC - RESULTANT VECTOR OF COMPLEX PARTS OF THE ROOTS. C POL - RESULTANT VECTOR OF COEFFICIENTS OF THE POLYNOMIAL C WITH CALCULATED ROOTS. COEFFICIENTS ARE ORDERED C FROM LOW TO HIGH (SEE REMARK 4). C IR - OUTPUT VALUE SPECIFYING THE NUMBER OF CALCULATED C ROOTS. NORMALLY IR IS EQUAL TO IC-1. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - SUBROUTINE PQFB RECORDS POOR CONVERGENCE C AT SOME QUADRATIC FACTORIZATION WITHIN C 50 ITERATION STEPS, C IER=2 - POLYNOMIAL IS DEGENERATE, I.E. ZERO OR C CONSTANT, C OR OVERFLOW IN NORMALIZATION OF GIVEN C POLYNOMIAL, C IER=3 - THE SUBROUTINE IS BYPASSED DUE TO C SUCCESSIVE ZERO DIVISORS OR OVERFLOWS C IN QUADRATIC FACTORIZATION OR DUE TO C COMPLETELY UNSATISFACTORY ACCURACY, C IER=-1 - CALCULATED COEFFICIENT VECTOR HAS LESS C THAN THREE CORRECT SIGNIFICANT DIGITS. C THIS REVEALS POOR ACCURACY OF CALCULATED C ROOTS. C C REMARKS C (1) REAL PARTS OF THE ROOTS ARE STORED IN RR(1) UP TO RR(IR) C AND CORRESPONDING COMPLEX PARTS IN RC(1) UP TO RC(IR). C (2) ERROR MESSAGE IER=1 INDICATES POOR CONVERGENCE WITHIN C 50 ITERATION STEPS AT SOME QUADRQTIC FACTORIZATION C PERFORMED BY SUBROUTINE PQFB. C (3) NO ACTION BESIDES ERROR MESSAGE IER=2 IN CASE OF A ZERO C OR CONSTANT POLYNOMIAL. THE SAME ERROR MESSAGE IS GIVEN C IN CASE OF AN OVERFLOW IN NORMALIZATION OF GIVEN C POLYNOMIAL. C (4) ERROR MESSAGE IER=3 INDICATES SUCCESSIVE ZERO DIVISORS C OR OVERFLOWS OR COMPLETELY UNSATISFACTORY ACCURACY AT C ANY QUADRATIC FACTORIZATION PERFORMED BY C SUBROUTINE PQFB. IN THIS CASE CALCULATION IS BYPASSED. C IR RECORDS THE NUMBER OF CALCULATED ROOTS. C POL(1),...,POL(J-IR) ARE THE COEFFICIENTS OF THE C REMAINING POLYNOMIAL, WHERE J IS THE ACTUAL NUMBER OF C COEFFICIENTS IN VECTOR C (NORMALLY J=IC). C (5) IF CALCULATED COEFFICIENT VECTOR HAS LESS THAN THREE C CORRECT SIGNIFICANT DIGITS THOUGH ALL QUADRATIC C FACTORIZATIONS SHOWED SATISFACTORY ACCURACY, THE ERROR C MESSAGE IER=-1 IS GIVEN. C (6) THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED C COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE C BEEN CALCULATED. IN THIS CASE THE NUMBER OF ROOTS IR IS C EQUAL TO THE ACTUAL DEGREE OF THE POLYNOMIAL (NORMALLY C IR=IC-1). THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT C VECTOR IS RECORDED IN RR(IR+1). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SUBROUTINE PQFB QUADRATIC FACTORIZATION OF A POLYNOMIAL C BY BAIRSTOW ITERATION. C C METHOD C THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF C SUCCESSIVE QUADRATIC FACTORIZATION PERFORMED BY BAIRSTOW C ITERATION. X**2 IS USED AS INITIAL GUESS FOR THE FIRST C QUADRATIC FACTOR, AND FURTHER EACH CALCULATED QUADRATIC C FACTOR IS USED AS INITIAL GUESS FOR THE NEXT ONE. AFTER C COMPUTATION OF ALL ROOTS THE COEFFICIENT VECTOR IS C CALCULATED AND COMPARED WITH THE GIVEN ONE. C FOR REFERENCE, SEE J. H. WILKINSON, THE EVALUATION OF THE C ZEROS OF ILL-CONDITIONED POLYNOMIALS (PART ONE AND TWO), C NUMERISCHE MATHEMATIK, VOL.1 (1959), PP.150-180. C C .................................................................. C SUBROUTINE PRBM(C,IC,RR,RC,POL,IR,IER) C C DIMENSION C(1),RR(1),RC(1),POL(1),Q(4) C C TEST ON LEADING ZERO COEFFICIENTS EPS=1.E-3 LIM=50 IR=IC+1 1 IR=IR-1 IF(IR-1)42,42,2 2 IF(C(IR))3,1,3 C C WORK UP ZERO ROOTS AND NORMALIZE REMAINING POLYNOMIAL 3 IER=0 J=IR L=0 A=C(IR) DO 8 I=1,IR IF(L)4,4,7 4 IF(C(I))6,5,6 5 RR(I)=0. RC(I)=0. POL(J)=0. J=J-1 GO TO 8 6 L=1 IST=I J=0 7 J=J+1 C(I)=C(I)/A POL(J)=C(I) CALL OVERFL(N) IF(N-2)42,8,8 8 CONTINUE C C START BAIRSTOW ITERATION Q1=0. Q2=0. 9 IF(J-2)33,10,14 C C DEGREE OF RESTPOLYNOMIAL IS EQUAL TO ONE 10 A=POL(1) RR(IST)=-A RC(IST)=0. IR=IR-1 Q2=0. IF(IR-1)13,13,11 11 DO 12 I=2,IR Q1=Q2 Q2=POL(I+1) 12 POL(I)=A*Q2+Q1 13 POL(IR+1)=A+Q2 GO TO 34 C THIS IS BRANCH TO COMPARISON OF COEFFICIENT VECTORS C AND POL C C DEGREE OF RESTPOLYNOMIAL IS GREATER THAN ONE 14 DO 22 L=1,10 N=1 15 Q(1)=Q1 Q(2)=Q2 CALL PQFB(POL,J,Q,LIM,I) IF(I)16,24,23 16 IF(Q1)18,17,18 17 IF(Q2)18,21,18 18 GO TO (19,20,19,21),N 19 Q1=-Q1 N=N+1 GO TO 15 20 Q2=-Q2 N=N+1 GO TO 15 21 Q1=1.+Q1 22 Q2=1.-Q2 C C ERROR EXIT DUE TO UNSATISFACTORY RESULTS OF FACTORIZATION IER=3 IR=IR-J RETURN C C WORK UP RESULTS OF QUADRATIC FACTORIZATION 23 IER=1 24 Q1=Q(1) Q2=Q(2) C C PERFORM DIVISION OF FACTORIZED POLYNOMIAL BY QUADRATIC FACTOR B=0. A=0. I=J 25 H=-Q1*B-Q2*A+POL(I) POL(I)=B B=A A=H I=I-1 IF(I-2)26,26,25 26 POL(2)=B POL(1)=A C C MULTIPLY POLYNOMIAL WITH CALCULATED ROOTS BY QUADRATIC FACTOR L=IR-1 IF(J-L)27,27,29 27 DO 28 I=J,L 28 POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1 29 POL(L)=POL(L)+POL(L+1)*Q2+Q1 POL(IR)=POL(IR)+Q2 C C CALCULATE ROOT-PAIR FROM QUADRATIC FACTOR X*X+Q2*X+Q1 H=-.5*Q2 A=H*H-Q1 B=SQRT(ABS(A)) IF(A)30,30,31 30 RR(IST)=H RC(IST)=B IST=IST+1 RR(IST)=H RC(IST)=-B GO TO 32 31 B=H+SIGN(B,H) RR(IST)=Q1/B RC(IST)=0. IST=IST+1 RR(IST)=B RC(IST)=0. 32 IST=IST+1 J=J-2 GO TO 9 C C SHIFT BACK ELEMENTS OF POL BY 1 AND COMPARE VECTORS POL AND C 33 IR=IR-1 34 A=0. DO 38 I=1,IR Q1=C(I) Q2=POL(I+1) POL(I)=Q2 IF(Q1)35,36,35 35 Q2=(Q1-Q2)/Q1 36 Q2=ABS(Q2) IF(Q2-A)38,38,37 37 A=Q2 38 CONTINUE I=IR+1 POL(I)=1. RR(I)=A RC(I)=0. IF(IER)39,39,41 39 IF(A-EPS)41,41,40 C C WARNING DUE TO POOR ACCURACY OF CALCULATED COEFFICIENT VECTOR 40 IER=-1 41 RETURN C C ERROR EXIT DUE TO DEGENERATE POLYNOMIAL OR OVERFLOW IN C NORMALIZATION 42 IER=2 IR=0 RETURN END C FUNCTION PROB(NOPT,X,N1,N2) C C THIS FUNCTION SUBPROGRAM COMPUTES THE PROBALITY CORRESPONDING C TO GIVEN VALUE OF A VARIANCE-RATIO, CHI-SQUARED, STUDENT'S, C OR STANDARDISED NORMAL DEVIATE, PARAMETERS ARE AS FOLLOWS: C NOPT= 1 FOR CHI-SQUARED (ONE-TAILED TEST) C 2 FOR STUDENT'S T(TWO-TAILED TEST) C 3 FOR STANDARDISED NORMAL DEVIATE (TWO-TAILED TEST) C 4 FOR VARIANCE RATIO (ONE-TAILED) C X= NUMERICAL VALUE OF TEST-STATISTIC C SPECIFIED BY NOPT C N1= DEGEES OF FREEDOM (FOR NUMERATOR IF NOPT=4 C SPECIFY ZERO IF NOPT=3) C N2= DEGREES OF FREEDOM FOR DENOMINATOR IF NOPT=4 C OTHERWISE SPECIFY ZERO) C NOTE-FOR ACCURACY SEE GOLDEN, WEISS AND DAWIS (1968) C EDUC. PHYSIOL. MEASUREMENT, VOL. 28, PP. 163-165 C C AN1=N1 AN2=N2 C C CONVERT TEST STATISTIC TO VARIANCE RATIO IF NECESSARY. C GO TO (1,2,3,4), NOPT 1 F=X/AN1 AN2=1.0E+10 GO TO 5 2 F=X*X AN1=1.0 AN2=N1 GO TO 5 3 Z=ABS(X) F=10.0 GO TO 7 4 F=X 5 FF=F PROB=1.0 IF(AN1*AN2*F.EQ.0.0) RETURN C C TAKE RECIPROCAL IF F LESS THEN 1. C IF(F.GE.1.0) GO TO 6 FF=1.0/F TEMP=AN1 AN1=AN2 AN2=TEMP C C NORMALISE VARIANCE RATIO C 6 A1=2.0/AN1/9.0 A2=2.0/AN2/9.0 Z=ABS(((1.0-A2)*FF**0.333333-1.0+A1)/SQRT(A2*FF** 1 0.666666+A1)) IF(AN2.LE.3.0) Z=Z*(1.0+0.08*Z**4/AN2**3) C C COMPUTE PROBABILITY C 7 FZ=EXP(-Z*Z/2.0)*0.3989423 W=1.0/(1.0+Z*0.2316419) PROB=FZ*W*((((1.330274*W-1.821256)*W+ 1 1.781478)*W-0.3565638)*W+0.3193815) IF(NOPT.EQ.3) PROB=2.0*PROB IF(F.LT.1.0) PROB=1.0-PROB RETURN END C C .................................................................. C C SUBROUTINE PROBT C C PURPOSE C TO OBTAIN MAXIMUM LIKELIHOOD ESTIMATES FOR THE PARAMETERS A C AND B IN THE PROBIT EQUATION Y = A + BX. AN ITERATIVE C SCHEME IS USED. THE INPUT TO THE SUBROUTINE CONSISTS OF K C DIFFERENT DOSAGE LEVELS APPLIED TO K GROUPS OF SUBJECTS, AND C THE NUMBER OF SUBJECTS IN EACH GROUP RESPONDING TO THE C RESPECTIVE DOSAGE OF THE DRUG. C C USAGE C CALL PROBT (K,X,S,R,LOG,ANS,W1,W2,IER) C C DESCRIPTION OF PARAMETERS C K - NUMBER OF DIFFERENT DOSE LEVELS OF THE DRUG. K SHOULD C BE GREATER THAN 2. C X - INPUT VECTOR OF LENGTH K CONTAINING THE DOSE LEVEL OF C THE DRUG TESTED. X MUST BE NON-NEGATIVE. C S - INPUT VECTOR OF LENGTH K CONTAINING THE NUMBER OF C SUBJECTS TESTED AT EACH DOSE LEVEL C R - INPUT VECTOR OF LENGTH K CONTAINING THE NUMBER OF C SUBJECTS AT EACH LEVEL RESPONDING TO THE DRUG C LOG - INPUT OPTION CODE C 1- IF IT IS DESIRED TO CONVERT THE DOSE LEVELS TO C COMMON LOGARITHMS. THE DOSAGE LEVELS SHOULD BE C NON-NULL IN THIS CASE. C 0- IF NO CONVERSION IS DESIRED C ANS - OUTPUT VECTOR OF LENGTH 4 CONTAINING THE FOLLOWING C RESULTS C ANS(1)- ESTIMATE OF THE INTERCEPT CONSTANT A C ANS(2)- ESTIMATE OF THE PROBIT REGRESSION COEFFICIENT C B C ANS(3)- CHI-SQUARED VALUE FOR A TEST OF SIGNIFICANCE C OF THE FINAL PROBIT EQUATION C ANS(4)- DEGREES OF FREEDOM FOR THE CHI-SQUARE C STATISTIC C W1 - OUTPUT VECTOR OF LENGTH K CONTAINING THE PROPORTIONS C OF SUBJECTS RESPONDING TO THE VARIOUS DOSE LEVELS OF C THE DRUG C W2 - OUTPUT VECTOR OF LENGTH K CONTAINING THE VALUES OF THE C EXPECTED PROBIT FOR THE VARIOUS LEVELS OF A DRUG C IER - 1 IF K IS NOT GREATER THAN 2. C 2 IF SOME DOSAGE LEVEL IS NEGATIVE, OR IF THE INPUT C OPTION CODE LOG IS 1 AND SOME DOSAGE LEVEL IS ZERO. C 3 IF SOME ELEMENT OF S IS NOT POSITIVE. C 4 IF NUMBER OF SUBJECTS RESPONDING IS GREATER THAN C NUMBER OF SUBJECTS TESTED. C ONLY IF IER IS ZERO IS A PROBIT ANALYSIS PERFORMED. C OTHERWISE, ANS, W1, AND W2 ARE SET TO ZERO. C C REMARKS C THE PROGRAM WILL ITERATE ON THE PROBIT EQUATION UNTIL TWO C SUCCESSIVE SOLUTIONS PRODUCE CHANGES OF LESS THAN 10**(-7). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NDTR C NDTRI C C METHOD C REFER TO D. J. FINNEY, PROBIT ANALYSIS. 2ND ED. (CAMBRIDGE, C 1952) C C .................................................................. C SUBROUTINE PROBT (K,X,S,R,LOG,ANS,W1,W2,IER) C DIMENSION X(1),S(1),R(1),ANS(1),W1(1),W2(1) C C TEST WHETHER LOG CONVERSION IS NEEDED C IER=0 IF(K-2)5,5,7 5 IER = 1 GO TO 90 7 DO 8 I=1,K IF(X(I))12,8,8 8 CONTINUE IF(LOG-1) 16,10,16 10 DO 15 I=1,K IF(X(I))12,12,14 12 IER=2 GO TO 90 14 X(I)= ALOG10(X(I)) 15 CONTINUE C C COMPUTE PROPORTIONS OF OBJECTS RESPONDING C 16 DO 18 I=1,K IF(S(I)-R(I)) 17,18,18 17 IER=4 GO TO 90 18 CONTINUE 20 DO 23 I=1,K IF(S(I))21,21,22 21 IER=3 GO TO 90 22 W1(I)=R(I)/S(I) 23 CONTINUE C C COMPUTE INITIAL ESTIMATES OF INTERCEPT AND PROBIT REGRESSION C COEFFICIENT C WN=0.0 XBAR=0.0 SNWY=0.0 SXX=0.0 SXY=0.0 C DO 30 I=1,K P=W1(I) IF(P) 30, 30, 24 24 IF(P-1.0) 25, 30, 30 25 WN=WN+1.0 C CALL NDTRI (P,Z,D,IER) C Z=Z+5.0 XBAR=XBAR+X(I) SNWY=SNWY+Z SXX=SXX+X(I)**2 SXY=SXY+X(I)*Z 30 CONTINUE C B=(SXY-(XBAR*SNWY)/WN)/(SXX-(XBAR*XBAR)/WN) XBAR=XBAR/WN SNWY=SNWY/WN A=SNWY-B*XBAR DD=0.0 C C COMPUTE EXPECTED PROBIT C DO 31 I=1,K 31 W2(I)=A+B*X(I) C 33 SNW=0.0 SNWX=0.0 SNWY=0.0 SNWXX=0.0 SNWXY=0.0 DO 50 I=1,K Y=W2(I) C C FIND A WEIGHTING COEFFICIENT FOR PROBIT ANALYSIS C D=Y-5.0 C CALL NDTR (D,P,Z) C Q=1.0-P W=(Z*Z)/(P*Q) C C COMPUTE WORKING PROBIT C IF(Y-5.0) 35, 35, 40 35 WP=(Y-P/Z)+W1(I)/Z GO TO 45 40 WP=(Y+Q/Z)-(1.0-W1(I))/Z C C SUM INTERMEDIATE RESULTS C 45 WN=W*S(I) SNW=SNW+WN SNWX=SNWX+WN*X(I) SNWY=SNWY+WN*WP SNWXX=SNWXX+WN*X(I)**2 50 SNWXY=SNWXY+WN*X(I)*WP C C COMPUTE NEW ESTIMATES OF INTERCEPT AND COEFFICIENT C XBAR=SNWX/SNW C SXX=SNWXX-(SNWX)*(SNWX)/SNW SXY=SNWXY-(SNWX)*(SNWY)/SNW B=SXY/SXX C A=SNWY/SNW-B*XBAR C C EXAMINE THE CHANGES IN Y C SXX=0.0 DO 60 I=1,K Y=A+B*X(I) D=W2(I)-Y SXX=SXX+D*D 60 W2(I)=Y IF(( ABS(DD-SXX))-(1.0E-7)) 65, 65, 63 63 DD=SXX GO TO 33 C C STORE INTERCEPT AND COEFFICIENT C 65 ANS(1)=A ANS(2)=B C C COMPUTE CHI-SQUARE C ANS(3)=0.0 DO 70 I=1,K Y=W2(I)-5.0 C CALL NDTR (Y,P,D) C AA=R(I)-S(I)*P DD=S(I)*P*(1.0-P) 70 ANS(3)=ANS(3)+AA*AA/DD C C DEGREES OF FREEDOM FOR CHI-SQUARE C ANS(4)=K-2 C 80 RETURN 90 DO 100 I=1,K W1(I)=0.0 100 W2(I)=0.0 DO 110 I=1,4 110 ANS(I)=0.0 GO TO 80 END C C .................................................................. C C SUBROUTINE PRQD C C PURPOSE C CALCULATE ALL REAL AND COMPLEX ROOTS OF A GIVEN POLYNOMIAL C WITH REAL COEFFICIENTS. C C USAGE C CALL PRQD(C,IC,Q,E,POL,IR,IER) C C DESCRIPTION OF PARAMETERS C C - COEFFICIENT VECTOR OF GIVEN POLYNOMIAL C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C THE GIVEN COEFFICIENT VECTOR GETS DIVIDED BY THE C LAST NONZERO TERM C IC - DIMENSION OF VECTOR C C Q - WORKING STORAGE OF DIMENSION IC C ON RETURN Q CONTAINS REAL PARTS OF ROOTS C E - WORKING STORAGE OF DIMENSION IC C ON RETURN E CONTAINS COMPLEX PARTS OF ROOTS C POL - WORKING STORAGE OF DIMENSION IC C ON RETURN POL CONTAINS THE COEFFICIENTS OF THE C POLYNOMIAL WITH CALCULATED ROOTS C THIS RESULTING COEFFICIENT VECTOR HAS DIMENSION IR+1 C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C IR - NUMBER OF CALCULATED ROOTS C NORMALLY IR IS EQUAL TO DIMENSION IC MINUS ONE C IER - RESULTING ERROR PARAMETER. SEE REMARKS C C REMARKS C THE REAL PART OF THE ROOTS IS STORED IN Q(1) UP TO Q(IR) C CORRESPONDING COMPLEX PARTS ARE STORED IN E(1) UP TO E(IR). C IER = 0 MEANS NO ERRORS C IER = 1 MEANS NO CONVERGENCE WITH FEASIBLE TOLERANCE C IER = 2 MEANS POLYNOMIAL IS DEGENERATE (CONSTANT OR ZERO) C IER = 3 MEANS SUBROUTINE WAS ABANDONED DUE TO ZERO DIVISOR C IER = 4 MEANS THERE EXISTS NO S-FRACTION C IER =-1 MEANS CALCULATED COEFFICIENT VECTOR REVEALS POOR C ACCURACY OF THE CALCULATED ROOTS. C THE CALCULATED COEFFICIENT VECTOR HAS LESS THAN C 3 CORRECT DIGITS. C THE FINAL COMPARISON BETWEEN GIVEN AND CALCULATED C COEFFICIENT VECTOR IS PERFORMED ONLY IF ALL ROOTS HAVE BEEN C CALCULATED. C THE MAXIMAL RELATIVE ERROR OF THE COEFFICIENT VECTOR IS C RECORDED IN Q(IR+1). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE ROOTS OF THE POLYNOMIAL ARE CALCULATED BY MEANS OF C THE QUOTIENT-DIFFERENCE ALGORITHM WITH DISPLACEMENT. C REFERENCE C H.RUTISHAUSER, DER QUOTIENTEN-DIFFERENZEN-ALGORITHMUS, C BIRKHAEUSER, BASEL/STUTTGART, 1957. C C .................................................................. C c SUBROUTINE PRQD(C,IC,Q,E,POL,IR,IER) cC cC DIMENSIONED DUMMY VARIABLES c DIMENSION E(1),Q(1),C(1),POL(1) cC C NORMALIZATION OF GIVEN POLYNOM SUBROUTINE PRQD(C,IC,Q,E,POL,IR,IER) DIMENSION E(1),Q(1),C(1),POL(1) IER=0 IR=IC EPS=1.E-6 TOL=1.E-3 LIMIT=10*IC KOUNT=0 1 IF(IR-1)79,79,2 2 IF(C(IR))4,3,4 3 IR=IR-1 GOTO 1 4 O=1./C(IR) IEND=IR-1 ISTA=1 NSAV=IR+1 JBEG=1 DO 9 I=1,IR J=NSAV-I IF(C(I))7,5,7 5 GOTO(6,8),JBEG 6 NSAV=NSAV+1 Q(ISTA)=0. E(ISTA)=0. ISTA=ISTA+1 GOTO 9 7 JBEG=2 8 Q(J)=C(I)*O C(I)=Q(J) 9 CONTINUE ESAV=0. Q(ISTA)=0. 10 NSAV=IR EXPT=IR-ISTA E(ISTA)=EXPT DO 11 I=ISTA,IEND EXPT=EXPT-1.0 POL(I+1)=EPS*ABS(Q(I+1))+EPS 11 E(I+1)=Q(I+1)*EXPT IF(ISTA-IEND)12,20,60 12 JEND=IEND-1 DO 19 I=ISTA,JEND IF(I-ISTA)13,16,13 13 IF(ABS(E(I))-POL(I+1))14,14,16 14 NSAV=I DO 15 K=I,JEND IF(ABS(E(K))-POL(K+1))15,15,80 15 CONTINUE GOTO 21 16 DO 19 K=I,IEND E(K+1)=E(K+1)/E(I) Q(K+1)=E(K+1)-Q(K+1) IF(K-I)18,17,18 17 IF(ABS(Q(I+1))-POL(I+1))80,80,19 18 Q(K+1)=Q(K+1)/Q(I+1) POL(K+1)=POL(K+1)/ABS(Q(I+1)) E(K)=Q(K+1)-E(K) 19 CONTINUE 20 Q(IR)=-Q(IR) 21 E(ISTA)=0. NRAN=NSAV-1 22 E(NRAN+1)=0. IF(NRAN-ISTA)24,23,31 23 Q(ISTA+1)=Q(ISTA+1)+EXPT E(ISTA+1)=0. 24 E(ISTA)=ESAV IF(IR-NSAV)60,60,25 25 ISTA=NSAV ESAV=E(ISTA) GOTO 10 26 P=P+EXPT IF(O)27,28,28 27 Q(NRAN)=P Q(NRAN+1)=P E(NRAN)=T E(NRAN+1)=-T GOTO 29 28 Q(NRAN)=P-T Q(NRAN+1)=P+T E(NRAN)=0. 29 NRAN=NRAN-2 GOTO 22 30 Q(NRAN+1)=EXPT+P NRAN=NRAN-1 GOTO 22 31 JBEG=ISTA+1 JEND=NRAN-1 TEPS=EPS TDELT=1.E-2 32 KOUNT=KOUNT+1 P=Q(NRAN+1) R=ABS(E(NRAN)) IF(R-TEPS)30,30,33 33 S=ABS(E(JEND)) IF(S-R)38,38,34 34 IF(R-TDELT)36,35,35 35 P=0. 36 O=P DO 37 J=JBEG,NRAN Q(J)=Q(J)+E(J)-E(J-1)-O IF(ABS(Q(J))-POL(J))81,81,37 37 E(J)=Q(J+1)*E(J)/Q(J) Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O GOTO 54 38 P=0.5*(Q(NRAN)+E(NRAN)+Q(NRAN+1)) O=P*P-Q(NRAN)*Q(NRAN+1) T=SQRT(ABS(O)) IF(S-TEPS)26,26,39 39 IF(O)43,40,40 40 IF(P)42,41,41 41 T=-T 42 P=P+T R=S GOTO 34 43 IF(S-TDELT)44,35,35 44 O=Q(JBEG)+E(JBEG)-P IF(ABS(O)-POL(JBEG))81,81,45 45 T=(T/O)**2 U=E(JBEG)*Q(JBEG+1)/(O*(1.+T)) V=O+U KOUNT=KOUNT+2 DO 53 J=JBEG,NRAN O=Q(J+1)+E(J+1)-U-P IF(ABS(V)-POL(J))46,46,49 46 IF(J-NRAN)81,47,81 47 EXPT=EXPT+P IF(ABS(E(JEND))-TOL)48,48,81 48 P=0.5*(V+O-E(JEND)) O=P*P-(V-U)*(O-U*T-O*W*(1.+T)/Q(JEND)) T=SQRT(ABS(O)) GOTO 26 49 IF(ABS(O)-POL(J+1))46,46,50 50 W=U*O/V T=T*(V/O)**2 Q(J)=V+W-E(J-1) U=0. IF(J-NRAN)51,52,52 51 U=Q(J+2)*E(J+1)/(O*(1.+T)) 52 V=O+U-W IF(ABS(Q(J))-POL(J))81,81,53 53 E(J)=W*V*(1.+T)/Q(J) Q(NRAN+1)=V-E(NRAN) 54 EXPT=EXPT+P TEPS=TEPS*1.1 TDELT=TDELT*1.1 IF(KOUNT-LIMIT)32,55,55 55 IER=1 56 IEND=NSAV-NRAN-1 E(ISTA)=ESAV IF(IEND)59,59,57 57 DO 58 I=1,IEND J=ISTA+I K=NRAN+1+I E(J)=E(K) 58 Q(J)=Q(K) 59 IR=ISTA+IEND 60 IR=IR-1 IF(IR)78,78,61 61 DO 62 I=1,IR Q(I)=Q(I+1) 62 E(I)=E(I+1) POL(IR+1)=1. IEND=IR-1 JBEG=1 DO 69 J=1,IR ISTA=IR+1-J O=0. P=Q(ISTA) T=E(ISTA) IF(T)65,63,65 63 DO 64 I=ISTA,IR POL(I)=O-P*POL(I+1) 64 O=POL(I+1) GOTO 69 65 GOTO(66,67),JBEG 66 JBEG=2 POL(ISTA)=0. GOTO 69 67 JBEG=1 U=P*P+T*T P=P+P DO 68 I=ISTA,IEND POL(I)=O-P*POL(I+1)+U*POL(I+2) 68 O=POL(I+1) POL(IR)=O-P 69 CONTINUE IF(IER)78,70,78 70 P=0. DO 75 I=1,IR IF(C(I))72,71,72 71 O=ABS(POL(I)) GOTO 73 72 O=ABS((POL(I)-C(I))/C(I)) 73 IF(P-O)74,75,75 74 P=O 75 CONTINUE IF(P-TOL)77,76,76 76 IER=-1 77 Q(IR+1)=P E(IR+1)=0. 78 RETURN 79 IER=2 IR=0 RETURN 80 IER=4 IR=ISTA GOTO 60 81 IER=3 GOTO 56 END C C .................................................................. C C SUBROUTINE PSUB C C PURPOSE C SUBTRACT ONE POLYNOMIAL FROM ANOTHER C C USAGE C CALL PSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY) C C DESCRIPTION OF PARAMETERS C Z - VECTOR OF RESULTANT COEFFICIENTS, ORDERED FROM C SMALLEST TO LARGEST POWER C IDIMZ - DIMENSION OF Z (CALCULATED) C X - VECTOR OF COEFFICIENTS FOR FIRST POLYNOMIAL, ORDERED C FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X (DEGREE IS IDIMX-1) C Y - VECTOR OF COEFFICIENTS FOR SECOND POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMY - DIMENSION OF Y (DEGREE IS IDIMY-1) C C REMARKS C VECTOR Z MAY BE IN SAME LOCATION AS EITHER VECTOR X OR C VECTOR Y ONLY IF THE DIMENSION OF THAT VECTOR IS NOT LESS C THAN THE OTHER INPUT VECTOR C THE RESULTANT POLYNOMIAL MAY HAVE TRAILING ZERO COEFFICIENTS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DIMENSION OF RESULTANT VECTOR IDIMZ IS CALCULATED AS THE C LARGER OF THE TWO INPUT VECTOR DIMENSIONS. COEFFICIENTS IN C VECTOR Y ARE THEN SUBTRACTED FROM CORRESPONDING COEFFICIENTS C IN VECTOR X. C C .................................................................. C SUBROUTINE PSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) C C TEST DIMENSIONS OF SUMMANDS C NDIM=IDIMX IF (IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF (NDIM) 90,90,30 30 DO 80 I=1,NDIM IF (I-IDIMX) 40,40,60 40 IF (I-IDIMY) 50,50,70 50 Z(I)=X(I)-Y(I) GO TO 80 60 Z(I)=-Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END C C .................................................................. C C SUBROUTINE PVAL C C PURPOSE C EVALUATE A POLYNOMIAL FOR A GIVEN VALUE OF THE VARIABLE C C USAGE C CALL PVAL(RES,ARG,X,IDIMX) C C DESCRIPTION OF PARAMETERS C RES - RESULTANT VALUE OF POLYNOMIAL C ARG - GIVEN VALUE OF THE VARIABLE C X - VECTOR OF COEFFICIENTS, ORDERED FROM SMALLEST TO C LARGEST POWER C IDIMX - DIMENSION OF X C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EVALUATION IS DONE BY MEANS OF NESTED MULTIPLICATION C C .................................................................. C SUBROUTINE PVAL(RES,ARG,X,IDIMX) DIMENSION X(1) C RES=0. J=IDIMX 1 IF(J)3,3,2 2 RES=RES*ARG+X(J) J=J-1 GO TO 1 3 RETURN END FUNCTION PVALUE(GIJ,M,N) PVALUE=1 G=ABS(GIJ) IF(G.LE.0)GOTO 999 IF(M.GT.0)GOTO 10 G=G*G M=1 10 P=1. IF(G.LT.1.)GOTO 20 IA=M IB=N F=G GOTO 30 20 IA=N IB=M F=1./G 30 B=IB A1=2./(9.*IA) B1=2./(9.*IB) Z=ABS((1.-B1)*F**0.333333-1.+A1) Z=Z/SQRT(B1*F**0.666667+A1) IF(IB.LT.4.) Z=Z*(1.+0.08*Z**4/B**3) P=(1.+Z*(0.196854+Z*(0.115194+Z*(0.000344+Z*0.019527))))**4 P=0.5/P IF(G.LT.1.)P=1.-P PVALUE=AINT(100000.*P)/100000. 999 RETURN END C C C .................................................................. C C SUBROUTINE PVSUB C C PURPOSE C SUBSTITUTE VARIABLE OF A POLYNOMIAL BY ANOTHER POLYNOMIAL C C USAGE C CALL PVSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY,WORK1,WORK2) C C DESCRIPTION OF PARAMETERS C Z - VECTOR OF COEFFICIENTS FOR RESULTANT POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMZ - DIMENSION OF Z C X - VECTOR OF COEFFICIENTS FOR ORIGINAL POLYNOMIAL, C ORDERED FROM SMALLEST TO LARGEST POWER C IDIMX - DIMENSION OF X C Y - VECTOR OF COEFFICIENTS FOR POLYNOMIAL WHICH IS C SUBSTITUTED FOR VARIABLE, ORDERED FROM SMALLEST TO C LARGEST POWER C IDIMY - DIMENSION OF Y C WORK1 - WORKING STORAGE ARRAY (SAME DIMENSION AS Z) C WORK2 - WORKING STORAGE ARRAY (SAME DIMENSION AS Z) C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C PMPY C PADDM C PCLA C C METHOD C VARIABLE OF POLYNOMIAL X IS SUBSTITUTED BY POLYNOMIAL Y C TO FORM POLYNOMIAL Z. DIMENSION OF NEW POLYNOMIAL IS C (IDIMX-1)*(IDIMY-1)+1. SUBROUTINE REQUIRES TWO WORK AREAS C C .................................................................. C SUBROUTINE PVSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY,WORK1,WORK2) DIMENSION Z(1),X(1),Y(1),WORK1(1),WORK2(1) C C TEST OF DIMENSIONS C IF (IDIMX-1) 1,3,3 1 IDIMZ=0 2 RETURN C 3 IDIMZ=1 Z(1)=X(1) IF (IDIMY*IDIMX-IDIMY) 2,2,4 4 IW1=1 WORK1(1)=1. C DO 5 I=2,IDIMX CALL PMPY(WORK2,IW2,Y,IDIMY,WORK1,IW1) CALL PCLA(WORK1,IW1,WORK2,IW2) FACT=X(I) CALL PADDM(Z,IDIMR,Z,IDIMZ,FACT,WORK1,IW1) IDIMZ=IDIMR 5 CONTINUE GO TO 2 END C C .................................................................. C C SUBROUTINE QA10 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA10 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 10-POINT GENERALIZED GAUSS- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 19. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA10(FCT,Y) C C X=29.02495 Y=.4458787E-12*FCT(X) X=21.19389 Y=Y+.8798682E-9*FCT(X) X=15.56116 Y=Y+.2172139E-6*FCT(X) X=11.20813 Y=Y+.1560511E-4*FCT(X) X=7.777439 Y=Y+.0004566773*FCT(X) X=5.084908 Y=Y+.006487547*FCT(X) X=3.022513 Y=Y+.04962104*FCT(X) X=1.522944 Y=Y+.2180344*FCT(X) X=.5438675 Y=Y+.5733510*FCT(X) X=.06019206 Y=Y+.9244873*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA2 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA2 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 2-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 3. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA2(FCT,Y) C C X=2.724745 Y=.1626257*FCT(X) X=.2752551 Y=Y+1.609828*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA3 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA3 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 3-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 5. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA3(FCT,Y) C C X=5.525344 Y=.009060020*FCT(X) X=1.784493 Y=Y+.3141346*FCT(X) X=.1901635 Y=Y+1.449259*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA4 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA4 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 7. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA4(FCT,Y) C C X=8.588636 Y=.0003992081*FCT(X) X=3.926964 Y=Y+.03415597*FCT(X) X=1.339097 Y=Y+.4156047*FCT(X) X=.1453035 Y=Y+1.322294*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA5 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA5 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 5-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 9. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA5(FCT,Y) C C X=11.80719 Y=.1528087E-4*FCT(X) X=6.414730 Y=Y+.002687291*FCT(X) X=3.085937 Y=Y+.06774879*FCT(X) X=1.074562 Y=Y+.4802772*FCT(X) X=.1175813 Y=Y+1.221725*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA6 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA6 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 6-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 11. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA6(FCT,Y) C C X=15.12996 Y=.5317103E-6*FCT(X) X=9.124248 Y=Y+.0001714737*FCT(X) X=5.196153 Y=Y+.007810781*FCT(X) X=2.552590 Y=Y+.1032160*FCT(X) X=.8983028 Y=Y+.5209846*FCT(X) X=.09874701 Y=Y+1.140270*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA7 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA7 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 7-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 13. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA7(FCT,Y) C C X=18.52828 Y=.1725718E-7*FCT(X) X=11.98999 Y=Y+.9432969E-5*FCT(X) X=7.554091 Y=Y+.0007101852*FCT(X) X=4.389793 Y=Y+.01570011*FCT(X) X=2.180592 Y=Y+.1370111*FCT(X) X=.7721379 Y=Y+.5462112*FCT(X) X=.08511544 Y=Y+1.072812*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA8 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA8 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 15. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA8(FCT,Y) C C X=21.98427 Y=.5309615E-9*FCT(X) X=14.97262 Y=Y+.4641962E-6*FCT(X) X=10.09332 Y=Y+.5423720E-4*FCT(X) X=6.483145 Y=Y+.001864568*FCT(X) X=3.809476 Y=Y+.02576062*FCT(X) X=1.905114 Y=Y+.1676201*FCT(X) X=.6772491 Y=Y+.5612949*FCT(X) X=.07479188 Y=Y+1.015859*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QA9 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X)/SQRT(X), SUMMED OVER X C FROM 0 TO INFINITY). C C USAGE C CALL QA9 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 9-POINT GENERALIZED GAUSSIAN- C LAGUERRE QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY, C WHENEVER FCT(X) IS A POLYNOMIAL UP TO DEGREE 17. C FOR REFERENCE, SEE C CONCUS/CASSATT/JAEHNIG/MELBY, TABLES FOR THE EVALUATION OF C INTEGRAL(X**BETA*EXP(-X)*F(X), SUMMED OVER X FROM 0 TO C INFINITY) BY GAUSS-LAGUERRE QUADRATURE, MTAC, VOL.17, C ISS.83 (1963), PP.245-256. C C .................................................................. C SUBROUTINE QA9(FCT,Y) C C X=25.48598 Y=.1565640E-10*FCT(X) X=18.04651 Y=Y+.2093441E-7*FCT(X) X=12.77183 Y=Y+.3621309E-5*FCT(X) X=8.769757 Y=Y+.0001836225*FCT(X) X=5.694423 Y=Y+.003777045*FCT(X) X=3.369176 Y=Y+.03728008*FCT(X) X=1.692395 Y=Y+.1946035*FCT(X) X=.6032364 Y=Y+.5696146*FCT(X) X=.06670223 Y=Y+.9669914*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QATR C C PURPOSE C TO COMPUTE AN APPROXIMATION FOR INTEGRAL(FCT(X), SUMMED C OVER X FROM XL TO XU). C C USAGE C CALL QATR (XL,XU,EPS,NDIM,FCT,Y,IER,AUX) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C EPS - THE UPPER BOUND OF THE ABSOLUTE ERROR. C NDIM - THE DIMENSION OF THE AUXILIARY STORAGE ARRAY AUX. C NDIM-1 IS THE MAXIMAL NUMBER OF BISECTIONS OF C THE INTERVAL (XL,XU). C FCT - THE NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING APPROXIMATION FOR THE INTEGRAL VALUE. C IER - A RESULTING ERROR PARAMETER. C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION NDIM. C C REMARKS C ERROR PARAMETER IER IS CODED IN THE FOLLOWING FORM C IER=0 - IT WAS POSSIBLE TO REACH THE REQUIRED ACCURACY. C NO ERROR. C IER=1 - IT IS IMPOSSIBLE TO REACH THE REQUIRED ACCURACY C BECAUSE OF ROUNDING ERRORS. C IER=2 - IT WAS IMPOSSIBLE TO CHECK ACCURACY BECAUSE NDIM C IS LESS THAN 5, OR THE REQUIRED ACCURACY COULD NOT C BE REACHED WITHIN NDIM-1 STEPS. NDIM SHOULD BE C INCREASED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE CODED BY C THE USER. ITS ARGUMENT X SHOULD NOT BE DESTROYED. C C METHOD C EVALUATION OF Y IS DONE BY MEANS OF TRAPEZOIDAL RULE IN C CONNECTION WITH ROMBERGS PRINCIPLE. ON RETURN Y CONTAINS C THE BEST POSSIBLE APPROXIMATION OF THE INTEGRAL VALUE AND C VECTOR AUX THE UPWARD DIAGONAL OF ROMBERG SCHEME. C COMPONENTS AUX(I) (I=1,2,...,IEND, WITH IEND LESS THAN OR C EQUAL TO NDIM) BECOME APPROXIMATIONS TO INTEGRAL VALUE WITH C DECREASING ACCURACY BY MULTIPLICATION WITH (XU-XL). C FOR REFERENCE, SEE C (1) FILIPPI, DAS VERFAHREN VON ROMBERG-STIEFEL-BAUER ALS C SPEZIALFALL DES ALLGEMEINEN PRINZIPS VON RICHARDSON, C MATHEMATIK-TECHNIK-WIRTSCHAFT, VOL.11, ISS.2 (1964), C PP.49-54. C (2) BAUER, ALGORITHM 60, CACM, VOL.4, ISS.6 (1961), PP.255. C C .................................................................. C SUBROUTINE QATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX) C C DIMENSION AUX(1) C C PREPARATIONS OF ROMBERG-LOOP AUX(1)=.5*(FCT(XL)+FCT(XU)) H=XU-XL IF(NDIM-1)8,8,1 1 IF(H)2,10,2 C C NDIM IS GREATER THAN 1 AND H IS NOT EQUAL TO 0. 2 HH=H E=EPS/ABS(H) DELT2=0. P=1. JJ=1 DO 7 I=2,NDIM Y=AUX(1) DELT1=DELT2 HD=HH HH=.5*HH P=.5*P X=XL+HH SM=0. DO 3 J=1,JJ SM=SM+FCT(X) 3 X=X+HD AUX(I)=.5*AUX(I-1)+P*SM C A NEW APPROXIMATION OF INTEGRAL VALUE IS COMPUTED BY MEANS OF C TRAPEZOIDAL RULE. C C START OF ROMBERGS EXTRAPOLATION METHOD. Q=1. JI=I-1 DO 4 J=1,JI II=I-J Q=Q+Q Q=Q+Q 4 AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.) C END OF ROMBERG-STEP C DELT2=ABS(Y-AUX(1)) IF(I-5)7,5,5 5 IF(DELT2-E)10,10,6 6 IF(DELT2-DELT1)7,11,11 7 JJ=JJ+JJ 8 IER=2 9 Y=H*AUX(1) RETURN 10 IER=0 GO TO 9 11 IER=1 Y=H*Y RETURN END C C .................................................................. C C SAMPLE PROGRAM FOR INTEGRATION OF A TABULATED FUNCTION BY C NUMERICAL QUADRATURE - QDINT C C PURPOSE C INTEGRATES A SET OF TABULATED VALUES FOR F(X) GIVEN THE C NUMBER OF VALUES AND THEIR SPACING C C REMARKS C THE NUMBER OF VALUES MUST BE MORE THAN TWO AND THE SPACING C GREATER THAN ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C QSF C C METHOD C READS CONTROL CARD CONTAINING THE CODE NUMBER, NUMBER OF C VALUES, AND THE SPACING OF THE FUNCTION VALUES CONTAINED C ON THE FOLLOWING DATA CARDS. DATA CARDS ARE THEN READ AND C INTEGRATION IS PERFORMED. MORE THAN ONE CONTROL CARD AND C CORRESPONDING DATA CAN BE INTEGRATED IN ONE RUN. EXECUTION C IS TERMINATED BY A BLANK CONTROL CARD. C C .................................................................. C C THE FOLLOWING DIMENSION MUST BE AS LARGE AS THE MAXIMUM NUMBER C OF TABULATED VALUES TO BE INTEGRATED C DIMENSION Z(500) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION Z,SPACE C C ............................................................... C 10 FORMAT (2I5,F10.0) 20 FORMAT(1H1,62HINTEGRATION OF TABULATED VALUES FOR DY/DX USING SUBR 1OUTINE QSF//1H ,10HFUNCTION ,I5,3X,I5,17H TABULATED VALUES, 25X,10HINTERVAL =,E15.8//) 22 FORMAT(1H ,17HILLEGAL CONDITION/) 23 FORMAT(1H ,45HNUMBER OF TABULATED VALUES IS LESS THAN THREE) 30 FORMAT(1H ,7X,'RESULTANT VALUE OF INTEGRAL AT EACH STEP IS ',/ 1(1H ,6E15.8)) 32 FORMAT(7F10.0) C OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') C OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') C 35 READ(5,10)ICOD,NUMBR,SPACE IF(ICOD+NUMBR)70,70,38 38 WRITE(6,20)ICOD,NUMBR,SPACE 50 READ(5,32)(Z(I),I=1,NUMBR) IF(NUMBR-3)100,55,55 55 CALL QSF(SPACE,Z,Z,NUMBR) 60 WRITE(6,30)(Z(I),I=1,NUMBR) GO TO 35 70 STOP 100 WRITE(6,22) WRITE (6,23) GO TO 35 200 WRITE(6,22) GO TO 35 END C C .................................................................. C C SUBROUTINE QG10 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG10(XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 10-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 19 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG10(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4869533*B Y=.03333567*(FCT(A+C)+FCT(A-C)) C=.4325317*B Y=Y+.07472567*(FCT(A+C)+FCT(A-C)) C=.3397048*B Y=Y+.1095432*(FCT(A+C)+FCT(A-C)) C=.2166977*B Y=Y+.1346334*(FCT(A+C)+FCT(A-C)) C=.07443717*B Y=B*(Y+.1477621*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE QG2 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG2 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 2-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 3 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG2(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL Y=.2886751*B Y=.5*B*(FCT(A+Y)+FCT(A-Y)) RETURN END C C .................................................................. C C SUBROUTINE QG3 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG3 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 3-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 5 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG3(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL Y=.3872983*B Y=.2777778*(FCT(A+Y)+FCT(A-Y)) Y=B*(Y+.4444444*FCT(A)) RETURN END C C .................................................................. C C SUBROUTINE QG4 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG4 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 7 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG4(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4305682*B Y=.1739274*(FCT(A+C)+FCT(A-C)) C=.1699905*B Y=B*(Y+.3260726*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE QG5 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG5 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 5-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 9 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG5(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4530899*B Y=.1184634*(FCT(A+C)+FCT(A-C)) C=.2692347*B Y=Y+.2393143*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.2844444*FCT(A)) RETURN END C C .................................................................. C C SUBROUTINE QG6 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG6 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 6-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 11 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG6(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4662348*B Y=.08566225*(FCT(A+C)+FCT(A-C)) C=.3306047*B Y=Y+.1803808*(FCT(A+C)+FCT(A-C)) C=.1193096*B Y=B*(Y+.2339570*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE QG7 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG7 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 7-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 13 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG7(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4745540*B Y=.06474248*(FCT(A+C)+FCT(A-C)) C=.3707656*B Y=Y+.1398527*(FCT(A+C)+FCT(A-C)) C=.2029226*B Y=Y+.1909150*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.2089796*FCT(A)) RETURN END C C .................................................................. C C SUBROUTINE QG8 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG8 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 15 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG8(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4801449*B Y=.05061427*(FCT(A+C)+FCT(A-C)) C=.3983332*B Y=Y+.1111905*(FCT(A+C)+FCT(A-C)) C=.2627662*B Y=Y+.1568533*(FCT(A+C)+FCT(A-C)) C=.09171732*B Y=B*(Y+.1813419*(FCT(A+C)+FCT(A-C))) RETURN END C C .................................................................. C C SUBROUTINE QG9 C C PURPOSE C TO COMPUTE INTEGRAL(FCT(X), SUMMED OVER X FROM XL TO XU) C C USAGE C CALL QG9 (XL,XU,FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C XL - THE LOWER BOUND OF THE INTERVAL. C XU - THE UPPER BOUND OF THE INTERVAL. C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 9-POINT GAUSS QUADRATURE C FORMULA, WHICH INTEGRATES POLYNOMIALS UP TO DEGREE 17 C EXACTLY. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.100-111 AND 337-338. C C .................................................................. C SUBROUTINE QG9(XL,XU,FCT,Y) C C A=.5*(XU+XL) B=XU-XL C=.4840801*B Y=.04063719*(FCT(A+C)+FCT(A-C)) C=.4180156*B Y=Y+.09032408*(FCT(A+C)+FCT(A-C)) C=.3066857*B Y=Y+.1303053*(FCT(A+C)+FCT(A-C)) C=.1621267*B Y=Y+.1561735*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.1651197*FCT(A)) RETURN END C C .................................................................. C C SUBROUTINE QH10 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH10(FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 10-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 19. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH10(FCT,Y) C C X=3.436159 Z=-X Y=.7640433E-5*(FCT(X)+FCT(Z)) X=2.532732 Z=-X Y=Y+.001343646*(FCT(X)+FCT(Z)) X=1.756684 Z=-X Y=Y+.03387439*(FCT(X)+FCT(Z)) X=1.036611 Z=-X Y=Y+.2401386*(FCT(X)+FCT(Z)) X=.3429013 Z=-X Y=Y+.6108626*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE QH2 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH2 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 2-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 3. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH2(FCT,Y) C C X=.7071068 Z=-X Y=.8862269*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE QH3 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH3 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 3-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 5. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH3(FCT,Y) C C X=1.224745 Z=-X Y=.2954090*(FCT(X)+FCT(Z)) X=0. Y=Y+1.181636*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QH4 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH4 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 7. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH4(FCT,Y) C C X=1.650680 Z=-X Y=.08131284*(FCT(X)+FCT(Z)) X=.5246476 Z=-X Y=Y+.8049141*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE QH5 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH5 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 5-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 9. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH5(FCT,Y) C C X=2.020183 Z=-X Y=.01995324*(FCT(X)+FCT(Z)) X=.9585725 Z=-X Y=Y+.3936193*(FCT(X)+FCT(Z)) X=0. Y=Y+.9453087*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QH6 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH6 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 6-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 11. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH6(FCT,Y) C C X=2.350605 Z=-X Y=.004530010*(FCT(X)+FCT(Z)) X=1.335849 Z=-X Y=Y+.1570673*(FCT(X)+FCT(Z)) X=.4360774 Z=-X Y=Y+.7246296*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE QH7 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH7 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 7-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 13. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH7(FCT,Y) C C X=2.651961 Z=-X Y=.0009717812*(FCT(X)+FCT(Z)) X=1.673552 Z=-X Y=Y+.05451558*(FCT(X)+FCT(Z)) X=.8162879 Z=-X Y=Y+.4256073*(FCT(X)+FCT(Z)) X=0. Y=Y+.8102646*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QH8 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH8 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 8-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 15. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH8(FCT,Y) C C X=2.930637 Z=-X Y=.0001996041*(FCT(X)+FCT(Z)) X=1.981657 Z=-X Y=Y+.01707798*(FCT(X)+FCT(Z)) X=1.157194 Z=-X Y=Y+.2078023*(FCT(X)+FCT(Z)) X=.3811870 Z=-X Y=Y+.6611470*(FCT(X)+FCT(Z)) RETURN END C C .................................................................. C C SUBROUTINE QH9 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X*X)*FCT(X), SUMMED OVER X FROM C -INFINITY TO +INFINITY). C C USAGE C CALL QH9 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 9-POINT GAUSSIAN-HERMITE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 17. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.129-130 AND 343-346. C C .................................................................. C SUBROUTINE QH9(FCT,Y) C C X=3.190993 Z=-X Y=.3960698E-4*(FCT(X)+FCT(Z)) X=2.266581 Z=-X Y=Y+.004943624*(FCT(X)+FCT(Z)) X=1.468553 Z=-X Y=Y+.08847453*(FCT(X)+FCT(Z)) X=.7235510 Z=-X Y=Y+.4326516*(FCT(X)+FCT(Z)) X=0. Y=Y+.7202352*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QHFE C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION AND DERIVATIVE VALUES. C C USAGE C CALL QHFE (H,Y,DERY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - THE INCREMENT OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C DERY - THE INPUT VECTOR OF DERIVATIVE VALUES. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH Y OR DERY. C NDIM - THE DIMENSION OF VECTORS Y,DERY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE QHFE(H,Y,DERY,Z,NDIM) C C DIMENSION Y(1),DERY(1),Z(1) C SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*H HS=.1666667*H C C INTEGRATION LOOP DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE QHFG C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C GENERAL TABLE OF ARGUMENT, FUNCTION, AND DERIVATIVE VALUES. C C USAGE C CALL QHFG (X,Y,DERY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C X - THE INPUT VECTOR OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C DERY - THE INPUT VECTOR OF DERIVATIVE VALUES. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH X,Y OR DERY. C NDIM - THE DIMENSION OF VECTORS X,Y,DERY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN FOURTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.314-319. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE QHFG(X,Y,DERY,Z,NDIM) C C DIMENSION X(1),Y(1),DERY(1),Z(1) C SUM2=0. IF(NDIM-1)4,3,1 C C INTEGRATION LOOP 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.3333333*SUM2*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE QHSE C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION, FIRST DERIVATIVE, C AND SECOND DERIVATIVE VALUES. C C USAGE C CALL QHSE (H,Y,FDY,SDY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - THE INCREMENT OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C FDY - THE INPUT VECTOR OF FIRST DERIVATIVE. C SDY - THE INPUT VECTOR OF SECOND DERIVATIVE. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH Y,FDY OR SDY. C NDIM - THE DIMENSION OF VECTORS Y,FDY,SDY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE QHSE(H,Y,FDY,SDY,Z,NDIM) C C DIMENSION Y(1),FDY(1),SDY(1),Z(1) C SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*H HF=.2*H HT=.08333333*H C C INTEGRATION LOOP DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+ 1 HT*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE QHSG C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C GENERAL TABLE OF ARGUMENT, FUNCTION, FIRST DERIVATIVE, C AND SECOND DERIVATIVE VALUES. C C USAGE C CALL QHSG (X,Y,FDY,SDY,Z,NDIM) C C DESCRIPTION OF PARAMETERS C X - THE INPUT VECTOR OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C FDY - THE INPUT VECTOR OF FIRST DERIVATIVE. C SDY - THE INPUT VECTOR OF SECOND DERIVATIVE. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH X,Y,FDY OR SDY. C NDIM - THE DIMENSION OF VECTORS X,Y,FDY,SDY,Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF HERMITEAN SIXTH ORDER INTEGRATION FORMULA. C FOR REFERENCE, SEE C R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.227-230. C C .................................................................. C SUBROUTINE QHSG(X,Y,FDY,SDY,Z,NDIM) C C DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1) C SUM2=0. IF(NDIM-1)4,3,1 C C INTEGRATION LOOP 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4*SUM2*((FDY(I-1)-FDY(I))+ 1 .1666667*SUM2*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C C .................................................................. C C SUBROUTINE QL10 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0 C TO INFINITY). C C USAGE C CALL QL10(FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 10-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 19. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352. C C .................................................................. C SUBROUTINE QL10(FCT,Y) C C X=29.92070 Y=.9911827E-12*FCT(X) X=21.99659 Y=Y+.1839565E-8*FCT(X) X=16.27926 Y=Y+.4249314E-6*FCT(X) X=11.84379 Y=Y+.2825923E-4*FCT(X) X=8.330153 Y=Y+.7530084E-3*FCT(X) X=5.552496 Y=Y+.009501517*FCT(X) X=3.401434 Y=Y+.06208746*FCT(X) X=1.808343 Y=Y+.2180683*FCT(X) X=.7294545 Y=Y+.4011199*FCT(X) X=.1377935 Y=Y+.3084411*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QL2 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0 C TO INFINITY). C C USAGE C CALL QL2 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 2-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 3. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352. C C .................................................................. C SUBROUTINE QL2(FCT,Y) C C X=3.414214 Y=.1464466*FCT(X) X=.5857864 Y=Y+.8535534*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QL3 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0 C TO INFINITY). C C USAGE C CALL QL3 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 3-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 5. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352. C C .................................................................. C SUBROUTINE QL3(FCT,Y) C C X=6.289945 Y=.01038926*FCT(X) X=2.294280 Y=Y+.2785177*FCT(X) X=.4157746 Y=Y+.7110930*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QL4 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0 C TO INFINITY). C C USAGE C CALL QL4 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 4-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 7. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352. C C .................................................................. C SUBROUTINE QL4(FCT,Y) C C X=9.395071 Y=.5392947E-3*FCT(X) X=4.536620 Y=Y+.03888791*FCT(X) X=1.745761 Y=Y+.3574187*FCT(X) X=.3225477 Y=Y+.6031541*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QL5 C C PURPOSE C TO COMPUTE INTEGRAL(EXP(-X)*FCT(X), SUMMED OVER X FROM 0 C TO INFINITY). C C USAGE C CALL QL5 (FCT,Y) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT C C DESCRIPTION OF PARAMETERS C FCT - THE NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C Y - THE RESULTING INTEGRAL VALUE. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF 5-POINT GAUSSIAN-LAGUERRE C QUADRATURE FORMULA, WHICH INTEGRATES EXACTLY WHENEVER C FCT(X) IS A POLYNOMIAL UP TO DEGREE 9. C FOR REFERENCE, SEE C V.I.KRYLOV, APPROXIMATE CALCULATION OF INTEGRALS, C MACMILLAN, NEW YORK/LONDON, 1962, PP.130-132 AND 347-352. C C .................................................................. C SUBROUTINE QL5(FCT,Y) C C X=12.64080 Y=.2336997E-4*FCT(X) X=7.085810 Y=Y+.3611759E-2*FCT(X) X=3.596426 Y=Y+.07594245*FCT(X) X=1.413403 Y=Y+.3986668*FCT(X) X=.2635603 Y=Y+.5217556*FCT(X) RETURN END C C .................................................................. C C SUBROUTINE QSF C C PURPOSE C TO COMPUTE THE VECTOR OF INTEGRAL VALUES FOR A GIVEN C EQUIDISTANT TABLE OF FUNCTION VALUES. C C USAGE C CALL QSF (H,Y,Z,NDIM) C C DESCRIPTION OF PARAMETERS C H - THE INCREMENT OF ARGUMENT VALUES. C Y - THE INPUT VECTOR OF FUNCTION VALUES. C Z - THE RESULTING VECTOR OF INTEGRAL VALUES. Z MAY BE C IDENTICAL WITH Y. C NDIM - THE DIMENSION OF VECTORS Y AND Z. C C REMARKS C NO ACTION IN CASE NDIM LESS THAN 3. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C BEGINNING WITH Z(1)=0, EVALUATION OF VECTOR Z IS DONE BY C MEANS OF SIMPSONS RULE TOGETHER WITH NEWTONS 3/8 RULE OR A C COMBINATION OF THESE TWO RULES. TRUNCATION ERROR IS OF C ORDER H**5 (I.E. FOURTH ORDER METHOD). ONLY IN CASE NDIM=3 C TRUNCATION ERROR OF Z(2) IS OF ORDER H**4. C FOR REFERENCE, SEE C (1) F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP.71-76. C (2) R.ZURMUEHL, PRAKTISCHE MATHEMATIK FUER INGENIEURE UND C PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/HEIDELBERG, 1963, C PP.214-221. C C .................................................................. C SUBROUTINE QSF(H,Y,Z,NDIM) C C DIMENSION Y(1),Z(1) C HT=.3333333*H IF(NDIM-5)7,8,1 C C NDIM IS GREATER THAN 5. PREPARATIONS OF INTEGRATION LOOP 1 SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(3)+AUX1+Y(5)) AUX2=HT*(Y(1)+3.875*(Y(2)+Y(5))+2.625*(Y(3)+Y(4))+Y(6)) SUM2=Y(5)+Y(5) SUM2=SUM2+SUM2 SUM2=AUX2-HT*(Y(4)+SUM2+Y(6)) Z(1)=0. AUX=Y(3)+Y(3) AUX=AUX+AUX Z(2)=SUM2-HT*(Y(2)+AUX+Y(4)) Z(3)=SUM1 Z(4)=SUM2 IF(NDIM-6)5,5,2 C C INTEGRATION LOOP 2 DO 4 I=7,NDIM,2 SUM1=AUX1 SUM2=AUX2 AUX1=Y(I-1)+Y(I-1) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I)) Z(I-2)=SUM1 IF(I-NDIM)3,6,6 3 AUX2=Y(I)+Y(I) AUX2=AUX2+AUX2 AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1)) 4 Z(I-1)=SUM2 5 Z(NDIM-1)=AUX1 Z(NDIM)=AUX2 RETURN 6 Z(NDIM-1)=SUM2 Z(NDIM)=AUX1 RETURN C END OF INTEGRATION LOOP C 7 IF(NDIM-3)12,11,8 C C NDIM IS EQUAL TO 4 OR 5 8 SUM2=1.125*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4)) SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) Z(1)=0. AUX1=Y(3)+Y(3) AUX1=AUX1+AUX1 Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4)) IF(NDIM-5)10,9,9 9 AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5)) 10 Z(3)=SUM1 Z(4)=SUM2 RETURN C C NDIM IS EQUAL TO 3 11 SUM1=HT*(1.25*Y(1)+Y(2)+Y(2)-.25*Y(3)) SUM2=Y(2)+Y(2) SUM2=SUM2+SUM2 Z(3)=HT*(Y(1)+SUM2+Y(3)) Z(1)=0. Z(2)=SUM1 12 RETURN END C C .................................................................. C C SUBROUTINE RADD C C PURPOSE C ADD ROW OF ONE MATRIX TO ROW OF ANOTHER MATRIX C C USAGE C CALL RADD(A,IRA,R,IRR,N,M,MS,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C IRA - ROW IN MATRIX A TO BE ADDED TO ROW IRR OF MATRIX R C R - NAME OF OUTPUT MATRIX C IRR - ROW IN MATRIX R WHERE SUMMATION IS DEVELOPED C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C L - NUMBER OF ROWS IN R C C REMARKS C MATRIX R MUST BE A GENERAL MATRIX C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A UNLESS C A IS GENERAL C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT OF ROW IRA OF MATRIX A IS ADDED TO C CORRESPONDING ELEMENT OF ROW IRR OF MATRIX R C C .................................................................. C SUBROUTINE RADD(A,IRA,R,IRR,N,M,MS,L) DIMENSION A(1),R(1) C IR=IRR-L DO 2 J=1,M IR=IR+L C C LOCATE INPUT ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(IRA,J,IA,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IA) 1,2,1 C C ADD ELEMENTS C 1 R(IR)=R(IR)+A(IA) 2 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RANK C C PURPOSE C RANK A VECTOR OF VALUES C C USAGE C CALL RANK(A,R,N) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF N VALUES C R - OUTPUT VECTOR OF LENGTH N. SMALLEST VALUE IS RANKED 1, C LARGEST IS RANKED N. TIES ARE ASSIGNED AVERAGE OF TIED C RANKS C N - NUMBER OF VALUES C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C VECTOR IS SEARCHED FOR SUCCESSIVELY LARGER ELEMENTS. IF TIES C OCCUR, THEY ARE LOCATED AND THEIR RANK VALUE COMPUTED. C FOR EXAMPLE, IF 2 VALUES ARE TIED FOR SIXTH RANK, THEY ARE C ASSIGNED A RANK OF 6.5 (=(6+7)/2) C C .................................................................. C SUBROUTINE RANK(A,R,N) DIMENSION A(1),R(1) C C INITIALIZATION C DO 10 I=1,N 10 R(I)=0.0 C C FIND RANK OF DATA C DO 100 I=1,N C C TEST WHETHER DATA POINT IS ALREADY RANKED C IF(R(I)) 20, 20, 100 C C DATA POINT TO BE RANKED C 20 SMALL=0.0 EQUAL=0.0 X=A(I) DO 50 J=1,N IF(A(J)-X) 30, 40, 50 C COUNT NUMBER OF DATA POINTS WHICH ARE SMALLER C C 30 SMALL=SMALL+1.0 GO TO 50 C C COUNT NUMBER OF DATA POINTS WHICH ARE EQUAL C 40 EQUAL=EQUAL+1.0 R(J)=-1.0 50 CONTINUE C C TEST FOR TIE C IF(EQUAL-1.0) 60, 60, 70 C C STORE RANK OF DATA POINT WHERE NO TIE C 60 R(I)=SMALL+1.0 GO TO 100 C C CALCULATE RANK OF TIED DATA POINTS C 70 P=SMALL + (EQUAL + 1.0)*0.5 DO 90 J=I,N IF(R(J)+1.0) 90, 80, 90 80 R(J)=P 90 CONTINUE 100 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RCPY C C PURPOSE C COPY SPECIFIED ROW OF A MATRIX INTO A VECTOR C C USAGE C CALL RCPY (A,L,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C L - ROW OF A TO BE MOVED TO R C R - NAME OF OUTPUT VECTOR OF LENGTH M C N - NUMBER OR ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS OF ROW L ARE MOVED TO CORRESPONDING POSITIONS C OF VECTOR R C C .................................................................. C SUBROUTINE RCPY(A,L,R,N,M,MS) DIMENSION A(1),R(1) C DO 3 J=1,M C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(L,J,LJ,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(LJ) 1,2,1 C C MOVE ELEMENT TO R C 1 R(J)=A(LJ) GO TO 3 2 R(J)=0.0 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RCUT C C PURPOSE C PARTITION A MATRIX BETWEEN SPECIFIED ROWS TO FORM TWO C RESULTANT MATRICES C C USAGE C CALL RCUT (A,L,R,S,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C L - ROW OF A ABOVE WHICH PARTITIONING TAKES PLACE C R - NAME OF MATRIX TO BE FORMED FROM UPPER PORTION OF A C S - NAME OF MATRIX TO BE FORMED FROM LOWER PORTION OF A C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX A C MATRIX S CANNOT BE IN SAME LOCATION AS MATRIX A C MATRIX R CANNOT BE IN SAME LOCATION AS MATRIX S C MATRIX R AND MATRIX S ARE ALWAYS GENERAL MATRICES C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS OF MATRIX A ABOVE ROW L ARE MOVED TO FORM MATRIX R C OF L-1 ROWS AND M COLUMNS. ELEMENTS OF MATRIX A IN ROW L C AND BELOW ARE MOVED TO FORM MATRIX S OF N-L+1 ROWS AND M C COLUMNS C C .................................................................. C SUBROUTINE RCUT(A,L,R,S,N,M,MS) DIMENSION A(1),R(1),S(1) C IR=0 IS=0 DO 70 J=1,M DO 70 I=1,N C C FIND LOCATION IN OUTPUT MATRIX AND SET TO ZERO C IF(I-L) 20,10,10 10 IS=IS+1 S(IS)=0.0 GO TO 30 20 IR=IR+1 R(IR)=0.0 C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C 30 CALL LOC(I,J,IJ,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 40,70,40 C C DETERMINE WHETHER ABOVE OR BELOW L C 40 IF(I-L) 60,50,50 50 S(IS)=A(IJ) GO TO 70 60 R(IR)=A(IJ) 70 CONTINUE RETURN END C C .................................................................. C C FUNCTION RECP C C PURPOSE C CALCULATE RECIPROCAL OF AN ELEMENT. THIS IS A FORTRAN C FUNCTION SUBPROGRAM WHICH MAY BE USED AS AN ARGUMENT BY C SUBROUTINE MFUN. C C USAGE C RECP(E) C C DESCRIPTION OF PARAMETERS C E - MATRIX ELEMENT C C REMARKS C RECIPROCAL OF ZERO IS TAKEN TO BE 1.0E75 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C RECIPROCAL OF ELEMENT E IS PLACED IN RECP C C .................................................................. C FUNCTION RECP(E) C BIG=1.0E37 C C TEST ELEMENT FOR ZERO C IF(E) 1,2,1 C C IF NON-ZERO, CALCULATE RECIPROCAL C 1 RECP=1.0/E RETURN C C IF ZERO, SET EQUAL TO INFINITY C 2 RECP=SIGN(BIG,E) RETURN END C C .................................................................. C C SUBROUTINE RINT C C PURPOSE C INTERCHANGE TWO ROWS OF A MATRIX C C USAGE C CALL RINT(A,N,M,LA,LB) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C LA - ROW TO BE INTERCHANGED WITH ROW LB C LB - ROW TO BE INTERCHANGED WITH ROW LA C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH ELEMENT OF ROW LA IS INTERCHANGED WITH CORRESPONDING C ELEMENT OF ROW LB C C .................................................................. C SUBROUTINE RINT(A,N,M,LA,LB) DIMENSION A(1) C LAJ=LA-N LBJ=LB-N DO 3 J=1,M C C LOCATE ELEMENTS IN BOTH ROWS C LAJ=LAJ+N LBJ=LBJ+N C C INTERCHANGE ELEMENTS C SAVE=A(LAJ) A(LAJ)=A(LBJ) 3 A(LBJ)=SAVE RETURN END C C .................................................................. C C SUBROUTINE RK1 C C PURPOSE C INTEGRATES A FIRST ORDER DIFFERENTIAL EQUATION C DY/DX=FUN(X,Y) UP TO A SPECIFIED FINAL VALUE C C USAGE C CALL RK1(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER) C C DESCRIPTION OF PARAMETERS C FUN -USER-SUPPLIED FUNCTION SUBPROGRAM WITH ARGUMENTS X,Y C WHICH GIVES DY/DX C HI -THE STEP SIZE C XI -INITIAL VALUE OF X C YI -INITIAL VALUE OF Y WHERE YI=Y(XI) C XF -FINAL VALUE OF X C YF -FINAL VALUE OF Y C ANSX-RESULTANT FINAL VALUE OF X C ANSY-RESULTANT FINAL VALUE OF Y C EITHER ANSX WILL EQUAL XF OR ANSY WILL EQUAL YF C DEPENDING ON WHICH IS REACHED FIRST C IER -ERROR CODE C IER=0 NO ERROR C IER=1 STEP SIZE IS ZERO C C REMARKS C IF XI IS GREATER THAN XF, ANSX=XI AND ANSY=YI C IF H IS ZERO, IER IS SET TO ONE, ANSX IS SET TO XI, AND C ANSY IS SET TO ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUN IS A TWO ARGUMENT FUNCTION SUBPROGRAM FURNISHED BY THE C USER. DY/DX=FUN (X,Y) C CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT C CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO C RK1 C C METHOD C USES FOURTH ORDER RUNGE-KUTTA INTEGRATION PROCESS ON A C RECURSIVE BASIS AS SHOWN IN F.B. HILDEBRAND, 'INTRODUCTION C TO NUMERICAL ANALYSIS',MCGRAW-HILL,1956. PROCESS IS C TERMINATED AND FINAL VALUE ADJUSTED WHEN EITHER XF OR YF C IS REACHED. C C .................................................................. C SUBROUTINE RK1(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION HI,XI,YI,XF,YF,ANSX,ANSY,H,XN,YN,HNEW,XN1,YN1, C 1 XX,YY,XNEW,YNEW,H2,T1,T2,T3,T4,FUN C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C USER FUNCTION SUBPROGRAM, FUN, MUST BE IN DOUBLE PRECISION. C C ............................................................... C C IF XF IS LESS THAN OR EQUAL TO XI, RETURN XI,YI AS ANSWER C IER=0 IF(XF-XI) 11,11,12 11 ANSX=XI ANSY=YI RETURN C C TEST INTERVAL VALUE C 12 H=HI IF(HI) 16,14,20 14 IER=1 ANSX=XI ANSY=0.0 RETURN 16 H=-HI C C SET XN=INITIAL X,YN=INITIAL Y C 20 XN=XI YN=YI C C INTEGRATE ONE TIME STEP C HNEW=H JUMP=1 GO TO 170 25 XN1=XX YN1=YY C C COMPARE XN1 (=X(N+1)) TO X FINAL AND BRANCH ACCORDINGLY C IF(XN1-XF)50,30,40 C C XN1=XF, RETURN (XF,YN1) AS ANSWER C 30 ANSX=XF ANSY=YN1 GO TO 160 C C XN1 GREATER THAN XF, SET NEW STEP SIZE AND INTEGRATE ONE STEP C RETURN RESULTS OF INTEGRATION AS ANSWER C 40 HNEW=XF-XN JUMP=2 GO TO 170 45 ANSX=XX ANSY=YY GO TO 160 C C XN1 LESS THAN X FINAL, CHECK IF (YN,YN1) SPAN Y FINAL C C 50 IF((YN1-YF)*(YF-YN))60,70,110 C C YN1 AND YN DO NOT SPAN YF. SET (XN,YN) AS (XN1,YN1) AND REPEAT C 60 YN=YN1 XN=XN1 GO TO 170 C C EITHER YN OR YN1 =YF. CHECK WHICH AND SET PROPER (X,Y) AS ANSWER C 70 IF(YN1-YF)80,100,80 80 ANSY=YN ANSX=XN GO TO 160 100 ANSY=YN1 ANSX=XN1 GO TO 160 C C YN AND YN1 SPAN YF. TRY TO FIND X VALUE ASSOCIATED WITH YF C 110 DO 140 I=1,10 C C INTERPOLATE TO FIND NEW TIME STEP AND INTEGRATE ONE STEP C TRY TEN INTERPOLATIONS AT MOST C HNEW=((YF-YN )/(YN1-YN))*(XN1-XN) JUMP=3 GO TO 170 115 XNEW=XX YNEW=YY C C COMPARE COMPUTED Y VALUE WITH YF AND BRANCH C IF(YNEW-YF)120,150,130 C C ADVANCE, YF IS BETWEEN YNEW AND YN1 C 120 YN=YNEW XN=XNEW GO TO 140 C C ADVANCE, YF IS BETWEEN YN AND YNEW C 130 YN1=YNEW XN1=XNEW 140 CONTINUE C C RETURN (XNEW,YF) AS ANSWER C 150 ANSX=XNEW ANSY=YF 160 RETURN C 170 H2=HNEW/2.0 T1=HNEW*FUN(XN,YN) T2=HNEW*FUN(XN+H2,YN+T1/2.0) T3=HNEW*FUN(XN+H2,YN+T2/2.0) T4=HNEW*FUN(XN+HNEW,YN+T3) YY=YN+(T1+2.0*T2+2.0*T3+T4)/6.0 XX=XN+HNEW GO TO (25,45,115), JUMP C END C C .................................................................. C C SUBROUTINE RK2 C C PURPOSE C INTEGRATES A FIRST ORDER DIFFERENTIAL EQUATION C DY/DX=FUN(X,Y) AND PRODUCES A TABLE OF INTEGRATED VALUES C C USAGE C CALL RK2(FUN,H,XI,YI,K,N,VEC) C C DESCRIPTION OF PARAMETERS C FUN-USER-SUPPLIED FUNCTION SUBPROGRAM WITH ARGUMENTS X,Y C WHICH GIVES DY/DX C H -STEP SIZE C XI -INITIAL VALUE OF X C YI -INITIAL VALUE OF Y WHERE YI=Y(XI) C K -THE INTERVAL AT WHICH COMPUTED VALUES ARE TO BE STORED C N -THE NUMBER OF VALUES TO BE STORED C VEC-THE RESULTANT VECTOR OF LENGTH N IN WHICH COMPUTED C VALUES OF Y ARE TO BE STORED C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C FUN - USER-SUPPLIED FUNCTION SUBPROGRAM FOR DY/DX C CALLING PROGRAM MUST HAVE FORTRAN EXTERNAL STATEMENT C CONTAINING NAMES OF FUNCTION SUBPROGRAMS LISTED IN CALL TO C RK2 C C METHOD C FOURTH ORDER RUNGE-KUTTA INTEGRATION ON A RECURSIVE BASIS AS C SHOWN IN F.B. HILDEBRAND, 'INTRODUCTION TO NUMERICAL C ANALYSIS', MCGRAW-HILL, NEW YORK, 1956 C C .................................................................. C SUBROUTINE RK2(FUN,H,XI,YI,K,N,VEC) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION H,XI,YI,VEC,H2,Y,X,T1,T2,T3,T4,FUN C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C USER FUNCTION SUBPROGRAM, FUN, MUST BE IN DOUBLE PRECISION. C C ............................................................... C DIMENSION VEC(1) H2=H/2. Y=YI X=XI DO 2 I=1,N DO 1 J=1,K T1=H*FUN(X,Y) T2=H*FUN(X+H2,Y+T1/2.) T3=H*FUN(X+H2,Y+T2/2.) T4=H*FUN(X+H,Y+T3) Y= Y+(T1+2.*T2+2.*T3+T4)/6. 1 X=X+H 2 VEC(I)=Y RETURN END C C .................................................................. C C SUBROUTINE RSRT C C PURPOSE C SORT ROWS OF A MATRIX C C USAGE C CALL RSRT(A,B,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX TO BE SORTED C B - NAME OF INPUT VECTOR WHICH CONTAINS SORTING KEY C R - NAME OF SORTED OUTPUT MATRIX C N - NUMBER OF ROWS IN A AND R AND LENGTH OF B C M - NUMBER OF COLUMNS IN A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R IS ALWAYS A GENERAL MATRIX C N MUST BE GREATER THAN ONE. C M ALSO MUST BE AT LEAST TWO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ROWS OF INPUT MATRIX A ARE SORTED TO FORM OUTPUT MATRIX R. C THE SORTED ROW SEQUENCE IS DETERMINED BY THE VALUES OF C ELEMENTS IN COLUMN VECTOR B. THE LOWEST VALUED ELEMENT IN C B WILL CAUSE THE CORRESPONDING ROW OF A TO BE PLACED IN THE C FIRST ROW OF R. THE HIGHEST VALUED ELEMENT OF B WILL CAUSE C THE CORRESPONDING ROW OF A TO BE PLACED IN THE LAST ROW OF C R. IF DUPLICATE VALUES EXIST IN B, THE CORRESPONDING ROWS C OF A ARE MOVED TO R IN THE SAME ORDER AS IN A. C C .................................................................. C SUBROUTINE RSRT(A,B,R,N,M,MS) DIMENSION A(1),B(1),R(1) C C MOVE SORTING KEY VECTOR TO FIRST COLUMN OF OUTPUT MATRIX C AND BUILD ORIGINAL SEQUENCE LIST IN SECOND COLUMN C DO 10 I=1,N R(I)=B(I) I2=I+N 10 R(I2)=I C C SORT ELEMENTS IN SORTING KEY VECTOR (ORIGINAL SEQUENCE LIST C IS RESEQUENCED ACCORDINGLY) C L=N+1 20 ISORT=0 L=L-1 DO 40 I=2,L IF(R(I)-R(I-1)) 30,40,40 30 ISORT=1 RSAVE=R(I) R(I)=R(I-1) R(I-1)=RSAVE I2=I+N SAVER=R(I2) R(I2)=R(I2-1) R(I2-1)=SAVER 40 CONTINUE IF(ISORT) 20,50,20 C C MOVE ROWS FROM MATRIX A TO MATRIX R (NUMBER IN SECOND COLUMN C OF R REPRESENTS ROW NUMBER OF MATRIX A TO BE MOVED) C 50 DO 80 I=1,N C C GET ROW NUMBER IN MATRIX A C I2=I+N IN=R(I2) C IR=I-N DO 80 J=1,M C C LOCATE ELEMENT IN OUTPUT MATRIX C IR=IR+N C C LOCATE ELEMENT IN INPUT MATRIX C CALL LOC(IN,J,IA,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IA) 60,70,60 C C MOVE ELEMENT TO OUTPUT MATRIX C 60 R(IR)=A(IA) GO TO 80 70 R(IR)=0 80 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RSUM C C PURPOSE C SUM ELEMENTS OF EACH ROW TO FORM COLUMN VECTOR C C USAGE C CALL RSUM (A,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF VECTOR OF LENGTH N C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C VECTOR R CANNOT BE IN THE SAME LOCATION AS MATRIX A C UNLESS A IS GENERAL C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C ELEMENTS ARE SUMMED ACROSS EACH ROW INTO A CORRESPONDING C ELEMENT OF OUTPUT COLUMN VECTOR R C C .................................................................. C SUBROUTINE RSUM(A,R,N,M,MS) DIMENSION A(1),R(1) C DO 3 I=1,N C C CLEAR OUTPUT LOCATION C R(I)=0.0 C DO 3 J=1,M C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,J,IJ,N,M,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 2,3,2 C C ACCUMULATE IN OUTPUT VECTOR C 2 R(I)=R(I)+A(IJ) 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RTAB C C PURPOSE C TABULATE ROWS OF A MATRIX TO FORM A SUMMARY MATRIX C C USAGE C CALL RTAB(A,B,R,S,N,M,MS,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C B - NAME OF INPUT VECTOR OF LENGTH N CONTAINING KEY C R - NAME OF OUTPUT MATRIX CONTAINING SUMMARY OF ROW DATA. C IT IS INITIALLY SET TO ZERO BY THIS SUBROUTINE. C S - NAME OF OUTPUT VECTOR OF LENGTH L+1 CONTAINING COUNTS C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A AND R C L - NUMBER OF ROWS IN R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R IS ALWAYS A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C RADD C C METHOD C ROWS OF DATA IN MATRIX A ARE TABULATED BASED ON THE KEY C CONTAINED IN VECTOR B. THE FLOATING POINT NUMBER IN B(I) IS C TRUNCATED TO FORM J. THE ITH ROW OF A IS ADDED TO THE JTH C ROW OF R ELEMENT BY ELEMENT AND ONE IS ADDED TO S(J). IF J C IS NOT BETWEEN ONE AND L, ONE IS ADDED TO S(L+1). THIS C PROCEDURE IS REPEATED FOR EVERY ELEMENT IN VECTOR B. C UPON COMPLETION, THE OUTPUT MATRIX R CONTAINS A SUMMARY OF C ROW DATA AS SPECIFIED BY VECTOR B. EACH ELEMENT IN VECTOR S C CONTAINS A COUNT OF THE NUMBER OF ROWS OF A USED TO FORM THE C CORRESPONDING ROW OF R. ELEMENT S(L+1) CONTAINS A COUNT OF C THE NUMBER OF ROWS OF A NOT INCLUDED IN R AS A RESULT OF J C BEING LESS THAN ONE OR GREATER THAN L. C C .................................................................. C SUBROUTINE RTAB(A,B,R,S,N,M,MS,L) DIMENSION A(1),B(1),R(1),S(1) C C CLEAR OUTPUT AREAS C CALL LOC(M,L,IT,M,L,0) DO 10 IR=1,IT 10 R(IR)=0.0 DO 20 IS=1,L 20 S(IS)=0.0 S(L+1)=0.0 C DO 60 I=1,N C C TEST FOR THE KEY OUTSIDE THE RANGE C JR=B(I) IF (JR-1) 50,40,30 30 IF (JR-L) 40,40,50 C C C ADD ROW OF A TO ROW OF R AND 1 TO COUNT C 40 CALL RADD(A,I,R,JR,N,M,MS,L) S(JR)=S(JR)+1.0 GO TO 60 C 50 S(L+1)=S(L+1)+1.0 60 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE RTIE C C PURPOSE C ADJOIN TWO MATRICES WITH SAME COLUMN DIMENSION TO FORM ONE C RESULTANT MATRIX (SEE METHOD) C C USAGE C CALL RTIE(A,B,R,N,M,MSA,MSB,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A,B,R C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C L - NUMBER OF ROWS IN B C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B C MATRIX R IS ALWAYS A GENERAL MATRIX C MATRIX A MUST HAVE THE SAME NUMBER OF COLUMNS AS MATRIX B C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C MATRIX B IS ATTACHED TO THE BOTTOM OF MATRIX A . C THE RESULTANT MATRIX R CONTAINS N+L ROWS AND M COLUMNS. C C .................................................................. C SUBROUTINE RTIE(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) C NN=N IR=0 NX=NN MSX=MSA DO 9 J=1,M DO 8 II=1,2 DO 7 I=1,NN IR=IR+1 R(IR)=0.0 C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,J,IJ,NN,M,MSX) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IJ) 2,7,2 C C MOVE ELEMENT TO MATRIX R C 2 GO TO(3,4),II 3 R(IR)=A(IJ) GO TO 7 4 R(IR)=B(IJ) 7 CONTINUE C C REPEAT ABOVE FOR MATRIX B C MSX=MSB 8 NN=L C C RESET FOR NEXT COLUMN C MSX=MSA 9 NN=NX RETURN END C C .................................................................. C C SUBROUTINE RTMI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM FCT(X)=0 C BY MEANS OF MUELLER-S ITERATION METHOD. C C USAGE C CALL RTMI (X,F,FCT,XLI,XRI,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - RESULTANT ROOT OF EQUATION FCT(X)=0. C F - RESULTANT FUNCTION VALUE AT ROOT X. C FCT - NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED. C XLI - INPUT VALUE WHICH SPECIFIES THE INITIAL LEFT BOUND C OF THE ROOT X. C XRI - INPUT VALUE WHICH SPECIFIES THE INITIAL RIGHT BOUND C OF THE ROOT X. C EPS - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE C ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS C FOLLOWED BY IEND SUCCESSIVE STEPS OF C BISECTION, C IER=2 - BASIC ASSUMPTION FCT(XLI)*FCT(XRI) LESS C THAN OR EQUAL TO ZERO IS NOT SATISFIED. C C REMARKS C THE PROCEDURE ASSUMES THAT FUNCTION VALUES AT INITIAL C BOUNDS XLI AND XRI HAVE NOT THE SAME SIGN. IF THIS BASIC C ASSUMPTION IS NOT SATISFIED BY INPUT VALUES XLI AND XRI, THE C PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C SOLUTION OF EQUATION FCT(X)=0 IS DONE BY MEANS OF MUELLER-S C ITERATION METHOD OF SUCCESSIVE BISECTIONS AND INVERSE C PARABOLIC INTERPOLATION, WHICH STARTS AT THE INITIAL BOUNDS C XLI AND XRI. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF C FCT(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP C REQUIRES TWO EVALUATIONS OF FCT(X). FOR TEST ON SATISFACTORY C ACCURACY SEE FORMULAE (3,4) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE G. K. KRISTIANSEN, ZERO OF ARBITRARY C FUNCTION, BIT, VOL. 3 (1963), PP.205-206. C C .................................................................. C SUBROUTINE RTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER) C C C PREPARE ITERATION IER=0 XL=XLI XR=XRI X=XL TOL=X F=FCT(TOL) IF(F)1,16,1 1 FL=F X=XR TOL=X F=FCT(TOL) IF(F)2,16,2 2 FR=F IF(SIGN(1.,FL)+SIGN(1.,FR))25,3,25 C C BASIC ASSUMPTION FL*FR LESS THAN 0 IS SATISFIED. C GENERATE TOLERANCE FOR FUNCTION VALUES. 3 I=0 TOLF=100.*EPS C C C START ITERATION LOOP 4 I=I+1 C C START BISECTION LOOP DO 13 K=1,IEND X=.5*(XL+XR) TOL=X F=FCT(TOL) IF(F)5,16,5 5 IF(SIGN(1.,F)+SIGN(1.,FR))7,6,7 C C INTERCHANGE XL AND XR IN ORDER TO GET THE SAME SIGN IN F AND FR 6 TOL=XL XL=XR XR=TOL TOL=FL FL=FR FR=TOL 7 TOL=F-FL A=F*TOL A=A+A IF(A-FR*(FR-FL))8,9,9 8 IF(I-IEND)17,17,9 9 XR=X FR=F C C TEST ON SATISFACTORY ACCURACY IN BISECTION LOOP TOL=EPS A=ABS(XR) IF(A-1.)11,11,10 10 TOL=TOL*A 11 IF(ABS(XR-XL)-TOL)12,12,13 12 IF(ABS(FR-FL)-TOLF)14,14,13 13 CONTINUE C END OF BISECTION LOOP C C NO CONVERGENCE AFTER IEND ITERATION STEPS FOLLOWED BY IEND C SUCCESSIVE STEPS OF BISECTION OR STEADILY INCREASING FUNCTION C VALUES AT RIGHT BOUNDS. ERROR RETURN. IER=1 14 IF(ABS(FR)-ABS(FL))16,16,15 15 X=XL F=FL 16 RETURN C C COMPUTATION OF ITERATED X-VALUE BY INVERSE PARABOLIC INTERPOLATION 17 A=FR-F DX=(X-XL)*FL*(1.+F*(A-TOL)/(A*(FR-FL)))/TOL XM=X FM=F X=XL-DX TOL=X F=FCT(TOL) IF(F)18,16,18 C C TEST ON SATISFACTORY ACCURACY IN ITERATION LOOP 18 TOL=EPS A=ABS(X) IF(A-1.)20,20,19 19 TOL=TOL*A 20 IF(ABS(DX)-TOL)21,21,22 21 IF(ABS(F)-TOLF)16,16,22 C C PREPARATION OF NEXT BISECTION LOOP 22 IF(SIGN(1.,F)+SIGN(1.,FL))24,23,24 23 XR=X FR=F GO TO 4 24 XL=X FL=F XR=XM FR=FM GO TO 4 C END OF ITERATION LOOP C C C ERROR RETURN IN CASE OF WRONG INPUT DATA 25 IER=2 RETURN END C C .................................................................. C C SUBROUTINE RTNI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM F(X)=0 C BY MEANS OF NEWTON-S ITERATION METHOD. C C USAGE C CALL RTNI (X,F,DERF,FCT,XST,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - RESULTANT ROOT OF EQUATION F(X)=0. C F - RESULTANT FUNCTION VALUE AT ROOT X. C DERF - RESULTANT VALUE OF DERIVATIVE AT ROOT X. C FCT - NAME OF THE EXTERNAL SUBROUTINE USED. IT COMPUTES C TO GIVEN ARGUMENT X FUNCTION VALUE F AND DERIVATIVE C DERF. ITS PARAMETER LIST MUST BE X,F,DERF. C XST - INPUT VALUE WHICH SPECIFIES THE INITIAL GUESS OF C THE ROOT X. C EPS - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE C ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS, C IER=2 - AT ANY ITERATION STEP DERIVATIVE DERF WAS C EQUAL TO ZERO. C C REMARKS C THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2 C IF AT ANY ITERATION STEP DERIVATIVE OF F(X) IS EQUAL TO 0. C POSSIBLY THE PROCEDURE WOULD BE SUCCESSFUL IF IT IS STARTED C ONCE MORE WITH ANOTHER INITIAL GUESS XST. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINE FCT(X,F,DERF) MUST BE FURNISHED C BY THE USER. C C METHOD C SOLUTION OF EQUATION F(X)=0 IS DONE BY MEANS OF NEWTON-S C ITERATION METHOD, WHICH STARTS AT THE INITIAL GUESS XST OF C A ROOT X. CONVERGENCE IS QUADRATIC IF THE DERIVATIVE OF C F(X) AT ROOT X IS NOT EQUAL TO ZERO. ONE ITERATION STEP C REQUIRES ONE EVALUATION OF F(X) AND ONE EVALUATION OF THE C DERIVATIVE OF F(X). FOR TEST ON SATISFACTORY ACCURACY SEE C FORMULAE (2) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE R. ZURMUEHL, PRAKTISCHE MATHEMATIK FUER C INGENIEURE UND PHYSIKER, SPRINGER, BERLIN/GOETTINGEN/ C HEIDELBERG, 1963, PP.12-17. C C .................................................................. C SUBROUTINE RTNI(X,F,DERF,FCT,XST,EPS,IEND,IER) C C C PREPARE ITERATION IER=0 X=XST TOL=X CALL FCT(TOL,F,DERF) TOLF=100.*EPS C C C START ITERATION LOOP DO 6 I=1,IEND IF(F)1,7,1 C C EQUATION IS NOT SATISFIED BY X 1 IF(DERF)2,8,2 C C ITERATION IS POSSIBLE 2 DX=F/DERF X=X-DX TOL=X CALL FCT(TOL,F,DERF) C C TEST ON SATISFACTORY ACCURACY TOL=EPS A=ABS(X) IF(A-1.)4,4,3 3 TOL=TOL*A 4 IF(ABS(DX)-TOL)5,5,6 5 IF(ABS(F)-TOLF)7,7,6 6 CONTINUE C END OF ITERATION LOOP C C C NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN. IER=1 7 RETURN C C ERROR RETURN IN CASE OF ZERO DIVISOR 8 IER=2 RETURN END C C .................................................................. C C SUBROUTINE RTWI C C PURPOSE C TO SOLVE GENERAL NONLINEAR EQUATIONS OF THE FORM X=FCT(X) C BY MEANS OF WEGSTEIN-S ITERATION METHOD. C C USAGE C CALL RTWI (X,VAL,FCT,XST,EPS,IEND,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C X - RESULTANT ROOT OF EQUATION X=FCT(X). C VAL - RESULTANT VALUE OF X-FCT(X) AT ROOT X. C FCT - NAME OF THE EXTERNAL FUNCTION SUBPROGRAM USED. C XST - INPUT VALUE WHICH SPECIFIES THE INITIAL GUESS OF C THE ROOT X. C EPS - INPUT VALUE WHICH SPECIFIES THE UPPER BOUND OF THE C ERROR OF RESULT X. C IEND - MAXIMUM NUMBER OF ITERATION STEPS SPECIFIED. C IER - RESULTANT ERROR PARAMETER CODED AS FOLLOWS C IER=0 - NO ERROR, C IER=1 - NO CONVERGENCE AFTER IEND ITERATION STEPS, C IER=2 - AT ANY ITERATION STEP THE DENOMINATOR OF C ITERATION FORMULA WAS EQUAL TO ZERO. C C REMARKS C THE PROCEDURE IS BYPASSED AND GIVES THE ERROR MESSAGE IER=2 C IF AT ANY ITERATION STEP THE DENOMINATOR OF ITERATION C FORMULA WAS EQUAL TO ZERO. THAT MEANS THAT THERE IS AT C LEAST ONE POINT IN THE RANGE IN WHICH ITERATION MOVES WITH C DERIVATIVE OF FCT(X) EQUAL TO 1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(X) MUST BE FURNISHED C BY THE USER. C C METHOD C SOLUTION OF EQUATION X=FCT(X) IS DONE BY MEANS OF C WEGSTEIN-S ITERATION METHOD, WHICH STARTS AT THE INITIAL C GUESS XST OF A ROOT X. ONE ITERATION STEP REQUIRES ONE C EVALUATION OF FCT(X). FOR TEST ON SATISFACTORY ACCURACY SEE C FORMULAE (2) OF MATHEMATICAL DESCRIPTION. C FOR REFERENCE, SEE C (1) G. N. LANCE, NUMERICAL METHODS FOR HIGH SPEED COMPUTERS, C ILIFFE, LONDON, 1960, PP.134-138, C (2) J. WEGSTEIN, ALGORITHM 2, CACM, VOL.3, ISS.2 (1960), C PP.74, C (3) H.C. THACHER, ALGORITHM 15, CACM, VOL.3, ISS.8 (1960), C PP.475, C (4) J.G. HERRIOT, ALGORITHM 26, CACM, VOL.3, ISS.11 (1960), C PP.603. C C .................................................................. C SUBROUTINE RTWI(X,VAL,FCT,XST,EPS,IEND,IER) C C C PREPARE ITERATION IER=0 TOL=XST X=FCT(TOL) A=X-XST B=-A TOL=X VAL=X-FCT(TOL) C C C START ITERATION LOOP DO 6 I=1,IEND IF(VAL)1,7,1 C C EQUATION IS NOT SATISFIED BY X 1 B=B/VAL-1. IF(B)2,8,2 C C ITERATION IS POSSIBLE 2 A=A/B X=X+A B=VAL TOL=X VAL=X-FCT(TOL) C C TEST ON SATISFACTORY ACCURACY TOL=EPS D=ABS(X) IF(D-1.)4,4,3 3 TOL=TOL*D 4 IF(ABS(A)-TOL)5,5,6 5 IF(ABS(VAL)-10.*TOL)7,7,6 6 CONTINUE C END OF ITERATION LOOP C C C NO CONVERGENCE AFTER IEND ITERATION STEPS. ERROR RETURN. IER=1 7 RETURN C C ERROR RETURN IN CASE OF ZERO DIVISOR 8 IER=2 RETURN END C C .................................................................. C C SUBROUTINE SADD C C PURPOSE C ADD A SCALAR TO EACH ELEMENT OF A MATRIX TO FORM A RESULTANT C MATRIX C C USAGE C CALL SADD(A,C,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN MATRIX A AND R C M - NUMBER OF COLUMNS IN MATRIX A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C SCALAR IS ADDED TO EACH ELEMENT OF MATRIX C C .................................................................. C SUBROUTINE SADD(A,C,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C ADD SCALAR C DO 1 I=1,IT 1 R(I)=A(I)+C RETURN END C C .................................................................. C C SUBROUTINE SCLA C C PURPOSE C SET EACH ELEMENT OF A MATRIX EQUAL TO A GIVEN SCALAR C C USAGE C CALL SCLA (A,C,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C N - NUMBER OF ROWS IN MATRIX A C M - NUMBER OF COLUMNS IN MATRIX A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT OF MATRIX A IS REPLACED BY SCALAR C C C .................................................................. C SUBROUTINE SCLA(A,C,N,M,MS) DIMENSION A(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C REPLACE BY SCALAR C DO 1 I=1,IT 1 A(I)=C RETURN END C C .................................................................. C C SUBROUTINE SCMA C C PURPOSE C MULTIPLY COLUMN OF MATRIX BY A SCALAR AND ADD TO ANOTHER C COLUMN OF THE SAME MATRIX C C USAGE C CALL SCMA(A,C,N,LA,LB) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX C C - SCALAR C N - NUMBER OF ROWS IN A C LA - COLUMN IN A TO BE MULTIPLIED BY SCALAR C LB - COLUMN IN A TO WHICH PRODUCT IS ADDED C IF 0 IS SPECIFIED, PRODUCT REPLACES ELEMENTS IN LA C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH ELEMENT OF COLUMN LA IS MULTIPLIED BY SCALAR C AND THE C PRODUCT IS ADDED TO THE CORRESPONDING ELEMENT OF COLUMN LB. C COLUMN LA REMAINS UNAFFECTED BY THE OPERATION. C IF PARAMETER LB CONTAINS ZERO, MULTIPLICATION BY THE SCALAR C IS PERFORMED AND THE PRODUCT REPLACES ELEMENTS IN LA. C C .................................................................. C SUBROUTINE SCMA(A,C,N,LA,LB) DIMENSION A(1) C C LOCATE STARTING POINT OF BOTH COLUMNS C ILA=N*(LA-1) ILB=N*(LB-1) C DO 3 I=1,N ILA=ILA+1 ILB=ILB+1 C C CHECK LB FOR ZERO C IF(LB) 1,2,1 C C IF NOT MULTIPLY BY CONSTANT AND ADD TO SECOND COLUMN C 1 A(ILB)=A(ILA)*C+A(ILB) GO TO 3 C C OTHERWISE, MULTIPLY COLUMN BY CONSTANT C 2 A(ILA)=A(ILA)*C 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE SDIV C C PURPOSE C DIVIDE EACH ELEMENT OF A MATRIX BY A SCALAR TO FORM A C RESULTANT MATRIX C C USAGE C CALL SDIV(A,C,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN MATRIX A AND R C M - NUMBER OF COLUMNS IN MATRIX A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C IF SCALAR IS ZERO, DIVISION IS PERFORMED ONLY ONCE TO CAUSE C FLOATING POINT OVERFLOW CONDITION C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C EACH ELEMENT OF MATRIX IS DIVIDED BY SCALAR C C .................................................................. C SUBROUTINE SDIV(A,C,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C DIVIDE BY SCALAR (IF SCALAR IS ZERO, DIVIDE ONLY ONCE) C IF(C) 2,1,2 1 IT=1 2 DO 3 I=1,IT 3 R(I)=A(I)/C RETURN END C C .................................................................. C C SUBROUTINE SE15 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A C VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO C EQUIDISTANTLY SPACED ARGUMENT VALUES. C C USAGE C CALL SE15(Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C Y - GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM) C Z - RESULTING VECTOR OF SMOOTHED FUNCTION VALUES C (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH C SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE C LEAST-SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 5 C SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE C HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS, C MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.) C C .................................................................. C SUBROUTINE SE15(Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-5)3,1,1 C C PREPARE LOOP 1 A=Y(1)+Y(1) C=Y(2)+Y(2) B=.2*(A+Y(1)+C+Y(3)-Y(5)) C=.1*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4)) C C START LOOP DO 2 I=5,NDIM A=B B=C C=.2*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-4)=A C END OF LOOP C C UPDATE LAST FOUR COMPONENTS A=Y(NDIM)+Y(NDIM) A=.1*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2) 1 +Y(NDIM-3)) Z(NDIM-3)=B Z(NDIM-2)=C Z(NDIM-1)=A Z(NDIM)=A+A-C IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 3 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE SE35 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN A C VECTOR OF FUNCTION VALUES WHOSE ENTRIES CORRESPOND TO C EQUIDISTANTLY SPACED ARGUMENT VALUES. C C USAGE C CALL SE35(Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C Y - GIVEN VECTOR OF FUNCTION VALUES (DIMENSION NDIM) C Z - RESULTING VECTOR OF SMOOTHED FUNCTION VALUES C (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS Y AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 5 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS Y. IF Y IS C DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINE AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF X IS THE (SUPPRESSED) VECTOR OF ARGUMENT VALUES, THEN C EXCEPT AT THE POINTS X(1),X(2),X(NDIM-1) AND X(NDIM), EACH C SMOOTHED VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE C LEAST-SQUARES POLYNOMIAL OF DEGREE 3 RELEVANT TO THE 5 C SUCCESSIVE POINTS (X(I+K),Y(I+K)) K = -2,-1,...,2. (SEE C HILDEBRAND, F.B., INTRODUCTION TO NUMERICAL ANALYSIS, C MC GRAW-HILL, NEW YORK/TORONTO/LONDON, 1956, PP. 295-302.) C C .................................................................. C SUBROUTINE SE35(Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-5)4,1,1 C C PREPARE LOOP 1 B=Y(1) C=Y(2) C C START LOOP DO 3 I=5,NDIM A=B B=C C=Y(I-2) C C GENERATE FOURTH CENTRAL DIFFERENCE D=C-B-Y(I-1) D=D+D+C D=D+D+A+Y(I) C C CHECK FIRST TWO COMPONENTS IF(I-5)2,2,3 2 Z(1)=A-.01428571*D Z(2)=B+.05714286*D 3 Z(I-2)=C-.08571429*D C END OF LOOP C C UPDATE LAST TWO COMPONENTS Z(NDIM-1)=Y(NDIM-1)+.05714286*D Z(NDIM)=Y(NDIM)-.01428571*D IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 5 4 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE SG13 C C PURPOSE C TO COMPUTE A VECTOR OF SMOOTHED FUNCTION VALUES GIVEN C VECTORS OF ARGUMENT VALUES AND CORRESPONDING FUNCTION C VALUES. C C USAGE C CALL SG13(X,Y,Z,NDIM,IER) C C DESCRIPTION OF PARAMETERS C X - GIVEN VECTOR OF ARGUMENT VALUES (DIMENSION NDIM) C Y - GIVEN VECTOR OF FUNCTION VALUES CORRESPONDING TO X C (DIMENSION NDIM) C Z - RESULTING VECTOR OF SMOOTHED FUNCTION VALUES C (DIMENSION NDIM) C NDIM - DIMENSION OF VECTORS X,Y,AND Z C IER - RESULTING ERROR PARAMETER C IER = -1 - NDIM IS LESS THAN 3 C IER = 0 - NO ERROR C C REMARKS C (1) IF IER=-1 THERE HAS BEEN NO COMPUTATION. C (2) Z CAN HAVE THE SAME STORAGE ALLOCATION AS X OR Y. IF C X OR Y IS DISTINCT FROM Z, THEN IT IS NOT DESTROYED. C C SUBROUTINES AND SUBPROGRAMS REQUIRED C NONE C C METHOD C EXCEPT AT THE ENDPOINTS X(1) AND X(NDIM), EACH SMOOTHED C VALUE Z(I) IS OBTAINED BY EVALUATING AT X(I) THE LEAST- C SQUARES POLYNOMIAL OF DEGREE 1 RELEVANT TO THE 3 SUCCESSIVE C POINTS (X(I+K),Y(I+K)) K = -1,0,1.(SEE HILDEBRAND, F.B., C INTRODUCTION TO NUMERICAL ANALYSIS, MC GRAW-HILL, NEW YORK/ C TORONTO/LONDON, 1956, PP.258-311.) C C .................................................................. C SUBROUTINE SG13(X,Y,Z,NDIM,IER) C C DIMENSION X(1),Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-3)7,1,1 C C START LOOP 1 DO 6 I=3,NDIM XM=.3333333*(X(I-2)+X(I-1)+X(I)) YM=.3333333*(Y(I-2)+Y(I-1)+Y(I)) T1=X(I-2)-XM T2=X(I-1)-XM T3=X(I)-XM XM=T1*T1+T2*T2+T3*T3 IF(XM)3,3,2 2 XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM C C CHECK FIRST POINT 3 IF(I-3)4,4,5 4 H=XM*T1+YM 5 Z(I-2)=H 6 H=XM*T2+YM C END OF LOOP C C UPDATE LAST TWO COMPONENTS Z(NDIM-1)=H Z(NDIM)=XM*T3+YM IER=0 RETURN C C ERROR EXIT IN CASE NDIM IS LESS THAN 3 7 IER=-1 RETURN END C C .................................................................. C C SUBROUTINE SICI C C PURPOSE C COMPUTES THE SINE AND COSINE INTEGRAL C C USAGE C CALL SICI(SI,CI,X) C C DESCRIPTION OF PARAMETERS C SI - THE RESULTANT VALUE SI(X) C CI - THE RESULTANT VALUE CI(X) C X - THE ARGUMENT OF SI(X) AND CI(X) C C REMARKS C THE ARGUMENT VALUE REMAINS UNCHANGED C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C DEFINITION C SI(X)=INTEGRAL(SIN(T)/T) C CI(X)=INTEGRAL(COS(T)/T) C EVALUATION C REDUCTION OF RANGE USING SYMMETRY. C DIFFERENT APPROXIMATIONS ARE USED FOR ABS(X) GREATER C THAN 4 AND FOR ABS(X) LESS THAN 4. C REFERENCE C LUKE AND WIMP, 'POLYNOMIAL APPROXIMATIONS TO INTEGRAL C TRANSFORMS', MATHEMATICAL TABLES AND OTHER AIDS TO C COMPUTATION, VOL. 15, 1961, ISSUE 74, PP. 174-178. C C .................................................................. C SUBROUTINE SICI(SI,CI,X) Z=ABS(X) IF(Z-4.)1,1,4 1 Y=(4.-Z)*(4.+Z) SI=-1.570797E0 IF(Z)3,2,3 2 CI=-1.7E38 0 RETURN 3 SI=X*(((((1.753141E-9*Y+1.568988E-7)*Y+1.374168E-5)*Y+6.939889E-4) 1*Y+1.964882E-2)*Y+4.395509E-1+SI/X) CI=((5.772156E-1+ALOG(Z))/Z-Z*(((((1.386985E-10*Y+1.584996E-8)*Y 1+1.725752E-6)*Y+1.185999E-4)*Y+4.990920E-3)*Y+1.315308E-1))*Z RETURN 4 SI=SIN(Z) Y=COS(Z) Z=4./Z U=((((((((4.048069E-3*Z-2.279143E-2)*Z+5.515070E-2)*Z-7.261642E-2) 1*Z+4.987716E-2)*Z-3.332519E-3)*Z-2.314617E-2)*Z-1.134958E-5)*Z 2+6.250011E-2)*Z+2.583989E-10 V=(((((((((-5.108699E-3*Z+2.819179E-2)*Z-6.537283E-2)*Z 1+7.902034E-2)*Z-4.400416E-2)*Z-7.945556E-3)*Z+2.601293E-2)*Z 2-3.764000E-4)*Z-3.122418E-2)*Z-6.646441E-7)*Z+2.500000E-1 CI=Z*(SI*V-Y*U) SI=-Z*(SI*U+Y*V) IF(X)5,6,6 5 SI=3.141593E0-SI 6 RETURN END C C .................................................................. C C SUBROUTINE SIGNT C C PURPOSE C TO PERFORM A NON-PARAMETRIC SIGN TEST, GIVEN TWO SETS OF C MATCHED OBSERVATIONS. IT TESTS THE NULL HYPOTHESIS THAT THE C DIFFERENCES BETWEEN EACH PAIR OF MATCHED OBSERVATIONS HAS A C MEDIAN EQUAL TO ZERO. C C USAGE C CALL SIGNT (N,A,B,K,M,P,IE) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS IN SETS A AND B C A - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE FIRST C SAMPLE, A C B - INPUT VECTOR OF LENGTH N CONTAINING DATA FROM THE SECOND C SAMPLE, B C K - OUTPUT VARIABLE CONTAINING THE NUMBER OF PAIRS OF C OBSERVATIONS FROM THE TWO SAMPLES WHOSE DIFFERENCES ARE C NON-ZERO C M - OUTPUT VARIABLE CONTAINING THE NUMBER OF PLUS OR MINUS C DIFFERENCES, WHICHEVER IS FEWER. C P - COMPUTED PROBABILITY OF AS FEW AS M NUMBER OF PAIRS C HAVING THE SAME SIGN, ASSUMING THAT THE SAMPLES CAME C FROM THE SAME POPULATION. C IE- 0, IF THERE IS NO ERROR. C 1, IF K IS ZERO. IN THIS CASE, P IS SET TO 1.0 AND C M TO 0. C C REMARKS C IF K IS LESS THAN OR EQUAL TO 25, THE PROBABILITY WILL BE C COMPUTED USING THE BINOMIAL DISTRIBUTION. IF K IS GREATER C THAN 25, THE PROBABILITY WILL BE COMPUTED USING THE NORMAL C APPROXIMATION TO THE BINOMIAL DISTRIBUTION. C P COMPUTED IS THE PROBABILITY FOR A ONE-TAILED TEST. THUS, C FOR A TWO TAILED TEST, DOUBLE THE VALUE FOR P. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NDTR C C METHOD C REFER TO DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS (MCGRAW-HILL, 1957). C C .................................................................. C SUBROUTINE SIGNT (N,A,B,K,M,P,IE) C DIMENSION A(1),B(1) DOUBLE PRECISION FN,FD C C INITIALIZATION C IE=0 K=0 MPLUS=0 MMINS=0 C C FIND (+) OR (-) DIFFERENCE C DO 40 I=1,N D=A(I)-B(I) IF(D) 20, 40, 30 C C (-) DIFFERENCE C 20 K=K+1 MMINS=MMINS+1 GO TO 40 C C (+) DIFFERENCE C 30 K=K+1 MPLUS=MPLUS+1 C 40 CONTINUE IF(K) 41,41,42 41 IE=1 P=1.0 M=0 GO TO 95 42 FK=K C C FIND THE NUMBER OF FEWER SIGNS C IF(MPLUS-MMINS) 45, 45, 50 45 M=MPLUS GO TO 55 50 M=MMINS C C TEST WHETHER K IS GREATER THAN 25 C 55 IF(K-25) 60, 60, 77 C C K IS LESS THAN OR EQUAL TO 25 C 60 P=1.0 IF(M) 75, 75, 65 65 FN=1.0 FD=1.0 DO 70 I=1,M FI=I FN=FN*(FK-(FI-1.0)) FD=FD*FI 70 P=P+FN/FD C 75 P=P/(2.0**K) GO TO 95 C C K IS GREATER THAN 25. COMPUTE MEAN, STANDARD DEVIATION, AND Z C 77 U=0.5*FK S=0.5*SQRT(FK) FM=M IF(FM-U) 80, 85, 85 80 CON=0.5 GO TO 90 85 CON=0.0 90 Z=(FM+CON-U)/S C C COMPUTE P ASSOCIATED WITH THE VALUE AS EXTREME AS Z C CALL NDTR (Z,P,D) C 95 RETURN END C C .................................................................. C C SUBROUTINE SIMQ C C PURPOSE C OBTAIN SOLUTION OF A SET OF SIMULTANEOUS LINEAR EQUATIONS, C AX=B C C USAGE C CALL SIMQ(A,B,N,KS) C C DESCRIPTION OF PARAMETERS C A - MATRIX OF COEFFICIENTS STORED COLUMNWISE. THESE ARE C DESTROYED IN THE COMPUTATION. THE SIZE OF MATRIX A IS C N BY N. C B - VECTOR OF ORIGINAL CONSTANTS (LENGTH N). THESE ARE C REPLACED BY FINAL SOLUTION VALUES, VECTOR X. C N - NUMBER OF EQUATIONS AND VARIABLES. N MUST BE .GT. ONE. C KS - OUTPUT DIGIT C 0 FOR A NORMAL SOLUTION C 1 FOR A SINGULAR SET OF EQUATIONS C C REMARKS C MATRIX A MUST BE GENERAL. C IF MATRIX IS SINGULAR , SOLUTION VALUES ARE MEANINGLESS. C AN ALTERNATIVE SOLUTION MAY BE OBTAINED BY USING MATRIX C INVERSION (MINV) AND MATRIX PRODUCT (GMPRD). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C METHOD OF SOLUTION IS BY ELIMINATION USING LARGEST PIVOTAL C DIVISOR. EACH STAGE OF ELIMINATION CONSISTS OF INTERCHANGING C ROWS WHEN NECESSARY TO AVOID DIVISION BY ZERO OR SMALL C ELEMENTS. C THE FORWARD SOLUTION TO OBTAIN VARIABLE N IS DONE IN C N STAGES. THE BACK SOLUTION FOR THE OTHER VARIABLES IS C CALCULATED BY SUCCESSIVE SUBSTITUTIONS. FINAL SOLUTION C VALUES ARE DEVELOPED IN VECTOR B, WITH VARIABLE 1 IN B(1), C VARIABLE 2 IN B(2),........, VARIABLE N IN B(N). C IF NO PIVOT CAN BE FOUND EXCEEDING A TOLERANCE OF 0.0, C THE MATRIX IS CONSIDERED SINGULAR AND KS IS SET TO 1. THIS C TOLERANCE CAN BE MODIFIED BY REPLACING THE FIRST STATEMENT. C C .................................................................. C SUBROUTINE SIMQ(A,B,N,KS) DIMENSION A(1),B(1) C C FORWARD SOLUTION C TOL=0.0 KS=0 JJ=-N DO 65 J=1,N JY=J+1 JJ=JJ+N+1 BIGA=0 IT=JJ-J DO 30 I=J,N C C SEARCH FOR MAXIMUM COEFFICIENT IN COLUMN C IJ=IT+I IF(ABS(BIGA)-ABS(A(IJ))) 20,30,30 20 BIGA=A(IJ) IMAX=I 30 CONTINUE C C TEST FOR PIVOT LESS THAN TOLERANCE (SINGULAR MATRIX) C IF(ABS(BIGA)-TOL) 35,35,40 35 KS=1 RETURN C C INTERCHANGE ROWS IF NECESSARY C 40 I1=J+N*(J-2) IT=IMAX-J DO 50 K=J,N I1=I1+N I2=I1+IT SAVE=A(I1) A(I1)=A(I2) A(I2)=SAVE C C DIVIDE EQUATION BY LEADING COEFFICIENT C 50 A(I1)=A(I1)/BIGA SAVE=B(IMAX) B(IMAX)=B(J) B(J)=SAVE/BIGA C C ELIMINATE NEXT VARIABLE C IF(J-N) 55,70,55 55 IQS=N*(J-1) DO 65 IX=JY,N IXJ=IQS+IX IT=J-IX DO 60 JX=JY,N IXJX=N*(JX-1)+IX JJX=IXJX+IT 60 A(IXJX)=A(IXJX)-(A(IXJ)*A(JJX)) 65 B(IX)=B(IX)-(B(J)*A(IXJ)) C C BACK SOLUTION C 70 NY=N-1 IT=N*N DO 80 J=1,NY IA=IT-J IB=N-J IC=N DO 80 K=1,J B(IB)=B(IB)-A(IA)*B(IC) IA=IA-N 80 IC=IC-1 RETURN END C C .................................................................. C C SUBROUTINE SMO C C PURPOSE C TO SMOOTH OR FILTER SERIES A BY WEIGHTS W. C C USAGE C CALL SMO (A,N,W,M,L,R) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF LENGTH N CONTAINING TIME SERIES DATA. C N - LENGTH OF SERIES A. C W - INPUT VECTOR OF LENGTH M CONTAINING WEIGHTS. C M - NUMBER OF ITEMS IN WEIGHT VECTOR. M MUST BE AN ODD C INTEGER. (IF M IS AN EVEN INTEGER, ANY FRACTION C RESULTING FROM THE CALCULATION OF (L*(M-1))/2 IN (1) C AND (2) BELOW WILL BE TRUNCATED.) C L - SELECTION INTEGER. FOR EXAMPLE, L=12 MEANS THAT WEIGHTS C ARE APPLIED TO EVERY 12-TH ITEM OF A. L=1 APPLIES C WEIGHTS TO SUCCESSIVE ITEMS OF A. FOR MONTHLY DATA, C L=12 GIVES YEAR-TO-YEAR AVERAGES AND L=1 GIVES MONTH-TO- C MONTH AVERAGES. C R - OUTPUT VECTOR OF LENGTH N. FROM IL TO IH ELEMENTS OF C THE VECTOR R ARE FILLED WITH THE SMOOTHED SERIES AND C OTHER ELEMENTS WITH ZERO, WHERE C IL=(L*(M-1))/2+1 ................ (1) C IH=N-(L*(M-1))/2 ................ (2) C C REMARKS C N MUST BE GREATER THAN OR EQUAL TO THE PRODUCT OF L*M. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO THE ARTICLE 'FORTRAN SUBROUTINES FOR TIME SERIES C ANALYSIS', BY J. R. HEALY AND B. P. BOGERT, COMMUNICATIONS C OF ACM, V.6, NO.1, JANUARY, 1963. C C .................................................................. C SUBROUTINE SMO (A,N,W,M,L,R) DIMENSION A(1),W(1),R(1) C C INITIALIZATION C DO 110 I=1,N 110 R(I)=0.0 IL=(L*(M-1))/2+1 IH=N-(L*(M-1))/2 C C SMOOTH SERIES A BY WEIGHTS W C DO 120 I=IL,IH K=I-IL+1 DO 120 J=1,M IP=(J*L)-L+K 120 R(I)=R(I)+A(IP)*W(J) RETURN END C C .................................................................. C C SAMPLE PROGRAM FOR REAL AND COMPLEX ROOTS OF A REAL POLY- C NOMIAL - SMPRT C C PURPOSE C COMPUTES THE REAL AND COMPLEX ROOTS OF A REAL POLYNOMIAL C WHOSE COEFFICIENTS ARE INPUT. C C REMARKS C THE ORDER OF THE POLYNOMIAL MUST BE GREATER THAN ONE AND C LESS THAN THIRTY SEVEN C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C POLRT C C METHOD C READS A CONTROL CARD CONTAINING THE IDENTIFICATION CODE AND C THE ORDER OF THE POLYNOMIAL WHOSE COEFFICIENTS ARE C CONTAINED ON THE FOLLOWING DATA CARDS. THE COEFFICIENTS C ARE THEN READ AND THE ROOTS ARE COMPUTED. C MORE THAN ONE CONTROL CARD AND CORRESPONDING DATA CAN BE C PROCESSED. EXECUTION IS TERMINATED BY A BLANK CONTROL CARD. C C .................................................................. C DIMENSION A(37),W(37),ROOTR(37),ROOTI(37) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION A,W,ROOTR,ROOTI C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C C OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') C OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') 5 READ(5,10)ID,IORD 10 FORMAT(1X,I4,3X,I2) IF(ID+IORD)100,100,20 20 WRITE(6,30)ID,IORD 30 FORMAT(1H1,61HREAL AND COMPLEX ROOTS OF A POLYNOMIAL USING SUBROUT 1INE POLRT/// 17H FOR POLYNOMIAL ,I4,2X,10HOF ORDER ,I2//1H , 226HTHE INPUT COEFFICIENTS ARE,//) J=IORD+1 READ(5,40)(A(I),I=1,J) 40 FORMAT(7F10.0) WRITE(6,50)(A(I),I=1,J) 50 FORMAT(6E16.7) CALL POLRT(A,W,IORD,ROOTR,ROOTI,IER) IF(IER-1)90,60,70 60 WRITE(6,65) 65 FORMAT(//1H ,33HORDER OF POLYNOMIAL LESS THAN ONE) GO TO 5 70 IF(IER-3)75,80,78 75 WRITE(6,77) 77 FORMAT(//1H ,35HORDER OF POLYNOMIAL GREATER THAN 36) GO TO 5 78 WRITE(6,79) 79 FORMAT(//1H ,31H HIGH ORDER COEFFICIENT IS ZERO) GO TO 5 80 WRITE(6,85) 85 FORMAT(//1H ,49HUNABLE TO DETERMINE ROOT. THOSE ALREADY FOUND ARE) 90 WRITE(6,95) 95 FORMAT(//1H ,5X,9HREAL ROOT,6X,12HCOMPLEX ROOT//) DO 96 I=1,IORD 96 WRITE(6,97)ROOTR(I),ROOTI(I) 97 FORMAT(1H ,2E16.7) GO TO 5 100 STOP END C C .................................................................. C C SUBROUTINE SMPY C C PURPOSE C MULTIPLY EACH ELEMENT OF A MATRIX BY A SCALAR TO FORM A C RESULTANT MATRIX C C USAGE C CALL SMPY(A,C,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN MATRIX A AND R C M - NUMBER OF COLUMNS IN MATRIX A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C SCALAR IS MULTIPLIED BY EACH ELEMENT OF MATRIX C C .................................................................. C SUBROUTINE SMPY(A,C,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C MULTIPLY BY SCALAR C DO 1 I=1,IT 1 R(I)=A(I)*C RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM - SOLN C C PURPOSE C SOLUTION OF A SET OF SIMULTANEOUS EQUATIONS C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SIMQ C MATIN C MXOUT C LOC C C METHOD C A MATRIX OF SIMULTANEOUS EQUATIONS COEFFICIENTS AND A VECTOR C OF CONSTANTS ARE READ FROM THE STANDARD INPUT DEVICE. THE C SOLUTION IS OBTAINED AND LISTED ON THE STANDARD OUTPUT C DEVICE. THIS PROCEDURE IS REPEATED FOR OTHER SETS OF C EQUATIONS UNTIL A BLANK CARD IS ENCOUNTERED. C C .................................................................. C C MATRIX IS DIMENSIONED FOR 2500 ELEMENTS. THEREFORE, NUMBER OF C EQUATIONS TO BE SOLVED CANNOT EXCEED 50 UNLESS DIMENSION C STATEMENT IS CHANGED cC c DIMENSION A(2500),B(50) cC c10 FORMAT(1H1,34HSOLUTION OF SIMULTANEOUS EQUATIONS) c11 FORMAT(1H0,44HDIMENSIONED AREA TOO SMALL FOR INPUT MATRIX ,I4) c12 FORMAT(1H0,20HEXECUTION TERMINATED) c13 FORMAT(1H0,47HROW AND COLUMN DIMENSIONS NOT EQUAL FOR MATRIX ,I4) c14 FORMAT(1H0,42HINCORRECT NUMBER OF DATA CARDS FOR MATRIX ,I4) c15 FORMAT(1H0,18HGO ON TO NEXT CASE) c16 FORMAT(1H0,38HSTRUCTURE CODE IS NOT ZERO FOR MATRIX ,I4) c17 FORMAT(1H1,17HORIGINAL B VECTOR,////) c18 FORMAT(1H1,15HSOLUTION VALUES,////) c19 FORMAT(1H0,18HMATRIX IS SINGULAR) c20 FORMAT(7F10.0) c21 FORMAT(I3,10X,E16.6) c22 FORMAT(1H0,11HEND OF CASE) cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC cC .................................................................. cC c WRITE (6,10) c25 CALL MATIN(ICOD,A,2500,N,M,MS,IER) c IF(N) 30,95,30 c30 IF(IER-1) 45,35,40 c35 WRITE(6,11) ICOD c GO TO 90 c40 WRITE(6,14) ICOD c GO TO 95 c45 IF(N-M) 50,55,50 c50 WRITE(6,13) ICOD c GO TO 90 c55 IF(MS) 60,65,60 c60 WRITE(6,16) ICOD c GO TO 90 c65 CALL MXOUT(ICOD,A,N,M,MS,60,120,2) c READ(5,20)(B(I),I=1,N) c WRITE(6,17) c DO 70 I=1,N c70 WRITE(6,21) I,B(I) c CALL SIMQ(A,B,N,KS) c IF(KS-1) 80,75,80 c75 WRITE(6,19) c WRITE(6,15) c GO TO 25 c80 WRITE(6,18) c DO 85 I=1,N c85 WRITE(6,21) I,B(I) c WRITE(6,22) c GO TO 25 c90 READ(5,20)(B(I),I=1,N) c WRITE(6,15) c GO TO 25 c95 WRITE(6,12) c STOP c END C C .................................................................. C C SUBROUTINE SRANK C C PURPOSE C TEST CORRELATION BETWEEN TWO VARIABLES BY MEANS OF SPEARMAN C RANK CORRELATION COEFFICIENT C C USAGE C CALL SRANK(A,B,R,N,RS,T,NDF,NR) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF N OBSERVATIONS FOR FIRST VARIABLE C B - INPUT VECTOR OF N OBSERVATIONS FOR SECOND VARIABLE C R - OUTPUT VECTOR FOR RANKED DATA, LENGTH IS 2*N. SMALLEST C OBSERVATION IS RANKED 1, LARGEST IS RANKED N. TIES C ARE ASSIGNED AVERAGE OF TIED RANKS. C N - NUMBER OF OBSERVATIONS C RS - SPEARMAN RANK CORRELATION COEFFICIENT (OUTPUT) C T - TEST OF SIGNIFICANCE OF RS (OUTPUT) C NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT) C NR - CODE, 0 FOR UNRANKED DATA IN A AND B, 1 FOR RANKED C DATA IN A AND B (INPUT) C C REMARKS C T IS SET TO ZERO IF N IS LESS THAN TEN C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANK C TIE C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 9 C C .................................................................. C SUBROUTINE SRANK(A,B,R,N,RS,T,NDF,NR) DIMENSION A(1),B(1),R(1) C FNNN=N*N*N-N C C DETERMINE WHETHER DATA IS RANKED C IF(NR-1) 5, 10, 5 C C RANK DATA IN A AND B VECTORS AND ASSIGN TIED OBSERVATIONS C AVERAGE OF TIED RANKS C 5 CALL RANK (A,R,N) CALL RANK (B,R(N+1),N) GO TO 40 C C MOVE RANKED DATA TO R VECTOR C 10 DO 20 I=1,N 20 R(I)=A(I) DO 30 I=1,N J=I+N 30 R(J)=B(I) C C COMPUTE SUM OF SQUARES OF RANK DIFFERENCES C 40 D=0.0 DO 50 I=1,N J=I+N 50 D=D+(R(I)-R(J))*(R(I)-R(J)) C C COMPUTE TIED SCORE INDEX C KT=1 CALL TIE (R,N,KT,TSA) CALL TIE (R(N+1),N,KT,TSB) C C COMPUTE SPEARMAN RANK CORRELATION COEFFICIENT C IF(TSA) 60,55,60 55 IF(TSB) 60,57,60 57 RS=1.0-6.0*D/FNNN GO TO 70 60 X=FNNN/12.0-TSA Y=X+TSA-TSB RS=(X+Y-D)/(2.0*(SQRT(X*Y))) C C COMPUTE T AND DEGREES OF FREEDOM IF N IS 10 OR LARGER C T=0.0 70 IF(N-10) 80,75,75 75 T=RS*SQRT(FLOAT(N-2)/(1.0-RS*RS)) 80 NDF=N-2 RETURN END C C .................................................................. C C SUBROUTINE SRATE C C PURPOSE C TO COMPUTE THE PROPORTION OF SUBJECTS SURVIVING, THE C SURVIVAL RATES AND THE STANDARD ERRORS FOR SUCCESSIVELY C REDUCED TIME PERIODS. THE SURVIVAL RATE IS COMPUTED FOR C EACH OF K PERIODS, WHERE K IS A CONSTANT TO BE SPECIFIED AND C IS LESS THAN OR EQUAL TO N (WHERE N = TOTAL NUMBER OF C PERIODS). C C USAGE C CALL SRATE (N,K,X,IE) C C DESCRIPTION OF PARAMETERS C N - THE TOTAL NUMBER OF PERIODS AFTER TREATMENT OR DIAGNOSIS C K - THE SPECIFIED PERIOD UP TO WHICH SURVIVAL RATES ARE TO C BE CALCULATED C X - AN INPUT AND OUTPUT MATRIX (N X 9) CONTAINING THE C FOLLOWING INFORMATION C FOR INPUT--STORED IN THE N ROWS OF EACH COLUMN C COL 1 - NUMBER OF SUBJECTS ALIVE AT THE BEGINNING OF C PERIOD C COL 2 - NUMBER OF SUBJECTS WHICH DIED DURING THE C PERIOD C COL 3 - NUMBER OF SUBJECTS LOST TO FOLLOW-UP DURING C THE PERIOD C COL 4 - NUMBER OF SUBJECTS WITHDRAWN ALIVE DURING THE C PERIOD C FOR OUTPUT--STORED IN THE FIRST K ROWS OF EACH C COLUMN C COL 5 - EFFECTIVE NUMBER EXPOSED TO THE RISK OF DYING C COL 6 - PROPORTION WHO DIED DURING THE PERIOD C COL 7 - PROPORTION WHO SURVIVED DURING THE PERIOD C COL 8 - SURVIAL RATE C COL 9 - STANDARD ERROR OF THE SURVIVAL RATE C IE- 1, IF K IS NOT IN THE CLOSED INTERVAL (0,N). C 2, IF THE NUMBER OF SUBJECTS ALIVE AT THE BEGINNING C OF PERIOD I IS LESS THAN THE SUM OF THOSE WHICH DIED, C WERE LOST, OR WERE WITHDRAWN DURING PERIOD I (I=1,...N) C 3, IF THE NUMBER OF SUBJECTS WHICH DIED, WERE LOST, OR C WERE WITHDRAWN IN PERIOD I IS NOT EQUAL TO THE NUMBER C ALIVE AT THE BEGINNING OF PERIOD I LESS THE NUMBER C ALIVE AT THE BEGINNING OF PERIOD I + 1 (I=1,...N-1) C C REMARKS C IF THE SUBJECTS IN A GIVEN GROUP ARE ALL DIAGNOSED OR C TREATED AT THE SAME TIME, THE CONSTANT K MAY BE SET EQUAL TO C N . IF THE SUBJECTS IN A GIVEN GOUP ENTER THE STUDY AT C VARYING TIMES, K CAN BE NO GREATER THAN N-1. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO S. J. CUTLER AND F. EDERER 'MAXIMUM UTILIZATION OF C THE LIFE TABLE METHOD IN ANALYZING SURVIVAL', JOURNAL OF C CHRONIC DISEASES, DECEMBER, 1958. PP 699-712. C C .................................................................. C SUBROUTINE SRATE (N,K,X,IE) C DIMENSION X(1) C C INITIALIZATION AND ERROR CHECKING C IE=0 NP4=4*N+1 NP9=NP4+NP4+N-2 DO 1 I=NP4,NP9 1 X(I)=0.0 IF (K) 2,2,3 2 IE=1 GO TO 45 3 IF(K-N) 4,4,2 4 DO 9 I=1,N NP4=I+N NP9=NP4+N NP1=NP9+N IF(INT(X(I)-X(NP4)-X(NP9)-X(NP1)+.01)) 5,6,6 5 IE=2 GO TO 45 6 IF(I-N) 7,9,9 7 IF (INT(X(I+1)-X(I)+X(NP4)+X(NP9)+X(NP1)+.01)) 8,9,8 8 IE=3 GO TO 45 9 CONTINUE 15 L1=0 L2=L1+N L3=L2+N L4=L3+N L5=L4+N L6=L5+N L7=L6+N L8=L7+N L9=L8+N LD=L2 LE=L5 LQ=L6 SUM=0.0 C DO 40 I=1,K C C COMPUTE EFFECTIVE NUMBER EXPOSED TO RISK OF DYING C L1=L1+1 L3=L3+1 L4=L4+1 L5=L5+1 X(L5)=X(L1)-(X(L3)+X(L4))/2.0 C C COMPUTE PROPORTION OF DYING C L2=L2+1 L6=L6+1 X(L6)=X(L2)/X(L5) C C COMPUTE PROPORTION OF SURVIVING C L7=L7+1 X(L7)=1.0-X(L6) C C COMPUTE SURVIVAL RATE C L8=L8+1 IF (I-1) 20, 20, 25 20 X(L8)=X(L7) GO TO 30 25 X(L8)=X(L8-1)*X(L7) C C COMPUTE STANDARD ERROR OF SURVIVAL RATE C 30 L9=L9+1 SUM=SUM+X(L6)/(X(L5)-X(L2)) 40 X(L9)=X(L8)*SQRT(SUM) C 45 RETURN END C C .................................................................. C C SUBROUTINE SRMA C C PURPOSE C MULTIPLY ROW OF MATRIX BY A SCALAR AND ADD TO ANOTHER ROW C OF THE SAME MATRIX C C USAGE C CALL SRMA(A,C,N,M,LA,LB) C C DESCRIPTION OF PARAMETERS C A - NAME OF MATRIX C C - SCALAR C N - NUMBER OF ROWS IN A C M - NUMBER OF COLUMNS IN A C LA - ROW IN A TO BE MULTIPLIED BY SCALAR C LB - ROW IN A TO WHICH PRODUCT IS ADDED C IF 0 IS SPECIFIED, PRODUCT REPLACES ELEMENTS IN ROW LA C C REMARKS C MATRIX A MUST BE A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH ELEMENT OF ROW LA IS MULTIPLIED BY SCALAR C AND THE C PRODUCT IS ADDED TO THE CORRESPONDING ELEMENT OF ROW LB. C ROW LA REMAINS UNAFFECTED BY THE OPERATION. C IF PARAMETER LB CONTAINS ZERO, MULTIPLICATION BY THE SCALAR C IS PERFORMED AND THE PRODUCT REPLACES ELEMENTS IN ROW LA. C C .................................................................. C SUBROUTINE SRMA(A,C,N,M,LA,LB) DIMENSION A(1) C LAJ=LA-N LBJ=LB-N DO 3 J=1,M C C LOCATE ELEMENT IN BOTH ROWS C LAJ=LAJ+N LBJ=LBJ+N C C CHECK LB FOR ZERO C IF(LB) 1,2,1 C C IF NOT, MULTIPLY BY CONSTANT AND ADD TO OTHER ROW C 1 A(LBJ)=A(LAJ)*C+A(LBJ) GO TO 3 C C OTHERWISE, MULTIPLY ROW BY CONSTANT C 2 A(LAJ)=A(LAJ)*C 3 CONTINUE RETURN END C C .................................................................. C C SUBROUTINE SSUB C C PURPOSE C SUBTRACT A SCALAR FROM EACH ELEMENT OF A MATRIX TO FORM A C RESULTANT MATRIX C C USAGE C CALL SSUB(A,C,R,N,M,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C C - SCALAR C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN MATRIX A AND R C M - NUMBER OF COLUMNS IN MATRIX A AND R C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A (AND R) C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C SCALAR IS SUBTRACTED FROM EACH EACH ELEMENT OF MATRIX C C .................................................................. C SUBROUTINE SSUB(A,C,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL LOC(N,M,IT,N,M,MS) C C SUBTRACT SCALAR C DO 1 I=1,IT 1 R(I)=A(I)-C RETURN END C C .................................................................. C C SAMPLE MAIN PROGRAM FOR STEP-WISE MULTIPLE REGRESSION - STEPR C C PURPOSE C (1) READ THE PROBLEM PARAMETER CARD FOR A STEP-WISE MULTIPLE C REGRESSION, (2) READ SUBSET SELECTION CARDS, (3) CALL THE C SUBROUTINE TO CALCULATE MEANS, STANDARD DEVIATIONS, SIMPLE C CORRELATION COEFFICIENTS, AND (4) CALL THE SUBROUTINE TO C PERFORM EACH STEP OF REGRESSION ANALYSIS. C C REMARKS C THE NUMBER OF OBSERVATIONS, N, MUST BE GREATER THAN M+2, C WHERE M IS THE NUMBER OF VARIABLES. IF SELECTION CARDS ARE C NOT PRESENT, THIS PROGRAM CAN NOT PERFORM STEP-WISE MULTIPLE C REGRESSION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C CORRE (WHICH, IN TURN, CALLS THE SUBROUTINE DATA) C MSTR (WHICH, IN TURN, CALLS THE SUBROUTINE LOC) C STPRG (WHICH, IN TURN, CALLS THE SUBROUTINE STOUT) C C METHOD C REFER TO C. A. BENNETT AND N. L. FRANKLIN, 'STATISTICAL C ANALYSIS IN CHEMISTRY AND THE CHEMICAL INDUSTRY', JOHN WILEY C AND SONS, 1954, APPENDIX 6A. C C .................................................................. C C THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE C NUMBER OF VARIABLES, M.. cC c DIMENSION XBAR(35),STD(35),D(35),B(35),T(35),IDX(35),L(35) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC PRODUCT OF M*M.. cC c DIMENSION RX(1225) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE cC (M+1)*M/2.. cC c DIMENSION R(630) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 5.. cC c DIMENSION NSTEP(5) cC cC THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 11.. cC c DIMENSION ANS(11) cC cC .................................................................. cC cC IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE cC C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION cC STATEMENT WHICH FOLLOWS. cC cC DOUBLE PRECISION XBAR,STD,RX,R,B,T,ANS,YEST cC cC THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS cC APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS cC ROUTINE. cC cC .................................................................. cC c1 FORMAT(A4,A2,I5,2I2,F6.0,I1) c2 FORMAT(53H0NUMBER OF SELECTIONS NOT SPECIFIED. JOB TERMINATED.) c3 FORMAT(35H1STEP-WISE MULTIPLE REGRESSION.....A4,A2) c4 FORMAT(31H0VARIABLE MEAN STANDARD/4X,3HN0.16X,9HDEVIATION) c5 FORMAT(4X,I2,F14.5,F12.5) c6 FORMAT(19H1CORRELATION MATRIX) c7 FORMAT(4H0ROWI3/(10F12.5)) c8 FORMAT(72I1) c9 FORMAT(23H0NUMBER OF OBSERVATIONSI5) c10 FORMAT(20H NUMBER OF VARIABLES3X,I5) c11 FORMAT(21H NUMBER OF SELECTIONS2X,I5) c12 FORMAT(28H0CONSTANT TO LIMIT VARIABLESF9.5) c13 FORMAT(/15H1SELECTION.....I2) c14 FORMAT(16X,18HTABLE OF RESIDUALS//9H CASE NO.5X,7HY VALUE5X,10HY E c 1STIMATE6X,8HRESIDUAL) c15 FORMAT(I7,F15.5,2F14.5) c16 FORMAT(1H ) c17 FORMAT(1H1) c18 FORMAT(1H0,'****COLUMN',I4,' OF SELECTION CARD',I5,' IS IN ERROR. c 1 IT IS POSSIBLE THAT COLUMNS SUCCEEDING THAT COLUMN ARE ALSO' c 2/' INCORRECT. THE SELECTION IS IGNORED.****') c19 FORMAT(1H0,'****SELECTION CARD',I5,' DOES NOT NAME ONE AND ONLY ON c 1E DEPENDENT VARIABLE. SELECTION IGNORED.****') c20 FORMAT(1H0,'****EITHER THE MATRIX IS SINGULAR, OR THE RESIDUAL SUM c 1 OF SQUARES IS NEGATIVE IMPLYING EXTREME ILL CONDITION.',/,' SELEC c 2TION IGNORED.****') c21 FORMAT(1H0,'****',I6,' OBSERVATIONS ARE TOO FEW TO ALLOW PARAMETER' c 1 'ESTIMATION FOR',I5,' VARIABLES. JOB TERMINATED.****') cC DOUBLE PRECISION TMPFIL,FILE cC OPEN (UNIT=5, DEVICE='CDR', ACCESS='SEQIN') cC OPEN (UNIT=6, DEVICE='LPT', ACCESS='SEQOUT') cC FILE = TMPFIL('SSP') cC OPEN (UNIT=9, DEVICE='DSK', FILE=FILE, ACCESS='SEQINOUT', cC 1 DISPOSE='DELETE') cC cC READ PROBLEM PARAMETER CARD cC c LOGICAL EOF c CALL CHKEOF (EOF) c100 READ (5,1) PR1,PR2,N,M,NS,PCT,NR c IF (EOF) GOTO 999 cC PR1.....PROBLEM CODE (MAY BE ALPHAMERIC) cC PR2.....PROBLEM CODE (CONTINUED) cC N ......NUMBER OF OBSERVATIONS cC M ......NUMBER OF VARIABLES cC NS......NUMBER OF SELECTIONS cC PCT.....A CONSTANT VALUE OF PROPORTION OF SUM OF SQUARES THAT cC WILL BE USED TO LIMIT VARIABLES ENTERING IN THE REGRES- cC SION cC NR......OPTION CODE FOR TABLE OF RESIDUALS cC 0 - IF IT IS NOT DESIRED cC 1 - IF IT IS DESIRED cC c WRITE (6,3) PR1,PR2 c WRITE (6,9) N c WRITE (6,10) M c IF(N-M-2) 101,101,102 c101 WRITE(6,21) N,M c STOP c102 WRITE (6,11) NS c WRITE (6,12) PCT cC cC LOGICAL TAPE 9 IS USED AS INTERMEDIATE STORAGE TO HOLD INPUT cC DATA. THE INPUT DATA ARE WRITTEN ON LOGICAL TAPE 9 BY THE cC SPECIAL INPUT SUBROUTINE NAMED DATA. THE STORED DATA MAY BE USED cC FOR RESIDUAL ANALYSIS. cC c REWIND 9 cC c IO=0 c X=0.0 cC c CALL CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T) cC c REWIND 9 cC cC PRINT MEANS AND STANDARD DEVIATION cC c WRITE (6,4) c DO 105 I=1,M c105 WRITE (6,5) I,XBAR(I),STD(I) cC cC PRINT CORRELATION MATRIX cC c WRITE (6,6) c DO 130 I=1,M c DO 125 J=1,M c IF(I-J) 110, 120, 120 c110 K=I+(J*J-J)/2 c GO TO 125 c120 K=J+(I*I-I)/2 c125 T(J)=R(K) c130 WRITE (6,7) I,(T(J),J=1,M) cC cC TEST NUMBER OF SELECTIONS cC c IF(NS) 135, 135, 140 c135 WRITE (6,2) c GO TO 200 cC cC SAVE THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS cC c140 CALL MSTR (RX,R,M,0,1) cC c NSEL=1 c GO TO 150 cC cC COPY THE MATRIX OF SUMS OF CROSS-PRODUCTS OF DEVIATIONS cC c145 CALL MSTR (R,RX,M,1,0) cC cC READ A SELECTION CARD cC c150 WRITE (6,13) NSEL c READ (5,8) (IDX(J),J=1,M) cC cC IN EACH POSITION OF IDX, ONE OF THE FOLLOWING CODES MUST BE cC SPECIFIED.. cC 0 OR BLANK - INDEPENDENT VARIABLE AVAILABLE FOR SELECTION cC 1 - INDEPENDENT VARIABLE TO BE FORCED IN REGRESSION cC 2 - VARIABLE TO BE DELETED cC 3 - DEPENDENT VARIABLE cC c N35=0 c DO 155 K=1,M c IF (IDX(K)) 152,153,153 c152 WRITE (6,18) K,NSEL c GO TO 185 c153 IF (IDX(K)-3) 155,154,152 c154 N35=N35+1 c155 CONTINUE c IF (N35-1) 156,157,156 c156 WRITE (6,19) NSEL c GO TO 185 cC CALL THE SUBROUTINE TO PERFORM A STEP-WISE REGRESSION ANALYSIS cC c157 CALL STPRG (M,N,RX,XBAR,IDX,PCT,NSTEP,ANS,L,B,STD,T,D,IER) c IF (IER) 158,159,158 c158 WRITE (6,20) c GO TO 185 cC cC FIND WHETHER TO PRINT THE TABLE OF RESIDUALS cC c159 IF(NR) 185, 185, 160 cC cC PRINT THE TABLE OF RESIDUALS cC cC c160 WRITE (6,13) NSEL c WRITE (6,16) c WRITE (6,14) c MM=NSTEP(1) c DO 180 I=1,N c READ (9) (D(J),J=1,M) c YEST=ANS(9) c K=NSTEP(4) c DO 170 J=1,K c KK=L(J) c170 YEST=YEST+B(J)*D(KK) c RESI=D(MM)-YEST c180 WRITE (6,15) I,D(MM),YEST,RESI c REWIND 9 cC cC TEST TO SEE WHETHER ALL SELECTIONS ARE COMPLETED cC c185 IF(NSEL-NS) 190, 100, 100 c190 NSEL=NSEL+1 c WRITE (6,17) c GO TO 145 cC c200 CONTINUE c999 STOP c END C C .................................................................. C C SAMPLE OUTPUT SUBROUTINE STOUT C C PURPOSE C PRINT THE RESULT OF A STEP-WISE MULTIPLE REGRESSION. THIS C SUBROUTINE IS CALLED BY THE SUBROUTINE STPRG. C C USAGE C CALL STOUT (NSTEP,ANS,L,B,S,T,NSTOP) C C DESCRIPTION OF PARAMETERS C NSTEP - INPUT VECTOR OF LENGTH 5 CONTAINING THE FOLLOWING C INFORMATION.. C NSTEP(1) DEPENDENT VARIABLE C NSTEP(2) NUMBER OF VARIABLES FORCED TO ENTER C IN THE REGRESSION C NSTEP(3) NUMBER OF VARIABLES DELETED C NSTEP(4) THE LAST STEP NUMBER C NSTEP(5) THE LAST VARIABLE ENTERED C ANS - INPUT VECTOR OF LENGTH 11 CONTAINING THE FOLLOWING C INFORMATION FOR THE LAST STEP.. C ANS(1) SUM OF SQUARES REDUCED C ANS(2) PROPORTION REDUCED C ANS(3) CUMULATIVE SUM OF SQUARES REDUCED C ANS(4) CUMULATIVE PROPORTION REDUCED C ANS(5) SUM OF SQUARES OF THE DEPENDENT VARIABLE C ANS(6) MULTIPLE CORRELATION COEFFICIENT C ANS(7) F-VALUE FOR ANALYSIS VARIANCE (FOR THE C REGRESSION) C ANS(8) STANDARD ERROR OF ESTIMATE C ANS(9) INTERCEPT C ANS(10) ADJUSTED MULTIPLE R C ANS(11) ADJUSTED STANDARD ERROR OF ESTIMATE C L - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN- C ING VARIABLES ENTERED IN THE REGRESSION. L(1)=FIRST C VARIABLE ENTERED, L(2)=SECOND VARIABLE ENTERED, ETC. C B - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN- C ING REGRESSION COEFFICIENTS CORRESPONDING TO THE C VARIABLES IN VECTOR L C S - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN- C ING STANDARD ERRORS OF REGRESSION COEFFICIENTS C CORRESPONDING TO THE VARIABLES IN VECTOR L C T - INPUT VECTOR OF LENGTH K (K=M-NSTEP(3)-1) CONTAIN- C ING COMPUTED T-VALUES CORRESPONDING TO THE VARIABLES C IN VECTOR L C NSTOP - OUTPUT OPTION CODE TO STOP THE STEP-WISE REGRESSION C 1 - IF THE STEP-WISE REGRESSION IS TO BE TERMI- C NATED BY SOME CRITERIA OTHER THAN PROPORTION C OF SUM OF SQUARES, SUCH AS F-TEST AND SO ON, C THIS SUBROUTINE MAY BE MODIFIED TO PERFORM C DESIRED TESTS. WHEN IT BECOMES NO LONGER C NECESSARY TO CONTINUE THE STEP-WISE REGRES- C SION, SET NSTOP EQUAL TO 1. C 0 - IF THE STEP-WISE REGRESSION IS TO BE CONTINUED C C REMARKS C THE CONTENTS OF THE VECTORS NSTEP, ANS, L ARE REQUIRED IN C SUBSEQUENT STEPS AND MUST NOT BE DESTROYED. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C C .................................................................. C SUBROUTINE STOUT (NSTEP,ANS,L,B,S,T,NSTOP) C DIMENSION NSTEP(1),ANS(1),L(1),B(1),S(1),T(1) C C .................................................................. C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION ANS,B,S,T C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C .................................................................. C 1 FORMAT(/5H1STEPI3) 2 FORMAT(22H0VARIABLE ENTERED.....I2) 3 FORMAT(40H0SUM OF SQUARES REDUCED IN THIS STEP....F13.3) 4 FORMAT(40H PROPORTION REDUCED IN THIS STEP........F13.3) 5 FORMAT(40H0CUMULATIVE SUM OF SQUARES REDUCED......F13.3) 6 FORMAT(40H CUMULATIVE PROPORTION REDUCED..........F13.3,4H OFF13. 13) 7 FORMAT(4H0FORI3,18H VARIABLES ENTERED) 8 FORMAT(38H MULTIPLE CORRELATION COEFFICIENT...F9.3) 9 FORMAT(38H F-VALUE FOR ANALYSIS OF VARIANCE...F9.3) 10 FORMAT(38H STANDARD ERROR OF ESTIMATE.........F9.3) 11 FORMAT(/57H VARIABLE REGRESSION STD. ERROR OF COMPUT 1ED/56H NUMBER COEFFICIENT REG. COEFF. T-VALUE) 12 FORMAT(5X,I3,F18.5,F16.5,F14.3) 13 FORMAT(12H INTERCEPTF14.5) 14 FORMAT(31H0DEPENDENT VARIABLE............I2) 15 FORMAT(31H NUMBER OF VARIABLES FORCED....I2) 16 FORMAT(31H NUMBER OF VARIABLES DELETED...I2) 17 FORMAT(20H (FORCED VARIABLE)) 18 FORMAT(38H (ADJUSTED FOR D.F.)...........F9.3) C C TEST WHETHER THIS IS THE FIRST STEP C IF(NSTEP(4)-1) 30, 30, 35 30 WRITE (6,14) NSTEP(1) WRITE (6,15) NSTEP(2) WRITE (6,16) NSTEP(3) C C PRINT THE RESULT OF A STEP C 35 WRITE (6,1) NSTEP(4) WRITE (6,2) NSTEP(5) IF(NSTEP(4)-NSTEP(2)) 37, 37, 38 37 WRITE (6,17) 38 WRITE (6,3) ANS(1) WRITE (6,4) ANS(2) WRITE (6,5) ANS(3) WRITE (6,6) ANS(4), ANS(5) WRITE (6,7) NSTEP(4) WRITE (6,8) ANS(6) WRITE(6,18)ANS(10) WRITE (6,9) ANS(7) WRITE (6,10) ANS(8) WRITE(6,18)ANS(11) WRITE (6,11) N=NSTEP(4) DO 40 I=1,N 40 WRITE (6,12) L(I),B(I),S(I),T(I) WRITE (6,13) ANS(9) C NSTOP=0 RETURN END C C .................................................................. C C SUBROUTINE STPRG C C PURPOSE C TO PERFORM A STEPWISE MULTIPLE REGRESSION ANALYSIS FOR A C DEPENDENT VARIABLE AND A SET OF INDEPENDENT VARIABLES. AT C EACH STEP, THE VARIABLE ENTERED INTO THE REGRESSION EQUATION C IS THAT WHICH EXPLAINS THE GREATEST AMOUNT OF VARIANCE C BETWEEN IT AND THE DEPENDENT VARIABLE (I.E. THE VARIABLE C WITH THE HIGHEST PARTIAL CORRELATION WITH THE DEPENDENT C VARIABLE). ANY VARIABLE CAN BE DESIGNATED AS THE DEPENDENT C VARIABLE. ANY INDEPENDENT VARIABLE CAN BE FORCED INTO OR C DELETED FROM THE REGRESSION EQUATION, IRRESPECTIVE OF ITS C CONTRIBUTION TO THE EQUATION. C C USAGE C CALL STPRG (M,N,D,XBAR,IDX,PCT,NSTEP,ANS,L,B,S,T,LL,IER) C C DESCRIPTION OF PARAMETERS C M - TOTAL NUMBER OF VARIABLES IN DATA MATRIX C N - NUMBER OF OBSERVATIONS C D - INPUT MATRIX (M X M) OF SUMS OF CROSS-PRODUCTS OF C DEVIATIONS FROM MEAN. THIS MATRIX WILL BE DESTROYED. C XBAR - INPUT VECTOR OF LENGTH M OF MEANS C IDX - INPUT VECTOR OF LENGTH M HAVING ONE OF THE FOLLOWING C CODES FOR EACH VARIABLE. C 0 - INDEPENDENT VARIABLE AVAILABLE FOR SELECTION C 1 - INDEPENDENT VARIABLE TO BE FORCED INTO THE C REGRESSION EQUATION C 2 - VARIABLE NOT TO BE CONSIDERED IN THE EQUATION C 3 - DEPENDENT VARIABLE C THIS VECTOR WILL BE DESTROYED C PCT - A CONSTANT VALUE INDICATING THE PROPORTION OF THE C TOTAL VARIANCE TO BE EXPLAINED BY ANY INDEPENDENT C VARIABLE. THOSE INDEPENDENT VARIABLES WHICH FALL C BELOW THIS PROPORTION WILL NOT ENTER THE REGRESSION C EQUATION. TO ENSURE THAT ALL VARIABLES ENTER THE C EQUATION, SET PCT = 0.0. C NSTEP- OUTPUT VECTOR OF LENGTH 5 CONTAINING THE FOLLOWING C INFORMATION C NSTEP(1)- THE NUMBER OF THE DEPENDENT VARIABLE C NSTEP(2)- NUMBER OF VARIABLES FORCED INTO THE C REGRESSION EQUATION C NSTEP(3)- NUMBER OF VARIABLE DELETED FROM THE C EQUATION C NSTEP(4)- THE NUMBER OF THE LAST STEP C NSTEP(5)- THE NUMBER OF THE LAST VARIABLE ENTERED C ANS - OUTPUT VECTOR OF LENGTH 11 CONTAINING THE FOLLOWING C INFORMATION FOR THE LAST STEP C ANS(1)- SUM OF SQUARES REDUCED BY THIS STEP C ANS(2)- PROPORTION OF TOTAL SUM OF SQUARES REDUCED C ANS(3)- CUMULATIVE SUM OF SQUARES REDUCED UP TO C THIS STEP C ANS(4)- CUMULATIVE PROPORTION OF TOTAL SUM OF C SQUARES REDUCED C ANS(5)- SUM OF SQUARES OF THE DEPENDENT VARIABLE C ANS(6)- MULTIPLE CORRELATION COEFFICIENT C ANS(7)- F RATIO FOR SUM OF SQUARES DUE TO C REGRESSION C ANS(8)- STANDARD ERROR OF THE ESTIMATE (RESIDUAL C MEAN SQUARE) C ANS(9)- INTERCEPT CONSTANT C ANS(10)-MULTIPLE CORRELATION COEFFICIENT ADJUSTED C FOR DEGREES OF FREEDOM. C ANS(11)-STANDARD ERROR OF THE ESTIMATE ADJUSTED C FOR DEGREES OF FREEDOM. C L - OUTPUT VECTOR OF LENGTH K, WHERE K IS THE NUMBER OF C INDEPENDENT VARIABLES IN THE REGRESSION EQUATION. C THIS VECTOR CONTAINS THE NUMBERS OF THE INDEPENDENT C VARIABLES IN THE EQUATION. C B - OUTPUT VECTOR OF LENGTH K, CONTAINING THE PARTIAL C REGRESSION COEFFICIENTS CORRESPONDING TO THE C VARIABLES IN VECTOR L. C S - OUTPUT VECTOR OF LENGTH K, CONTAINING THE STANDARD C ERRORS OF THE PARTIAL REGRESSION COEFFICIENTS, C CORRESPONDING TO THE VARIABLES IN VECTOR L. C T - OUTPUT VECTOR OF LENGTH K, CONTAINING THE COMPUTED C T-VALUES CORRESPONDING TO THE VARIABLES IN VECTOR L. C LL - WORKING VECTOR OF LENGTH M C IER - 0, IF THERE IS NO ERROR. C 1, IF RESIDUAL SUM OF SQUARES IS NEGATIVE OR IF THE C PIVOTAL ELEMENT IN THE STEPWISE INVERSION PROCESS IS C ZERO. IN THIS CASE, THE VARIABLE WHICH CAUSES THIS C ERROR IS NOT ENTERED IN THE REGRESSION, THE RESULT C PRIOR TO THIS STEP IS RETAINED, AND THE CURRENT C SELECTION IS TERMINATED. C C REMARKS C THE NUMBER OF DATA POINTS MUST BE AT LEAST GREATER THAN THE C NUMBER OF INDEPENDENT VARIABLES PLUS ONE. FORCED VARIABLES C ARE ENTERED INTO THE REGRESSION EQUATION BEFORE ALL OTHER C INDEPENDENT VARIABLES. WITHIN THE SET OF FORCED VARIABLES, C THE ONE TO BE CHOSEN FIRST WILL BE THAT ONE WHICH EXPLAINS C THE GREATEST AMOUNT OF VARIANCE. C INSTEAD OF USING, AS A STOPPING CRITERION, A PROPORTION OF C THE TOTAL VARIANCE, SOME OTHER CRITERION MAY BE ADDED TO C SUBROUTINE STOUT. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C STOUT(NSTEP,ANS,L,B,S,T,NSTOP) C THIS SUBROUTINE MUST BE PROVIDED BY THE USER. IT IS AN C OUTPUT ROUTINE WHICH WILL PRINT THE RESULTS OF EACH STEP OF C THE REGRESSION ANALYSIS. NSTOP IS AN OPTION CODE WHICH IS C ONE IF THE STEPWISE REGRESSION IS TO BE TERMINATED, AND IS C ZERO IF IT IS TO CONTINUE. THE USER MUST CONSIDER THIS IF C SOME OTHER STOPPING CRITERION THAN VARIANCE PROPORTION IS TO C BE USED. C C METHOD C THE ABBREVIATED DOOLITTLE METHOD IS USED TO (1) DECIDE VARI- C ABLES ENTERING IN THE REGRESSION AND (2) COMPUTE REGRESSION C COEFFICIENTS. REFER TO C. A. BENNETT AND N. L. FRANKLIN, C 'STATISTICAL ANALYSIS IN CHEMISTRY AND THE CHEMICAL INDUS- C TRY', JOHN WILEY AND SONS, 1954, APPENDIX 6A. C C .................................................................. C SUBROUTINE STPRG (M,N,D,XBAR,IDX,PCT,NSTEP,ANS,L,B,S,T,LL,IER) C DIMENSION D(1),XBAR(1),IDX(1),NSTEP(1),ANS(1),L(1),B(1),S(1),T(1), 1LL(1) C C .................................................................. C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION D,XBAR,ANS,B,S,T,RD,RE C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS C 85,90,114,132,AND 134, MUST BE CHANGED TO DSQRT. C C .................................................................. C C INITIALIZATION C IER=0 ONM=N-1 NFO=0 NSTEP(3)=0 ANS(3)=0.0 ANS(4)=0.0 NSTOP=0 C C FIND DEPENDENT VARIABLE, NUMBER OF VARIABLES TO BE FORCED TO C ENTER IN THE REGRESSION, AND NUMBER OF VARIABLES TO BE DELETED C DO 30 I=1,M LL(I)=1 IF(IDX(I)) 30, 30, 10 10 IF(IDX(I)-2) 15, 20, 25 15 NFO=NFO+1 IDX(NFO)=I GO TO 30 20 NSTEP(3)=NSTEP(3)+1 LL(I)=-1 GO TO 30 25 MY=I NSTEP(1)=MY LY=M*(MY-1) LYP=LY+MY ANS(5)=D(LYP) 30 CONTINUE NSTEP(2)=NFO C C FIND THE MAXIMUM NUMBER OF STEPS C MX=M-NSTEP(3)-1 C C START SELECTION OF VARIABLES C DO 140 NL=1,MX RD=0 IF(NL-NFO) 35, 35, 55 C C SELECT NEXT VARIABLE TO ENTER AMONG FORCED VARIABLES C 35 DO 50 I=1,NFO K=IDX(I) IF(LL(K)) 50, 50, 40 40 LYP=LY+K IP=M*(K-1)+K RE=D(LYP)*D(LYP)/D(IP) IF(RD-RE) 45, 50, 50 45 RD=RE NEW=K 50 CONTINUE GO TO 75 C C SELECT NEXT VARIABLE TO ENTER AMONG NON-FORCED VARIABLES C 55 DO 70 I=1,M IF(I-MY) 60, 70, 60 60 IF(LL(I)) 70, 70, 62 62 LYP=LY+I IP=M*(I-1)+I RE=D(LYP)*D(LYP)/D(IP) IF(RD-RE) 64, 70, 70 64 RD=RE NEW=I 70 CONTINUE C C TEST WHETHER THE PROPORTION OF THE SUM OF SQUARES REDUCED BY C THE LAST VARIABLE ENTERED IS GREATER THAN OR EQUAL TO THE C SPECIFIED PROPORTION C 75 IF(RD) 77,77,76 76 IF(ANS(5)-(ANS(3)+RD))77,77,78 77 IER=1 GO TO 150 78 RE=RD/ANS(5) IF(RE-PCT) 150, 80, 80 C C IT IS GREATER THAN OR EQUAL C 80 LL(NEW)=0 L(NL)=NEW ANS(1)=RD ANS(2)=RE ANS(3)=ANS(3)+RD ANS(4)=ANS(4)+RE NSTEP(4)=NL NSTEP(5)=NEW C C COMPUTE MULTIPLE CORRELATION, F-VALUE FOR ANALYSIS OF C VARIANCE, AND STANDARD ERROR OF ESTIMATE C 85 ANS(6)= SQRT(ANS(4)) RD=NL RE=ONM-RD RE=(ANS(5)-ANS(3))/RE ANS(7)=(ANS(3)/RD)/RE 90 ANS(8)= SQRT(RE) C C DIVIDE BY THE PIVOTAL ELEMENT C IP=M*(NEW-1)+NEW RD=D(IP) LYP=NEW-M DO 100 J=1,M LYP=LYP+M IF(LL(J)) 100, 94, 97 94 IF(J-NEW) 96, 98, 96 96 IJ=M*(J-1)+J D(IJ)=D(IJ)+D(LYP)*D(LYP)/RD 97 D(LYP)=D(LYP)/RD GO TO 100 98 D(IP)=1.0/RD 100 CONTINUE C C COMPUTE REGRESSION COEFFICIENTS C LYP=LY+NEW B(NL)=D(LYP) IF(NL-1) 112, 112, 105 105 ID=NL-1 DO 110 J=1,ID IJ=NL-J KK=L(IJ) LYP=LY+KK B(IJ)=D(LYP) DO 110 K=1,J IK=NL-K+1 MK=L(IK) LYP=M*(MK-1)+KK 110 B(IJ)=B(IJ)-D(LYP)*B(IK) C C COMPUTE INTERCEPT C 112 ANS(9)=XBAR(MY) DO 115 I=1,NL KK=L(I) ANS(9)=ANS(9)-B(I)*XBAR(KK) IJ=M*(KK-1)+KK 114 S(I)=ANS(8)* SQRT(D(IJ)) 115 T(I)=B(I)/S(I) C C PERFORM A REDUCTION TO ELIMINATE THE LAST VARIABLE ENTERED C IP=M*(NEW-1) DO 130 I=1,M IJ=I-M IK=NEW-M IP=IP+1 IF(LL(I)) 130, 130, 120 120 DO 126 J=1,M IJ=IJ+M IK=IK+M IF(LL(J)) 126, 122, 122 122 IF(J-NEW) 124, 126, 124 124 D(IJ)=D(IJ)-D(IP)*D(IK) 126 CONTINUE D(IP)=D(IP)/(-RD) 130 CONTINUE C C ADJUST STANDARD ERROR OF THE ESTIMATE AND MULTIPLE CORRELATION C COEFFICIENT C RD=N-NSTEP(4) RD=ONM/RD 132 ANS(10)=SQRT(1.0-(1.0-ANS(6)*ANS(6))*RD) 134 ANS(11)=ANS(8)*SQRT(RD) C C CALL THE OUTPUT SUBROUTINE CALL STOUT (NSTEP,ANS,L,B,S,T,NSTOP) C C TEST WHETHER THE STEP-WISE REGRESSION WAS TERMINATED IN C SUBROUTINE STOUT C IF(NSTOP) 140, 140, 150 C 140 CONTINUE C 150 RETURN END C C .................................................................. C C SUBROUTINE SUBMX C C PURPOSE C BASED ON VECTOR S DERIVED FROM SUBROUTINE SUBST OR ABSNT, C THIS SUBROUTINE COPIES FROM A LARGER MATRIX OF OBSERVATION C DATA A SUBSET MATRIX OF THOSE OBSERVATIONS WHICH HAVE C SATISFIED CERTAIN CONDITION. THIS SUBROUTINE IS NORMALLY C USED PRIOR TO STATISTICAL ANALYSES (E.G., MULTIPLE REGRES- C SION, FACTOR ANALYSIS). C C USAGE C CALL SUBMX (A,D,S,NO,NV,N) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX OF OBSERVATIONS, NO BY NV. C D - OUTPUT MATRIX OF OBSERVATIONS, N BY NV. C S - INPUT VECTOR OF LENGTH NO CONTAINING THE CODES DERIVED C FROM SUBROUTINE SUBST OR ABSNT. C NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1. C NV - NUMBER OF VARIABLES. NV MUST BE > OR = TO 1. C N - OUTPUT VARIABLE CONTAINING THE NUMBER OF NON-ZERO CODES C IN VECTOR S. C C REMARKS C MATRIX D CAN BE IN THE SAME LOCATION AS MATRIX A. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C IF S(I) CONTAINS A NON-ZERO CODE, I-TH OBSERVATION IS C COPIED FROM THE INPUT MATRIX TO THE OUTPUT MATRIX. C C .................................................................. C SUBROUTINE SUBMX (A,D,S,NO,NV,N) DIMENSION A(1),D(1),S(1) C L=0 LL=0 DO 20 J=1,NV DO 15 I=1,NO L=L+1 IF(S(I)) 15, 15, 10 10 LL=LL+1 D(LL)=A(L) 15 CONTINUE 20 CONTINUE C C COUNT NON-ZERO CODES IN VECTOR S C N=0 DO 30 I=1,NO IF(S(I)) 30, 30, 25 25 N=N+1 30 CONTINUE C RETURN END C C .................................................................. C C SUBROUTINE SUBST C C PURPOSE C DERIVE A SUBSET VECTOR INDICATING WHICH OBSERVATIONS IN A C SET HAVE SATISFIED CERTAIN CONDITIONS ON THE VARIABLES. C C USAGE C CALL SUBST (A,C,R,B,S,NO,NV,NC) C PARAMETER B MUST BE DEFINED BY AN EXTERNAL STATEMENT IN THE C CALLING PROGRAM C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C C - INPUT MATRIX, 3 BY NC, OF CONDITIONS TO BE CONSIDERED. C THE FIRST ELEMENT OF EACH COLUMN OF C REPRESENTS THE C NUMBER OF THE VARIABLE (COLUMN OF THE MATRIX A) TO BE C TESTED, THE SECOND ELEMENT OF EACH COLUMN IS A C RELATIONAL CODE AS FOLLOWS C 1. FOR LT (LESS THAN) C 2. FOR LE (LESS THAN OR EQUAL TO) C 3. FOR EQ (EQUAL TO) C 4. FOR NE (NOT EQUAL TO) C 5. FOR GE (GREATER THAN OR EQUAL TO) C 6. FOR GT (GREATER THAN) C THE THIRD ELEMENT OF EACH COLUMN IS A QUANTITY TO BE C USED FOR COMPARISON WITH THE OBSERVATION VALUES. FOR C EXAMPLE, THE FOLLOWING COLUMN IN C C 2. C 5. C 92.5 C CAUSES THE SECOND VARIABLE TO BE TESTED FOR GREATER C THAN OR EQUAL TO 92.5 C R - WORKING VECTOR USED TO STORE INTERMEDIATE RESULTS OF C ABOVE TESTS ON A SINGLE OBSERVATION. IF CONDITION IS C SATISFIED, R(I) IS SET TO 1. IF IT IS NOT, R(I) IS SET C TO 0. VECTOR LENGTH IS NC. C B - NAME OF SUBROUTINE TO BE SUPPLIED BY THE USER. IT C CONSISTS OF A BOOLEAN EXPRESSION LINKING THE C INTERMEDIATE VALUES STORED IN VECTOR R. THE BOOLEAN C OPERATORS ARE '*' FOR'AND', '+' FOR 'OR'. EXAMPLE C SUBROUTINE BOOL(R,T) C DIMENSION R(3) C T=R(1)*(R(2)+R(3)) C RETURN C END C THE ABOVE EXPRESSION IS TESTED FOR C R(1).AND.(R(2).OR.R(3)) C S - OUTPUT VECTOR INDICATING, FOR EACH OBSERVATION, C WHETHER OR NOT PROPOSITION B IS SATISFIED. IF IT IS, C S(I) IS NON-ZERO. IF IT IS NOT, S(I) IS ZERO. VECTOR C LENGTH IS NO. C NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1. C NV - NUMBER OF VARIABLES. NV MUST BE > OR = TO 1. C NC - NUMBER OF BASIC CONDITIONS TO BE SATISFIED. NC MUST BE C GREATER THAN OR EQUAL TO 1. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C B THE NAME OF ACTUAL SUBROUTINE SUPPLIED BY THE USER MAY C BE DIFFERENT (E.G., BOOL), BUT SUBROUTINE SUBST ALWAYS C CALLS IT AS B. IN ORDER FOR SUBROUTINE SUBST TO DO THIS, C THE NAME OF THE USER-SUPPLIED SUBROUTINE MUST BE C DEFINED BY AN EXTERNAL STATEMENT IN THE CALLING PROGRAM. C THE NAME MUST ALSO BE LISTED IN THE ''CALL SUBST'' C STATEMENT. (SEE USAGE ABOVE) C C METHOD C THE FOLLOWING IS DONE FOR EACH OBSERVATION. C CONDITION MATRIX IS ANALYZED TO DETERMINE WHICH VARIABLES C ARE TO BE EXAMINED. INTERMEDIATE VECTOR R IS FORMED. THE C BOOLEAN EXPRESSION (IN SUBROUTINE B) IS THEN EVALUATED TO C DERIVE THE ELEMENT IN SUBSET VECTOR S CORRESPONDING TO THE C OBSERVATION. C C .................................................................. C SUBROUTINE SUBST(A,C,R,B,S,NO,NV,NC) DIMENSION A(1),C(1),R(1),S(1) C DO 9 I=1,NO IQ=I-NO K=-2 DO 8 J=1,NC C C CLEAR R VECTOR C R(J)=0.0 C C LOCATE ELEMENT IN OBSERVATION MATRIX AND RELATIONAL CODE C K=K+3 IZ=C(K) IA=IQ+IZ*NO IGO=C(K+1) C C FORM R VECTOR C Q=A(IA)-C(K+2) GO TO(1,2,3,4,5,6),IGO 1 IF(Q) 7,8,8 2 IF(Q) 7,7,8 3 IF(Q) 8,7,8 4 IF(Q) 7,8,7 5 IF(Q) 8,7,7 6 IF(Q) 8,8,7 7 R(J)=1.0 8 CONTINUE C C CALCULATE S VECTOR C 9 CALL B(R,S(I)) RETURN END C C .................................................................. C C SUBROUTINE TAB1 C C PURPOSE C TABULATE FOR ONE VARIABLE IN AN OBSERVATION MATRIX (OR A C MATRIX SUBSET), THE FREQUENCY AND PERCENT FREQUENCY OVER C GIVEN CLASS INTERVALS. IN ADDITION, CALCULATE FOR THE SAME C VARIABLE THE TOTAL, AVERAGE, STANDARD DEVIATION, MINIMUM, C AND MAXIMUM. C C USAGE C CALL TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV) C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C S - INPUT VECTOR GIVING SUBSET OF A. ONLY THOSE C OBSERVATIONS WITH A CORRESPONDING NON-ZERO S(J) ARE C CONSIDERED. VECTOR LENGTH IS NO. C NOVAR - THE VARIABLE TO BE TABULATED. NOVAR MUST BE GREATER C THAN OR EQUAL TO 1 AND LESS THAN OR EQUAL TO NV. C AND UPPER LIMIT OF VARIABLE TO BE TABULATED C IN UBO(1), UBO(2) AND UBO(3) RESPECTIVELY. IF C LOWER LIMIT IS EQUAL TO UPPER LIMIT, THE PROGRAM C USES THE MINIMUM AND MAXIMUM VALUES OF THE VARIABLE. C NUMBER OF INTERVALS, UBO(2), MUST INCLUDE TWO CELLS C FOR VALUES UNDER AND ABOVE LIMITS. VECTOR LENGTH C IS 3. C FREQ - OUTPUT VECTOR OF FREQUENCIES. VECTOR LENGTH IS C UBO(2). C PCT - OUTPUT VECTOR OF RELATIVE FREQUENCIES. VECTOR C LENGTH IS UBO(2). C STATS - OUTPUT VECTOR OF SUMMARY STATISTICS, I.E., TOTAL, C AVERAGE, STANDARD DEVIATION, MINIMUM AND MAXIMUM. C VECTOR LENGTH IS 5. IF S IS NULL, THEN TOTAL,AVERAGE C AND STANDARD DEVIATION = 0, MIN=1.E75 AND MAX=-1.E75 C NO - NUMBER OF OBSERVATIONS. NO MUST BE > OR = TO 1 C NV - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV MUST C BE GREATER THAN OR EQUAL TO 1. C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE INTERVAL SIZE IS CALCULATED FROM THE GIVEN INFORMATION C OR OPTIONALLY FROM THE MINIMUM AND MAXIMUM VALUES FOR C VARIABLE NOVAR. THE FREQUENCIES AND PERCENT FREQUENCIES ARE C THEN CALCULATED ALONG WITH SUMMARY STATISTICS. C THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS THAN THE C NUMBER OF OBSERVATIONS USED. C C .................................................................. C SUBROUTINE TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV) DIMENSION A(1),S(1),UBO(1),FREQ(1),PCT(1),STATS(1) DIMENSION WBO(3) DO 5 I=1,3 5 WBO(I)=UBO(I) C C CALCULATE MIN AND MAX C VMIN=1.7E38 VMAX=-1.7E38 IJ=NO*(NOVAR-1) DO 30 J=1,NO IJ=IJ+1 IF(S(J)) 10,30,10 10 IF(A(IJ)-VMIN) 15,20,20 15 VMIN=A(IJ) 20 IF(A(IJ)-VMAX) 30,30,25 25 VMAX=A(IJ) 30 CONTINUE STATS(4)=VMIN STATS(5)=VMAX C C DETERMINE LIMITS C IF(UBO(1)-UBO(3)) 40,35,40 35 UBO(1)=VMIN UBO(3)=VMAX 40 INN=UBO(2) C C CLEAR OUTPUT AREAS C DO 45 I=1,INN FREQ(I)=0.0 45 PCT(I)=0.0 DO 50 I=1,3 50 STATS(I)=0.0 C C CALCULATE INTERVAL SIZE C SINT=ABS((UBO(3)-UBO(1))/(UBO(2)-2.0)) C C TEST SUBSET VECTOR C SCNT=0.0 IJ=NO*(NOVAR-1) DO 75 J=1,NO IJ=IJ+1 IF(S(J)) 55,75,55 55 SCNT=SCNT+1.0 C C DEVELOP TOTAL AND FREQUENCIES C STATS(1)=STATS(1)+A(IJ) STATS(3)=STATS(3)+A(IJ)*A(IJ) TEMP=UBO(1)-SINT INTX=INN-1 DO 60 I=1,INTX TEMP=TEMP+SINT IF(A(IJ)-TEMP) 70,60,60 60 CONTINUE IF(A(IJ)-TEMP) 75,65,65 65 FREQ(INN)=FREQ(INN)+1.0 GO TO 75 70 FREQ(I)=FREQ(I)+1.0 75 CONTINUE IF (SCNT)79,105,79 C C CALCULATE RELATIVE FREQUENCIES C 79 DO 80 I=1,INN 80 PCT(I)=FREQ(I)*100.0/SCNT C C CALCULATE MEAN AND STANDARD DEVIATION C IF(SCNT-1.0) 85,85,90 85 STATS(2)=STATS(1) STATS(3)=0.0 GO TO 95 90 STATS(2)=STATS(1)/SCNT STATS(3)=SQRT(ABS((STATS(3)-STATS(1)*STATS(1)/SCNT)/(SCNT-1.0))) 95 DO 100 I=1,3 100 UBO(I)=WBO(I) 105 RETURN END C C .................................................................. C C SUBROUTINE TAB2 C C PURPOSE C PERFORM A TWO-WAY CLASSIFICATION FOR TWO VARIABLES IN AN C OBSERVATION MATRIX (OR A MATRIX SUBSET) OF THE FREQUENCY, C PERCENT FREQUENCY, AND OTHER STATISTICS OVER GIVEN CLASS C INTERVALS. C C USAGE C CALL TAB2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO,NV) C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C S - INPUT VECTOR GIVING SUBSET OF A. ONLY THOSE C OBSERVATIONS WITH A CORRESPONDING NON-ZERO S(J) ARE C CONSIDERED. VECTOR LENGTH IS NO. C NOV - VARIABLES TO BE CROSS-TABULATED. NOV(1) IS VARIABLE C 1, NOV(2) IS VARIABLE 2. VECTOR LENGTH IS 2. NOV C MUST BE GREATER THAN OR EQUAL TO 1 AND LESS THAN C OR EQUAL TO NV. C UBO - 3 BY 2 MATRIX GIVING LOWER LIMIT, NUMBER OF C INTERVALS, AND UPPER LIMIT OF BOTH VARIABLES TO BE C TABULATED (FIRST COLUMN FOR VARIABLE 1, SECOND C COLUMN FOR VARIABLE 2). IF LOWER LIMIT IS EQUAL TO C UPPER LIMIT FOR VARIABLE 1, THE PROGRAM USES THE C MINIMUM AND MAXIMUM VALUES ON EACH VARIABLE. NUMBER C OF INTERVALS MUST INCLUDE TWO CELLS FOR UNDER AND C ABOVE LIMITS. C FREQ - OUTPUT MATRIX OF FREQUENCIES IN THE TWO-WAY C CLASSIFICATION. ORDER OF MATRIX IS INT1 BY INT2, C WHERE INT1 IS THE NUMBER OF INTERVALS OF VARIABLE 1 C AND INT2 IS THE NUMBER OF INTERVALS OF VARIABLE 2. C INT1 AND INT2 MUST BE SPECIFIED IN THE SECOND C POSITION OF RESPECTIVE COLUMN OF UBO MATRIX. C PCT - OUTPUT MATRIX OF PERCENT FREQUENCIES, SAME ORDER C AS FREQ. C STAT1 - OUTPUT MATRIX SUMMARIZING TOTALS, MEANS, AND C STANDARD DEVIATIONS FOR EACH CLASS INTERVAL OF C VARIABLE 1. ORDER OF MATRIX IS 3 BY INT1. C STAT2 - SAME AS STAT1 BUT OVER VARIABLE 2. ORDER OF MATRIX C IS 3 BY INT2. C NO - NUMBER OF OBSERVATIONS. NO MUST BE GREATER THAN C OR EQUAL TO 1. C NV - NUMBER OF VARIABLES FOR EACH OBSERVATION. NV C MUST BE GREATER THAN OR EQUAL TO 1. C C REMARKS C IF S IS NULL, OUTPUT AREAS ARE SET TO ZERO C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C INTERVAL SIZES FOR BOTH VARIABLES ARE CALCULATED FROM THE C GIVEN INFORMATION OR OPTIONALLY FROM THE MINIMUM AND MAXIMUM C VALUES. THE FREQUENCY AND PERCENT FREQUENCY MATRICES ARE C DEVELOPED. MATRICES STAT1 AND STAT2 SUMMARIZING TOTALS, C MEANS, AND STANDARD DEVIATIONS ARE THEN CALCULATED. C THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS THAN THE C NUMBER OF OBSERVATIONS USED IN EACH CLASS INTERVAL. C C .................................................................. C SUBROUTINE TAB2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO,NV) DIMENSION A(1),S(1),NOV(2),UBO(3,2),FREQ(1),PCT(1),STAT1(1), 1STAT2(2),SINT(2) DIMENSION WBO(3,2) DO 5 I=1,3 DO 5 J=1,2 5 WBO(I,J)=UBO(I,J) C C DETERMINE LIMITS C DO 40 I=1,2 IF(UBO(1,I)-UBO(3,I)) 40, 10, 40 10 VMIN=1.7E38 VMAX=-1.7E38 IJ=NO*(NOV(I)-1) DO 35 J=1,NO IJ=IJ+1 IF(S(J)) 15,35,15 15 IF(A(IJ)-VMIN) 20,25,25 20 VMIN=A(IJ) 25 IF(A(IJ)-VMAX) 35,35,30 30 VMAX=A(IJ) 35 CONTINUE UBO(1,I)=VMIN UBO(3,I)=VMAX 40 CONTINUE C C CALCULATE INTERVAL SIZE C 45 DO 50 I=1,2 50 SINT(I)=ABS((UBO(3,I)-UBO(1,I))/(UBO(2,I)-2.0)) C C CLEAR OUTPUT AREAS C INT1=UBO(2,1) INT2=UBO(2,2) INTT=INT1*INT2 DO 55 I=1,INTT FREQ(I)=0.0 55 PCT(I)=0.0 INTY=3*INT1 DO 60 I=1,INTY 60 STAT1(I)=0.0 INTZ=3*INT2 DO 65 I=1,INTZ 65 STAT2(I)=0.0 C C TEST SUBSET VECTOR C SCNT=0.0 INTY=INT1-1 INTX=INT2-1 IJ=NO*(NOV(1)-1) IJX=NO*(NOV(2)-1) DO 95 J=1,NO IJ=IJ+1 IJX=IJX+1 IF(S(J)) 70,95,70 70 SCNT=SCNT+1.0 C C CALCULATE FREQUENCIES C TEMP1=UBO(1,1)-SINT(1) DO 75 IY=1,INTY TEMP1=TEMP1+SINT(1) IF(A(IJ)-TEMP1) 80,75,75 75 CONTINUE IY=INT1 80 IYY=3*(IY-1)+1 STAT1(IYY)=STAT1(IYY)+A(IJ) IYY=IYY+1 STAT1(IYY)=STAT1(IYY)+1.0 IYY=IYY+1 STAT1(IYY)=STAT1(IYY)+A(IJ)*A(IJ) TEMP2=UBO(1,2)-SINT(2) DO 85 IX=1,INTX TEMP2=TEMP2+SINT(2) IF(A(IJX)-TEMP2) 90,85,85 85 CONTINUE IX=INT2 90 IJF=INT1*(IX-1)+IY FREQ(IJF)=FREQ(IJF)+1.0 IX=3*(IX-1)+1 STAT2(IX)=STAT2(IX)+A(IJX) IX=IX+1 STAT2(IX)=STAT2(IX)+1.0 IX=IX+1 STAT2(IX)=STAT2(IX)+A(IJX)*A(IJX) 95 CONTINUE IF (SCNT)98,151,98 C C CALCULATE PERCENT FREQUENCIES C 98 DO 100 I=1,INTT 100 PCT(I)=FREQ(I)*100.0/SCNT C C CALCULATE TOTALS, MEANS, STANDARD DEVIATIONS C IXY=-1 DO 120 I=1,INT1 IXY=IXY+3 ISD=IXY+1 TEMP1=STAT1(IXY) SUM=STAT1(IXY-1) IF(TEMP1-1.0) 120,105,110 105 STAT1(ISD)=0.0 GO TO 115 110 STAT1(ISD)=SQRT(ABS((STAT1(ISD)-SUM*SUM/TEMP1)/(TEMP1-1.0))) 115 STAT1(IXY)=SUM/TEMP1 120 CONTINUE IXX=-1 DO 140 I=1,INT2 IXX=IXX+3 ISD=IXX+1 TEMP2=STAT2(IXX) SUM=STAT2(IXX-1) IF(TEMP2-1.0) 140,125,130 125 STAT2(ISD)=0.0 GO TO 135 130 STAT2(ISD)=SQRT(ABS((STAT2(ISD)-SUM*SUM/TEMP2)/(TEMP2-1.0))) 135 STAT2(IXX)=SUM/TEMP2 140 CONTINUE DO 150 I=1,3 DO 150 J=1,2 150 UBO(I,J)=WBO(I,J) 151 RETURN END C C .................................................................. C C SUBROUTINE TALLY C C PURPOSE C CALCULATE TOTAL, MEAN, STANDARD DEVIATION, MINIMUM, MAXIMUM C FOR EACH VARIABLE IN A SET (OR A SUBSET) OF OBSERVATIONS C C USAGE C CALL TALLY(A,S,TOTAL,AVER,SD,VMIN,VMAX,NO,NV,IER) C C DESCRIPTION OF PARAMETERS C A - OBSERVATION MATRIX, NO BY NV C S - INPUT VECTOR INDICATING SUBSET OF A. ONLY THOSE C OBSERVATIONS WITH A NON-ZERO S(J) ARE CONSIDERED. C VECTOR LENGTH IS NO. C TOTAL - OUTPUT VECTOR OF TOTALS OF EACH VARIABLE. VECTOR C LENGTH IS NV. C AVER - OUTPUT VECTOR OF AVERAGES OF EACH VARIABLE. VECTOR C LENGTH IS NV. C SD - OUTPUT VECTOR OF STANDARD DEVIATIONS OF EACH C VARIABLE. VECTOR LENGTH IS NV. C VMIN - OUTPUT VECTOR OF MINIMA OF EACH VARIABLE. VECTOR C LENGTH IS NV. C VMAX - OUTPUT VECTOR OF MAXIMA OF EACH VARIABLE. VECTOR C LENGTH IS NV. C NO - NUMBER OF OBSERVATIONS C NV - NUMBER OF VARIABLES FOR EACH OBSERVATION C IER - ZERO, IF NO ERROR. C - 1, IF S IS NULL. VMIN=-1.E75, VMAX=SD=AVER=1.E75. C - 2, IF S HAS ONLY ONE NON-ZERO ELEMENT. VMIN=VMAX. C SD=0.0 C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C ALL OBSERVATIONS CORRESPONDING TO A NON-ZERO ELEMENT IN S C VECTOR ARE ANALYZED FOR EACH VARIABLE IN MATRIX A. C TOTALS ARE ACCUMULATED AND MINIMUM AND MAXIMUM VALUES ARE C FOUND. FOLLOWING THIS, MEANS AND STANDARD DEVIATIONS ARE C CALCULATED. THE DIVISOR FOR STANDARD DEVIATION IS ONE LESS C THAN THE NUMBER OF OBSERVATIONS USED. C C .................................................................. C SUBROUTINE TALLY(A,S,TOTAL,AVER,SD,VMIN,VMAX,NO,NV) DIMENSION A(1),S(1),TOTAL(1),AVER(1),SD(1),VMIN(1),VMAX(1) C C CLEAR OUTPUT VECTORS AND INITIALIZE VMIN,VMAX C IER=0 DO 1 K=1,NV TOTAL(K)=0.0 AVER(K)=1.7E38 SD(K)=1.7E38 VMIN(K)=-1.7E38 1 VMAX(K)=1.7E38 C C TEST SUBSET VECTOR C SCNT=0.0 DO 7 J=1,NO IJ=J-NO IF(S(J)) 2,7,2 2 SCNT=SCNT+1.0 C C CALCULATE TOTAL, MINIMA, MAXIMA C DO 6 I=1,NV IJ=IJ+NO TOTAL(I)=TOTAL(I)+A(IJ) IF(A(IJ)-VMIN(I)) 3,4,4 3 VMIN(I)=A(IJ) 4 IF(A(IJ)-VMAX(I)) 6,6,5 5 VMAX(I)=A(IJ) 6 SD(I)=SD(I)+A(IJ)*A(IJ) 7 CONTINUE C C CALCULATE MEANS AND STANDARD DEVIATIONS C IF (SCNT)8,8,9 8 IER=1 GO TO 15 9 DO 10 I=1,NV 10 AVER(I)=TOTAL(I)/SCNT IF (SCNT-1.0) 13,11,13 11 IER=2 DO 12 I=1,NV 12 SD(I)=0.0 GO TO 15 13 DO 14 I=1,NV 14 SD(I)=SQRT(ABS((SD(I)-TOTAL(I)*TOTAL(I)/SCNT)/(SCNT-1.0))) 15 RETURN END C C .................................................................. C C SUBROUTINE TCNP C C PURPOSE C A SERIES EXPANSION IN CHEBYSHEV POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B. C C USAGE C CALL TCNP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C WORK - WORKING STORAGE OF DIMENSION 2*N C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-(1+B)/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR CHEBYSHEV POLYNOMIALS T(N,X) C T(N+1,X)=2*X*T(N,X)-T(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE T(0,X)=1, T(1,X)=X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X = A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*T(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE TCNP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+C(2)*B POL(2)=C(2)*A IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1. WORK(2)=B WORK(3)=0. WORK(4)=A XD=A+A X0=B+B C C CALCULATE COEFFICIENT VECTOR OF NEXT CHEBYSHEV POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0. C DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0. WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END C C .................................................................. C C SUBROUTINE TCSP C C PURPOSE C A SERIES EXPANSION IN SHIFTED CHEBYSHEV POLYNOMIALS WITH C INDEPENDENT VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH C INDEPENDENT VARIABLE Z, WHERE X=A*Z+B. C C USAGE C CALL TCSP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C WORK - WORKING STORAGE OF DIMENSION 2*N C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (0,1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-B/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=1/(ZR-ZL) AND B=-ZL/(ZR-ZL). C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION FOR C SHIFTED CHEBYSHEV POLYNOMIALS TS(N,X) C TS(N+1,X)=(4*X-2)*TS(N,X)-TS(N-1,X), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE TS(0,X)=1, TS(1,X)=2*X-1. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*TS(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE TCSP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 XD=A+A X0=B+B-1. POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1. WORK(2)=X0 WORK(3)=0. WORK(4)=XD XD=XD+XD X0=X0+X0 C C CALCULATE COEFFICIENT VECTOR OF NEXT SHIFTED CHEBYSHEV C POLYNOMIAL AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0. C DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0. WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END C C .................................................................. C C SUBROUTINE TEAS C C PURPOSE C CALCULATE THE LIMIT OF A GIVEN SEQUENCE BY MEANS OF THE C EPSILON-ALGORITHM. C C USAGE C CALL TEAS(X,N,FIN,EPS,IER) C C DESCRIPTION OF PARAMETERS C X - VECTOR WHOSE COMPONENTS ARE TERMS OF THE GIVEN C SEQUENCE. ON RETURN THE COMPONENTS OF VECTOR X C ARE DESTROYED. C N - DIMENSION OF INPUT VECTOR X. C FIN - RESULTANT SCALAR CONTAINING ON RETURN THE LIMIT C OF THE GIVEN SEQUENCE. C EPS - AN INPUT VALUE, WHICH SPECIFIES THE UPPER BOUND C OF THE RELATIVE (ABSOLUTE) ERROR IF THE COMPONENTS C OF X ARE ABSOLUTELY GREATER (LESS) THAN ONE. C CALCULATION IS TERMINATED AS SOON AS THREE TIMES IN C SUCCESSION THE RELATIVE (ABSOLUTE) DIFFERENCE C BETWEEN NEIGHBOURING TERMS IS NOT GREATER THAN EPS. C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - REQUIRED ACCURACY NOT REACHED WITH C MAXIMAL NUMBER OF ITERATIONS C IER=-1 - INTEGER N IS LESS THAN TEN. C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE N LESS THAN TEN. C THE CHARACTER OF THE GIVEN INFINITE SEQUENCE MUST BE C RECOGNIZABLE BY THOSE N COMPONENTS OF THE INPUT VECTOR X. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE CONVERGENCE OF THE GIVEN SEQUENCE IS ACCELERATED BY C MEANS OF THE E(2)-TRANSFORMATION, USED IN AN ITERATIVE WAY. C FOR REFERENCE, SEE C ALGORITHM 215,SHANKS, CACM 1963, NO. 11, PP. 662. AND C P. WYNN, SINGULAR RULES FOR CERTAIN NON-LINEAR ALGORITHMS C BIT VOL. 3, 1963, PP. 175-195. C C .................................................................. C SUBROUTINE TEAS(X,N,FIN,EPS,IER) C DIMENSION X(1) C C TEST ON WRONG INPUT PARAMETER N C NEW=N IF(NEW-10)1,2,2 1 IER=-1 RETURN C C CALCULATE INITIAL VALUES FOR THE EPSILON ARRAY C 2 ISW1=0 ISW2=0 W1=1.E38 W7=X(4)-X(3) IF(W7)3,4,3 3 W1=1./W7 C 4 W5=1.E38 W7=X(2)-X(1) IF(W7)5,6,5 5 W5=1./W7 C 6 W4=X(3)-X(2) IF(W4)9,7,9 7 W4=1.E38 T=X(2) W2=X(3) 8 W3=1.E38 GO TO 17 C 9 W4=1./W4 C T=1.E38 W7=W4-W5 IF(W7)10,11,10 10 T=X(2)+1./W7 C 11 W2=W1-W4 IF(W2)15,12,15 12 W2=1.E38 IF(T-1.E38)13,14,14 13 ISW2=1 14 W3=W4 GO TO 17 C 15 W2=X(3)+1./W2 W7=W2-T IF(W7)16,8,16 16 W3=W4+1./W7 C 17 ISW1=ISW2 ISW2=0 IMIN=4 C C CALCULATE DIAGONALS OF THE EPSILON ARRAY IN A DO-LOOP C DO 40 I=5,NEW IAUS=I-IMIN W4=1.E38 W5=X(I-1) W7=X(I)-X(I-1) IF(W7)18,24,18 18 W4=1./W7 C IF(W1-1.E38)19,25,25 19 W6=W4-W1 C C TEST FOR NECESSITY OF A SINGULAR RULE C IF(ABS(W6)-ABS(W4)*1.E-4)20,20,22 20 ISW2=1 IF(W6)22,21,22 21 W5=1.E38 W6=W1 IF(W2-1.E38)28,26,26 22 W5=X(I-1)+1./W6 C C FIRST TEST FOR LOSS OF SIGNIFICANCE C IF(ABS(W5)-ABS(X(I-1))*1.E-5)23,24,24 23 IF(W5)36,24,36 C 24 W7=W5-W2 IF(W7)27,25,27 25 W6=1.E38 26 ISW2=0 X(IAUS)=W2 GO TO 37 27 W6=W1+1./W7 28 IF(ISW1-1)33,29,29 C C CALCULATE X(IAUS) WITH HELP OF SINGULAR RULE C 29 IF(W2-1.E38)30,32,32 30 W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2) IF(1.+W7)31,38,31 31 X(IAUS)=W7*W2/(1.+W7) GO TO 39 C 32 X(IAUS)=W5+T-X(I-2) GO TO 39 C 33 W7=W6-W3 IF(W7)34,38,34 34 X(IAUS)=W2+1./W7 C C SECOND TEST FOR LOSS OF SIGNIFICANCE C IF(ABS(X(IAUS))-ABS(W2)*1.E-5)35,37,37 35 IF(X(IAUS))36,37,36 C 36 NEW=IAUS-1 ISW2=0 GO TO 41 C 37 IF(W2-1.E38)39,38,38 38 X(IAUS)=1.E38 IMIN=I C 39 W1=W4 T=W2 W2=W5 W3=W6 ISW1=ISW2 40 ISW2=0 C NEW=NEW-IMIN C C TEST FOR ACCURACY C 41 IEND=NEW-1 DO 47 I=1,IEND W1=ABS(X(I)-X(I+1)) W2=ABS(X(I+1)) IF(W1-EPS)44,44,42 42 IF(W2-1.)46,46,43 43 IF(W1-EPS*W2)44,44,46 44 ISW2=ISW2+1 IF(3-ISW2)45,45,47 45 FIN=X(I) IER=0 RETURN C 46 ISW2=0 47 CONTINUE C IF(NEW-6)48,2,2 48 FIN=X(NEW) IER=1 RETURN END C C .................................................................. C C SUBROUTINE TETRA C C PURPOSE C COMPUTE A TETRACHORIC CORRELATION COEFFICIENT BETWEEN TWO C VARIABLES WHERE DATA IN BOTH VARIABLES HAVE BEEN REDUCED C ARTIFICIALLY TO TWO CATEGORIES. C C USAGE C CALL TETRA (N,U,V,HU,HV,R,RS,IE) C C DESCRIPTION OF PARAMETERS C N - NUMBER OF OBSERVATIONS C U - INPUT VECTOR OF LENGTH N CONTAINING THE FIRST VARIABLE C REDUCED TO TWO CATEGORIES C V - INPUT VECTOR OF LENGTH N CONTAINING THE SECOND VARIABLE C REDUCED TO TWO CATEGORIES C HU - INPUT NUMERICAL CODE INDICATING THE HIGHER CATEGORY OF C THE FIRST VARIABLE. IF ANY VALUE OF VARIABLE U IS C EQUAL TO OR GREATER THAN HU, IT WILL BE CLASSIFIED AS C THE HIGHER CATEGORY, OTHERWISE AS THE LOWER CATEGORY. C HV - SAME AS HU EXCEPT THAT HV IS FOR THE SECOND VARIABLE. C R - TETRACHORIC CORRELATION COMPUTED C RS - STANDARD ERROR OF TETRACHORIC CORRELATION COMPUTED C IE - ERROR CODE C 0 - NO ERROR C 1 - UNABLE TO COMPUTE A TETRACHORIC CORRELATION DUE TO C THE FACT THAT AT LEAST ONE CELL SHOWS ZERO FRE- C QUENCY IN THE 2X2 CONTINGENCY TABLE CONSTRUCTED C FROM INPUT DATA. IN THIS CASE, R AND RS ARE SET C TO 10**75. (SEE GUILFORD, 1956) C 2 - THE ROOT SOLVER GIVES MULTIPLE ROOTS, OR NO ROOTS, C R, IN THE INTERVAL (-1,1) INCLUSIVE. R AND RS ARE C SET TO 10**75. C 3 - UNABLE TO COMPUTE A SATISFACTORY VALUE OF TETRA- C CHORIC CORRELATION USING NEWTON-RAPHSON METHOD OF C APPROXIMATION TO THE ROOT OF THE EQUATION. R AND C RS ARE SET TO 10**75. SEE SUBROUTINE POLRT ERROR C INDICATORS. C 4 - HIGH ORDER COEFFICIENT OF THE POLYNOMIAL IS ZERO. C SEE SUBROUTINE POLRT ERROR INDICATORS. C C REMARKS C VALUES OF VARIABLES U AND V MUST BE NUMERICAL, AND C ALPHABETIC AND SPECIAL CHARACTERS MUST NOT BE USED. C FOR A DEPENDABLE RESULT FOR TETRACHORIC CORRELATION, C IT IS RECOMMENDED THAT N BE AT LEAST 200 OR GREATER. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NDTRI C POLRT--THIS POLYNOMIAL ROOT ROUTINE WAS SELECTED BECAUSE OF C ITS SMALL STORAGE REQUIREMENT. OTHER SSP ROUTINES C WHICH COULD REPLACE POLRT ARE PRQD AND PRBM. THEIR C USE WOULD REQUIRE MODIFICATION OF TETRA. C C METHOD C REFER TO J. P. GUILFORD, 'FUNDAMENTAL STATISTICS IN PSYCHO- C LOGY AND EDUCATION', MCGRAW-HILL, NEW YORK, 1956, CHAPTER 13 C AND W. P. ELDERTON, 'FREQUENCY CURVES AND CORRELATION' 4-TH C ED., CAMBRIDGE UNIVERSITY PRESS, 1953, CHAPTER 9. C C .................................................................. C SUBROUTINE TETRA (N,U,V,HU,HV,R,RS,IE) C DIMENSION XCOF(8),COF(8),ROOTR(7),ROOTI(7) DIMENSION U(1),V(1) DOUBLE PRECISION X31,X32,X312,X322 C C CONSTRUCT A 2X2 CONTINGENCY TABLE C A=0.0 B=0.0 C=0.0 D=0.0 DO 40 I=1,N IF(U(I)-HU) 10, 25, 25 10 IF(V(I)-HV) 15, 20, 20 15 D=D+1.0 GO TO 40 20 B=B+1.0 GO TO 40 25 IF(V(I)-HV) 30, 35, 35 30 C=C+1.0 GO TO 40 35 A=A+1.0 40 CONTINUE C C TEST WHETHER ANY CELL IN THE CONTINGENCY TABLE IS ZERO. C IF SO, RETURN TO THE CALLING ROUTINE WITH R=0.0 AND IE=1. C IE=0 IF(A) 60, 60, 45 45 IF(B) 60, 60, 50 50 IF(C) 60, 60, 55 55 IF(D) 60, 60, 70 60 IE=1 GO TO 86 C C COMPUTE P1, Q1, P2, AND Q2 C 70 FN=N P1=(A+C)/FN Q1=(B+D)/FN P2=(A+B)/FN Q2=(C+D)/FN C C FIND THE STANDARD NORMAL DEVIATES AT Q1 AND Q2, AND THE C ORDINATES AT THOSE POINTS C CALL NDTRI (Q1,X1,Y1,ER) CALL NDTRI (Q2,X2,Y2,ER) C C COMPUTE THE TETRACHORIC CORRELATION COEFFICIENT C IF(X1) 76, 72, 76 72 IF(X2) 76, 74, 76 74 R=0.0 GO TO 90 76 XCOF(1)=-((A*D-B*C)/(Y1*Y2*FN*FN)) XCOF(2)=1.0 XCOF(3)=X1*X2/2.0 XCOF(4)=(X1*X1-1.0)*(X2*X2-1.0)/6.0 X31=DBLE(X1) X32=DBLE(X2) X312=X31**2 X322=X32**2 XCOF(5)=SNGL(X31*(X312-3.0D0)*X32*(X322-3.0D0)/24.0D0) XCOF(6)=SNGL((X312*(X312-6.0D0)+3.0D0)*(X322*(X322-6.0D0)+3.0D0) 1 /120.0D0) XCOF(7)=SNGL(X31*(X312*(X312-10.0D0)+15.0D0)*X32*(X322*(X322-10.0 1 D0)+15.0D0)/720.0D0) XCOF(8)=SNGL((((X312-15.0D0)*X312+45.0D0)*X312-15.0D0)*(((X322- 1 15.0D0)*X322+45.0D0)*X322-15.0D0)/5040.0D0) C CALL POLRT (XCOF,COF,7,ROOTR,ROOTI,IER) C J=0 IF(IER) 78, 78, 84 78 DO 82 I=1,7 IF(ABS(ROOTI(I))-.5*ABS(ROOTR(I))*1.0E-6)79,79,82 79 R=ROOTR(I) IF(ABS(R)-1.0)81,81,80 80 R=1.7E38 0 GO TO 82 81 J=J+1 82 CONTINUE IF(J-1)83,88,83 83 IE=2 GO TO 86 C C UNABLE TO COMPUTE R C 84 IE=IER 86 R=1.7E38 RS=R GO TO 100 88 IF(R-1.7E38)90,83,83 C C STANDARD ERROR OF R=0.0 C 90 RS= SQRT(P1*P2*Q1*Q2)/(Y1*Y2* SQRT(FN)) C 100 RETURN END C C .................................................................. C C SUBROUTINE TEUL C C PURPOSE C COMPUTE THE SUM OF FCT(K) FOR K FROM ONE UP TO INFINITY. C C USAGE C CALL TEUL(FCT,SUM,MAX,EPS,IER) C PARAMETER FCT REQUIRES AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C FCT - NAME OF AN EXTERNAL FUNCTION SUBPROGRAM USED. C IT COMPUTES THE K-TH TERM OF THE SERIES TO ANY C GIVEN INDEX K. C SUM - RESULTANT VALUE CONTAINING ON RETURN THE SUM OF C THE GIVEN SERIES. C MAX - INPUT VALUE, WHICH SPECIFIES THE MAXIMAL NUMBER C OF TERMS OF THE SERIES THAT ARE RESPECTED. C EPS - INPUT VALUE, WHICH SPECIFIES THE UPPER BOUND OF C THE RELATIVE ERROR. C SUMMATION IS STOPPED AS SOON AS FIVE TIMES IN C SUCCESSION THE ABSOLUTE VALUE OF THE TERMS OF THE C TRANSFORMED SERIES ARE FOUND TO BE LESS THAN C EPS*(ABSOLUTE VALUE OF CURRENT SUM). C IER - RESULTANT ERROR PARAMETER CODED IN THE FOLLOWING C FORM C IER=0 - NO ERROR C IER=1 - REQUIRED ACCURACY NOT REACHED WITH C MAXIMAL NUMBER OF TERMS C IER=-1 - THE INTEGER MAX IS LESS THAN ONE. C C REMARKS C NO ACTION BESIDES ERROR MESSAGE IN CASE MAX LESS THAN ONE. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL FUNCTION SUBPROGRAM FCT(K) MUST BE FURNISHED C BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF A SUITABLY REFINED EULER C TRANSFORMATION. FOR REFERENCE, SEE C F.B.HILDEBRAND, INTRODUCTION TO NUMERICAL ANALYSIS, C MCGRAW/HILL, NEW YORK/TORONTO/LONDON, 1956, PP.155-160, AND C P. NAUR, REPORT ON THE ALGORITHMIC LANGUAGE ALGOL 60, C CACM, VOL.3, ISS.5 (1960), PP.311. C C .................................................................. C SUBROUTINE TEUL (FCT,SUM,MAX,EPS,IER) C DIMENSION Y(15) C C TEST ON WRONG INPUT PARAMETER MAX C IF(MAX)1,1,2 1 IER=-1 GOTO 12 C C INITIALIZE EULER TRANSFORMATION C 2 IER=1 I=1 M=1 N=1 Y(1)=FCT(N) SUM=Y(1)*.5 C C START EULER-LOOP C 3 J=0 4 I=I+1 IF(I-MAX)5,5,12 5 N=I AMN=FCT(N) DO 6 K=1,M AMP=(AMN+Y(K))*.5 Y(K)=AMN 6 AMN=AMP C C CHECK EULER TRANSFORMATION C IF(ABS(AMN)-ABS(Y(M)))7,9,9 7 IF(M-15)8,9,9 8 M=M+1 Y(M)=AMN AMN=.5*AMN C C UPDATE SUM C 9 SUM=SUM+AMN IF(ABS(AMN)-EPS*ABS(SUM))10,10,3 C C TEST END OF PROCEDURE C 10 J=J+1 IF(J-5)4,11,11 11 IER=0 12 RETURN END C C .................................................................. C C SUBROUTINE THEP C C PURPOSE C A SERIES EXPANSION IN HERMITE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL THEP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTOR POL AND C C C - COEFFICIENT VECTOR OF GIVEN EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C WORK - WORKING STORAGE OF DIMENSION 2*N C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-C,C) IN X TO THE RANGE (ZL,ZR) IN Z WHERE C ZL=-(C+B)/A AND ZR=(C-B)/A. C FOR GIVEN ZL, ZR AND C WE HAVE A=2C/(ZR-ZL) AND C B=-C(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR HERMITE POLYNOMIALS H(N,X) C H(N+1,X)=2*(X*H(N,X)-N*H(N-1,X)), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE H(0,X)=1,H(1,X)=2*X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*H(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE THEP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 XD=A+A X0=B+B POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1. WORK(2)=X0 WORK(3)=0. WORK(4)=XD FI=2. C C CALCULATE COEFFICIENT VECTOR OF NEXT HERMITE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N P=0. C DO 5 K=2,J H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=P*XD FI=FI+2. 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE TIE C C PURPOSE C CALCULATE CORRECTION FACTOR DUE TO TIES C C USAGE C CALL TIE(R,N,KT,T) C C DESCRIPTION OF PARAMETERS C R - INPUT VECTOR OF RANKS OF LENGTH N CONTAINING VALUES C 1 TO N C N - NUMBER OF RANKED VALUES C KT - INPUT CODE FOR CALCULATION OF CORRECTION FACTOR C 1 SOLVE EQUATION 1 C 2 SOLVE EQUATION 2 C T - CORRECTION FACTOR (OUTPUT) C EQUATION 1 T=SUM(CT**3-CT)/12 C EQUATION 2 T=SUM(CT*(CT-1)/2) C WHERE CT IS THE NUMBER OF OBSERVATIONS TIED FOR A C GIVEN RANK C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C VECTOR IS SEARCHED FOR SUCCESSIVELY LARGER RANKS. TIES ARE C COUNTED AND CORRECTION FACTOR 1 OR 2 SUMMED. C C .................................................................. C SUBROUTINE TIE(R,N,KT,T) DIMENSION R(1) C C INITIALIZATION C T=0.0 Y=0.0 5 X=1.0E38 IND=0 C C FIND NEXT LARGEST RANK C DO 30 I=1,N IF(R(I)-Y) 30,30,10 10 IF(R(I)-X) 20,30,30 20 X=R(I) IND=IND+1 30 CONTINUE C C IF ALL RANKS HAVE BEEN TESTED, RETURN C IF(IND) 90,90,40 40 Y=X CT=0.0 C C COUNT TIES C DO 60 I=1,N IF(R(I)-X) 60,50,60 50 CT=CT+1.0 60 CONTINUE C C CALCULATE CORRECTION FACTOR C IF(CT) 70,5,70 70 IF(KT-1) 75,80,75 75 T=T+CT*(CT-1.)/2.0 GO TO 5 80 T=T+(CT*CT*CT-CT)/12.0 GO TO 5 90 RETURN END C RETURNS T VALUE CORRESPONDING TO GIVEN P C USES ZINV C ABRAMOWITZ 26.7.5 FUNCTION TINV(P,N) REAL N4 X=ZINV(P) N4=N*4 X2=X*X TINV=X+((X2+1)+((3+X2*(16+5*X2))+(-15+X2*(17+ A X2*(19+3*X2)))/N4)/N4/6.)/N4*X RETURN END C C C .................................................................. C C SUBROUTINE TLAP C C PURPOSE C A SERIES EXPANSION IN LAGUERRE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL TLAP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C WORK - WORKING STORAGE OF DIMENSION 2*N C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (0,C) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-B/A AND ZR=(C-B)/A. C FOR GIVEN ZL, ZR AND C WE HAVE A=C/(ZR-ZL) AND C B=-C*ZL/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR LAGUERRE POLYNOMIALS L(N,X) C L(N+1,X)=2*L(N,X)-L(N-1,X)-((1+X)*L(N,X)-L(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE L(0,X)=1, L(1,X)=1-X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*L(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE TLAP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+C(2)-B*C(2) POL(2)=-C(2)*A IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1. WORK(2)=1.D0-B WORK(3)=0. WORK(4)=-A FI=1. C C CALCULATE COEFFICIENT VECTOR OF NEXT LAGUERRE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N FI=FI+1. Q=1./FI Q1=Q-1. Q2=1.-Q1-B*Q Q=Q*A P=0. C DO 5 K=2,J H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1 P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=-Q*P 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE TLEP C C PURPOSE C A SERIES EXPANSION IN LEGENDRE POLYNOMIALS WITH INDEPENDENT C VARIABLE X IS TRANSFORMED TO A POLYNOMIAL WITH INDEPENDENT C VARIABLE Z, WHERE X=A*Z+B C C USAGE C CALL TLEP(A,B,POL,N,C,WORK) C C DESCRIPTION OF PARAMETERS C A - FACTOR OF LINEAR TERM IN GIVEN LINEAR TRANSFORMATION C B - CONSTANT TERM IN GIVEN LINEAR TRANSFORMATION C POL - COEFFICIENT VECTOR OF POLYNOMIAL (RESULTANT VALUE) C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C N - DIMENSION OF COEFFICIENT VECTORS POL AND C C C - GIVEN COEFFICIENT VECTOR OF EXPANSION C COEFFICIENTS ARE ORDERED FROM LOW TO HIGH C POL AND C MAY BE IDENTICALLY LOCATED C WORK - WORKING STORAGE OF DIMENSION 2*N C C REMARKS C COEFFICIENT VECTOR C REMAINS UNCHANGED IF NOT COINCIDING C WITH COEFFICIENT VECTOR POL. C OPERATION IS BYPASSED IN CASE N LESS THAN 1. C THE LINEAR TRANSFORMATION X=A*Z+B OR Z=(1/A)(X-B) TRANSFORMS C THE RANGE (-1,+1) IN X TO THE RANGE (ZL,ZR) IN Z, WHERE C ZL=-(1+B)/A AND ZR=(1-B)/A. C FOR GIVEN ZL, ZR WE HAVE A=2/(ZR-ZL) AND B=-(ZR+ZL)/(ZR-ZL) C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C THE TRANSFORMATION IS BASED ON THE RECURRENCE EQUATION C FOR LEGENDRE POLYNOMIALS P(N,X) C P(N+1,X)=2*X*P(N,X)-P(N-1,X)-(X*P(N,X)-P(N-1,X))/(N+1), C WHERE THE FIRST TERM IN BRACKETS IS THE INDEX, C THE SECOND IS THE ARGUMENT. C STARTING VALUES ARE P(0,X)=1, P(1,X)=X. C THE TRANSFORMATION IS IMPLICITLY DEFINED BY MEANS OF C X=A*Z+B TOGETHER WITH C SUM(POL(I)*Z**(I-1), SUMMED OVER I FROM 1 TO N) C =SUM(C(I)*P(I-1,X), SUMMED OVER I FROM 1 TO N). C C .................................................................. C SUBROUTINE TLEP(A,B,POL,N,C,WORK) C DIMENSION POL(1),C(1),WORK(1) C C TEST OF DIMENSION IF(N-1)2,1,3 C C DIMENSION LESS THAN 2 1 POL(1)=C(1) 2 RETURN C 3 POL(1)=C(1)+B*C(2) POL(2)=A*C(2) IF(N-2)2,2,4 C C INITIALIZATION 4 WORK(1)=1. WORK(2)=B WORK(3)=0. WORK(4)=A FI=1. C C CALCULATE COEFFICIENT VECTOR OF NEXT LEGENDRE POLYNOMIAL C AND ADD MULTIPLE OF THIS VECTOR TO POLYNOMIAL POL DO 6 J=3,N FI=FI+1. Q=1./FI-1. Q1=1.-Q P=0. C DO 5 K=2,J H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=A*P*Q1 6 POL(J)=C(J)*WORK(2*J) RETURN END C C .................................................................. C C SUBROUTINE TPRD C C PURPOSE C TRANSPOSE A MATRIX AND POSTMULTIPLY BY ANOTHER TO FORM C A RESULTANT MATRIX C C USAGE C CALL TPRD(A,B,R,N,M,MSA,MSB,L) C C DESCRIPTION OF PARAMETERS C A - NAME OF FIRST INPUT MATRIX C B - NAME OF SECOND INPUT MATRIX C R - NAME OF OUTPUT MATRIX C N - NUMBER OF ROWS IN A AND B C M - NUMBER OF COLUMNS IN A AND ROWS IN R C MSA - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C MSB - SAME AS MSA EXCEPT FOR MATRIX B C L - NUMBER OF COLUMNS IN B AND R C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRICES A OR B C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C MATRIX TRANSPOSE OF A IS NOT ACTUALLY CALCULATED. INSTEAD, C ELEMENTS IN MATRIX A ARE TAKEN COLUMNWISE RATHER THAN C ROWWISE FOR MULTIPLICATION BY MATRIX B. C THE FOLLOWING TABLE SHOWS THE STORAGE MODE OF THE OUTPUT C MATRIX FOR ALL COMBINATIONS OF INPUT MATRICES C A B R C GENERAL GENERAL GENERAL C GENERAL SYMMETRIC GENERAL C GENERAL DIAGONAL GENERAL C SYMMETRIC GENERAL GENERAL C SYMMETRIC SYMMETRIC GENERAL C SYMMETRIC DIAGONAL GENERAL C DIAGONAL GENERAL GENERAL C DIAGONAL SYMMETRIC GENERAL C DIAGONAL DIAGONAL DIAGONAL C C .................................................................. C SUBROUTINE TPRD(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) C C SPECIAL CASE FOR DIAGONAL BY DIAGONAL C MS=MSA*10+MSB IF(MS-22) 30,10,30 10 DO 20 I=1,N 20 R(I)=A(I)*B(I) RETURN C C MULTIPLY TRANSPOSE OF A BY B C 30 IR=1 DO 90 K=1,L DO 90 J=1,M R(IR)=0.0 DO 80 I=1,N IF(MS) 40,60,40 40 CALL LOC(I,J,IA,N,M,MSA) CALL LOC(I,K,IB,N,L,MSB) IF(IA) 50,80,50 50 IF(IB) 70,80,70 60 IA=N*(J-1)+I IB=N*(K-1)+I 70 R(IR)=R(IR)+A(IA)*B(IB) 80 CONTINUE 90 IR=IR+1 RETURN END C C .................................................................. C C SUBROUTINE TRACE C C PURPOSE C COMPUTE CUMULATIVE PERCENTAGE OF EIGENVALUES GREATER THAN C OR EQUAL TO A CONSTANT SPECIFIED BY THE USER. THIS SUB- C ROUTINE NORMALLY OCCURS IN A SEQUENCE OF CALLS TO SUB- C ROUTINES CORRE, EIGEN, TRACE, LOAD, AND VARMX IN THE PER- C FORMANCE OF A FACTOR ANALYSIS. C C USAGE C CALL TRACE (M,R,CON,K,D) C C DESCRIPTION OF PARAMETERS C M - NUMBER OF VARIABLES. M MUST BE > OR = TO 1 C R - INPUT MATRIX (SYMMETRIC AND STORED IN COMPRESSED C FORM WITH ONLY UPPER TRIANGLE BY COLUMN IN CORE) C CONTAINING EIGENVALUES IN DIAGONAL. EIGENVALUES ARE C ARRANGED IN DESCENDING ORDER. THE ORDER OF MATRIX R C IS M BY M. ONLY M*(M+1)/2 ELEMENTS ARE IN STORAGE. C (STORAGE MODE OF 1) C CON - A CONSTANT USED TO DECIDE HOW MANY EIGENVALUES TO C RETAIN. CUMULATIVE PERCENTAGE OF EIGENVALUES C WHICH ARE GREATER THAN OR EQUAL TO THIS VALUE IS C CALCULATED. C K - OUTPUT VARIABLE CONTAINING THE NUMBER OF EIGENVALUES C GREATER THAN OR EQUAL TO CON. (K IS THE NUMBER OF C FACTORS.) C D - OUTPUT VECTOR OF LENGTH M CONTAINING CUMULATIVE C PERCENTAGE OF EIGENVALUES WHICH ARE GREATER THAN C OR EQUAL TO CON. C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C EACH EIGENVALUE GREATER THAN OR EQUAL TO CON IS DIVIDED BY M C AND THE RESULT IS ADDED TO THE PREVIOUS TOTAL TO OBTAIN C THE CUMULATIVE PERCENTAGE FOR EACH EIGENVALUE. C C .................................................................. C SUBROUTINE TRACE (M,R,CON,K,D) DIMENSION R(1),D(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C STATEMENT WHICH FOLLOWS. C C DOUBLE PRECISION R,D C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C ............................................................... C FM=M L=0 DO 100 I=1,M L=L+I 100 D(I)=R(L) K=0 C C TEST WHETHER I-TH EIGENVALUE IS GREATER C THAN OR EQUAL TO THE CONSTANT C DO 110 I=1,M IF(D(I)-CON) 120, 105, 105 105 K=K+1 110 D(I)=D(I)/FM C C COMPUTE CUMULATIVE PERCENTAGE OF EIGENVALUES C 120 DO 130 I=2,K 130 D(I)=D(I)+D(I-1) RETURN END C C .................................................................. C C SUBROUTINE TTEST C C PURPOSE C TO FIND CERTAIN T-STATISTICS ON THE MEANS OF POPULATIONS. C C USAGE C CALL TTEST (A,NA,B,NB,NOP,NDF,ANS) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF LENGTH NA CONTAINING DATA. C NA - NUMBER OF OBSERVATIONS IN A. C B - INPUT VECTOR OF LENGTH NB CONTAINING DATA. C NB - NUMBER OF OBSERVATIONS IN B. C NOP - OPTIONS FOR VARIOUS HYPOTHESES.. C NOP=1--- THAT POPULATION MEAN OF B = GIVEN VALUE A. C (SET NA=1) C NOP=2--- THAT POPULATION MEAN OF B = POPULATION MEAN C OF A, GIVEN THAT THE VARIANCE OF B = THE C VARIANCE OF A. C NOP=3--- THAT POPULATION MEAN OF B = POPULATION MEAN C OF A, GIVEN THAT THE VARIANCE OF B IS NOT C EQUAL TO THE VARIANCE OF A. C NOP=4--- THAT POPULATION MEAN OF B = POPULATION MEAN C OF A, GIVEN NO INFORMATION ABOUT VARIANCES OF C A AND B. (SET NA=NB) C NDF - OUTPUT VARIABLE CONTAINING DEGREES OF FREEDOM ASSOCI- C ATED WITH T-STATISTIC CALCULATED. C ANS - T-STATISTIC FOR GIVEN HYPOTHESIS. C C REMARKS C NA AND NB MUST BE GREATER THAN 1, EXCEPT THAT NA=1 IN C OPTION 1. NA AND NB MUST BE THE SAME IN OPTION 4. C IF NOP IS OTHER THAN 1, 2, 3 OR 4, DEGREES OF FREEDOM AND C T-STATISTIC WILL NOT BE CALCULATED. NDF AND ANS WILL BE C SET TO ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C REFER TO OSTLE, BERNARD, 'STATISTICS IN RESEARCH', IOWA C STATE COLLEGE PRESS, 1954, CHAPTER 5. C C .................................................................. C SUBROUTINE TTEST (A,NA,B,NB,NOP,NDF,ANS) DIMENSION A(1),B(1) C C INITIALIZATION C NDF=0 ANS=0.0 C C CALCULATE THE MEAN OF A C AMEAN=0.0 DO 110 I=1,NA 110 AMEAN=AMEAN+A(I) FNA=NA AMEAN=AMEAN/FNA C C CALCULATE THE MEAN OF B C 115 BMEAN=0.0 DO 120 I=1,NB 120 BMEAN=BMEAN+B(I) FNB=NB BMEAN=BMEAN/FNB C IF(NOP-4) 122, 180, 200 122 IF(NOP-1) 200, 135, 125 C C CALCULATE THE VARIANCE OF A C 125 SA2=0.0 DO 130 I=1,NA 130 SA2=SA2+(A(I)-AMEAN)**2 SA2=SA2/(FNA-1.0) C C CALCULATE THE VARIANCE OF B C 135 SB2=0.0 DO 140 I=1,NB 140 SB2=SB2+(B(I)-BMEAN)**2 SB2=SB2/(FNB-1.0) C GO TO (150,160,170), NOP C C OPTION 1 C 150 ANS=((BMEAN-AMEAN)/SQRT(SB2))*SQRT(FNB) NDF=NB-1 GO TO 200 C C OPTION 2 C 160 NDF=NA+NB-2 FNDF=NDF S=SQRT(((FNA-1.0)*SA2+(FNB-1.0)*SB2)/FNDF) ANS=((BMEAN-AMEAN)/S)*(1.0/SQRT(1.0/FNA+1.0/FNB)) GO TO 200 C C OPTION 3 C 170 ANS=(BMEAN-AMEAN)/SQRT(SA2/FNA+SB2/FNB) A1=(SA2/FNA+SB2/FNB)**2 A2=(SA2/FNA)**2/(FNA+1.0)+(SB2/FNB)**2/(FNB+1.0) NDF=A1/A2-2.0+0.5 GO TO 200 C C OPTION 4 C 180 SD=0.0 D=BMEAN-AMEAN DO 190 I=1,NB 190 SD=SD+(B(I)-A(I)-D)**2 SD=SQRT(SD/(FNB-1.0)) ANS=(D/SD)*SQRT(FNB) NDF=NB-1 C 200 RETURN END C C .................................................................. C C SUBROUTINE TWOAV C C PURPOSE C TEST WHETHER A NUMBER OF SAMPLES ARE FROM THE SAME C POPULATION BY THE FRIEDMAN TWO-WAY ANALYSIS OF VARIANCE TEST C C USAGE C CALL TWOAV(A,R,N,M,W,XR,NDF,NR) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX, N BY M, OF ORIGINAL DATA C R - OUTPUT MATRIX, N BY M, OF RANKED DATA C N - NUMBER OF GROUPS C M - NUMBER OF CASES IN EACH GROUP C W - WORK AREA OF LENGTH 2*M C XR - FRIEDMAN STATISTIC (OUTPUT) C NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT) C NR - CODE, 0 FOR UNRANKED DATA IN A, 1 FOR RANKED DATA C IN A (INPUT) C C REMARKS C NONE C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANK C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 7 C C .................................................................. C SUBROUTINE TWOAV (A,R,N,M,W,XR,NDF,NR) DIMENSION A(1),R(1),W(1) C C DETERMINE WHETHER DATA IS RANKED C IF(NR-1) 10, 30, 10 C C RANK DATA IN EACH GROUP AND ASSIGN TIED OBSERVATIONS AVERAGE C OF TIED RANK C 10 DO 20 I=1,N IJ=I-N IK=IJ DO 15 J=1,M IJ=IJ+N 15 W(J)=A(IJ) CALL RANK (W,W(M+1),M) DO 20 J=1,M IK=IK+N IW=M+J 20 R(IK)=W(IW) GO TO 35 30 NM=N*M DO 32 I=1,NM 32 R(I)=A(I) C C CALCULATE SUM OF SQUARES OF SUMS OF RANKS C 35 RTSQ=0.0 IR=0 DO 50 J=1,M RT=0.0 DO 40 I=1,N IR=IR+1 40 RT=RT+R(IR) 50 RTSQ=RTSQ+RT*RT C C CALCULATE FRIEDMAN TEST VALUE, XR C FNM=N*(M+1) FM=M XR=(12.0/(FM*FNM))*RTSQ-3.0*FNM C C FIND DEGREES OF FREEDOM C NDF=M-1 RETURN END C C .................................................................. C C SUBROUTINE UTEST C C PURPOSE C TEST WHETHER TWO INDEPENDENT GROUPS ARE FROM THE SAME C POPULATION BY MEANS OF MANN-WHITNEY U-TEST C C USAGE C CALL UTEST(A,R,N1,N2,U,Z,IER) C C DESCRIPTION OF PARAMETERS C A - INPUT VECTOR OF CASES CONSISTING OF TWO INDEPENDENT C GROUPS . SMALLER GROUP PRECEDES LARGER GROUP. LENGTH C IS N1+N2. C R - OUTPUT VECTOR OF RANKS. SMALLEST VALUE IS RANKED 1, C LARGEST IS RANKED N. TIES ARE ASSIGNED AVERAGE OF TIED C RANKS. LENGTH IS N1+N2. C N1 - NUMBER OF CASES IN SMALLER GROUP C N2 - NUMBER OF CASES IN LARGER GROUP C U - STATISTIC USED TO TEST HOMOGENEITY OF THE TWO C GROUPS (OUTPUT) C Z - MEASURE OF SIGNIFICANCE OF U IN TERMS OF NORMAL C DISTRIBUTION (OUTPUT) C IER- 0, IF NO ERROR. C - 1, IF ALL VALUES OF ONE GROUP ARE TIED. C C REMARKS C Z IS SET TO ZERO IF N2 IS LESS THAN 20 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANK C TIE C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 6 C C .................................................................. C SUBROUTINE UTEST(A,R,N1,N2,U,Z,IER) DIMENSION A(1),R(1) IER=0 C C RANK SCORES FROM BOTH GROUP TOGETHER IN ASCENDING ORDER, AND C ASSIGN TIED OBSERVATIONS AVERAGE OF TIED RANKS C N=N1+N2 CALL RANK(A,R,N) Z=0.0 C C SUM RANKS IN LARGER GROUP C R2=0.0 NP=N1+1 DO 10 I=NP,N 10 R2=R2+R(I) C C CALCULATE U C FNX=N1*N2 FN=N FN2=N2 UP=FNX+FN2*((FN2+1.0)/2.0)-R2 U=FNX-UP IF(UP-U) 20,30,30 20 U=UP C C TEST FOR N2 LESS THAN 20 C 30 IF(N2-20) 80,40,40 C C COMPUTE STANDARD DEVIATION C 40 KT=1 CALL TIE(R,N,KT,TS) IF(TS) 50,60,50 50 IF (TS-(FN*FN*FN-FN)/12)52,51,52 51 IER=1 GO TO 80 52 S=SQRT((FNX/(FN*(FN-1.0)))*(((FN*FN*FN-FN)/12.0)-TS)) GO TO 70 60 S=SQRT(FNX*(FN+1.0)/12.0) C C COMPUTE Z C 70 Z=(U-FNX*0.5)/S 80 RETURN END C C .................................................................. C C SUBROUTINE VARMX C C PURPOSE C PERFORM ORTHOGONAL ROTATIONS OF A FACTOR MATRIX. THIS C SUBROUTINE NORMALLY OCCURS IN A SEQUENCE OF CALLS TO SUB- C ROUTINES CORRE, EIGEN, TRACE, LOAD, VARMX IN THE PERFORMANCE C OF A FACTOR ANALYSIS. C C USAGE C CALL VARMX (M,K,A,NC,TV,H,F,D,IER) C C DESCRIPTION OF PARAMETERS C M - NUMBER OF VARIABLES AND NUMBER OF ROWS OF MATRIX A. C K - NUMBER OF FACTORS. C A - INPUT IS THE ORIGINAL FACTOR MATRIX, AND OUTPUT IS C THE ROTATED FACTOR MATRIX. THE ORDER OF MATRIX A C IS M X K. C NC - OUTPUT VARIABLE CONTAINING THE NUMBER OF ITERATION C CYCLES PERFORMED. C TV - OUTPUT VECTOR CONTAINING THE VARIANCE OF THE FACTOR C MATRIX FOR EACH ITERATION CYCLE. THE VARIANCE PRIOR C TO THE FIRST ITERATION CYCLE IS ALSO CALCULATED. C THIS MEANS THAT NC+1 VARIANCES ARE STORED IN VECTOR C TV. MAXIMUM NUMBER OF ITERATION CYCLES ALLOWED IN C THIS SUBROUTINE IS 50. THEREFORE, THE LENGTH OF C VECTOR TV IS 51. C H - OUTPUT VECTOR OF LENGTH M CONTAINING THE ORIGINAL C COMMUNALITIES. C F - OUTPUT VECTOR OF LENGTH M CONTAINING THE FINAL C COMMUNALITIES. C D - OUTPUT VECTOR OF LENGTH M CONTAINING THE DIFFERENCES C BETWEEN THE ORIGINAL AND FINAL COMMUNALITIES. C IER - ERROR INDICATOR C IER=0 - NO ERROR C IER=1 - CONVERGENCE WAS NOT ACHIEVED IN 50 CYCLES C OF ROTATION C C REMARKS C IF VARIANCE COMPUTED AFTER EACH ITERATION CYCLE DOES NOT C INCREASE FOR FOUR SUCCESSIVE TIMES, THE SUBROUTINE STOPS C ROTATION. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C NONE C C METHOD C KAISER'S VARIMAX ROTATION AS DESCRIBED IN 'COMPUTER PROGRAM C FOR VARIMAX ROTATION IN FACTOR ANALYSIS' BY THE SAME AUTHOR, C EDUCATIONAL AND PSYCHOLOGICAL MEASUREMENT, VOL XIX, NO. 3, C 1959. C C .................................................................. C SUBROUTINE VARMX (M,K,A,NC,TV,H,F,D,IER) DIMENSION A(1),TV(1),H(1),F(1),D(1) C C ............................................................... C C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION C C DOUBLE PRECISION A,TV,H,F,D,TVLT,CONS,AA,BB,CC,DD,U,T,B,COS4T, C 1 SIN4T,TAN4T,SINP,COSP,CTN4T,COS2T,SIN2T,COST,SINT C C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS C ROUTINE. C C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS C 115, 290, 330, 350, AND 355 MUST BE CHANGED TO DSQRT. ABS IN C STATEMENTS 280, 320, AND 375 MUST BE CHANGED TO DABS. C C ............................................................... C C INITIALIZATION C IER=0 EPS=0.00116 TVLT=0.0 LL=K-1 NV=1 NC=0 FN=M FFN=FN*FN CONS=0.7071066 C C CALCULATE ORIGINAL COMMUNALITIES C DO 110 I=1,M H(I)=0.0 DO 110 J=1,K L=M*(J-1)+I 110 H(I)=H(I)+A(L)*A(L) C C CALCULATE NORMALIZED FACTOR MATRIX C DO 120 I=1,M 115 H(I)= SQRT(H(I)) DO 120 J=1,K L=M*(J-1)+I 120 A(L)=A(L)/H(I) GO TO 132 C C CALCULATE VARIANCE FOR FACTOR MATRIX C 130 NV=NV+1 TVLT=TV(NV-1) 132 TV(NV)=0.0 DO 150 J=1,K AA=0.0 BB=0.0 LB=M*(J-1) DO 140 I=1,M L=LB+I CC=A(L)*A(L) AA=AA+CC 140 BB=BB+CC*CC 150 TV(NV)=TV(NV)+(FN*BB-AA*AA)/FFN IF(NV-51)160,155,155 155 IER=1 GO TO 430 C C PERFORM CONVERGENCE TEST C 160 IF((TV(NV)-TVLT)-(1.E-7)) 170, 170, 190 170 NC=NC+1 IF(NC-3) 190, 190, 430 C C ROTATION OF TWO FACTORS CONTINUES UP TO C THE STATEMENT 120. C 190 DO 420 J=1,LL L1=M*(J-1) II=J+1 C C CALCULATE NUM AND DEN C DO 420 K1=II,K L2=M*(K1-1) AA=0.0 BB=0.0 CC=0.0 DD=0.0 DO 230 I=1,M L3=L1+I L4=L2+I U=(A(L3)+A(L4))*(A(L3)-A(L4)) T=A(L3)*A(L4) T=T+T CC=CC+(U+T)*(U-T) DD=DD+2.0*U*T AA=AA+U 230 BB=BB+T T=DD-2.0*AA*BB/FN B=CC-(AA*AA-BB*BB)/FN C C COMPARISON OF NUM AND DEN C IF(T-B) 280, 240, 320 240 IF((T+B)-EPS) 420, 250, 250 C C NUM + DEN IS GREATER THAN OR EQUAL TO THE C TOLERANCE FACTOR C 250 COS4T=CONS SIN4T=CONS GO TO 350 C C NUM IS LESS THAN DEN C 280 TAN4T= ABS(T)/ ABS(B) IF(TAN4T-EPS) 300, 290, 290 290 COS4T=1.0/ SQRT(1.0+TAN4T*TAN4T) SIN4T=TAN4T*COS4T GO TO 350 300 IF(B) 310, 420, 420 310 SINP=CONS COSP=CONS GO TO 400 C C NUM IS GREATER THAN DEN C 320 CTN4T= ABS(T/B) IF(CTN4T-EPS) 340, 330, 330 330 SIN4T=1.0/ SQRT(1.0+CTN4T*CTN4T) COS4T=CTN4T*SIN4T GO TO 350 340 COS4T=0.0 SIN4T=1.0 C C DETERMINE COS THETA AND SIN THETA C 350 COS2T= SQRT((1.0+COS4T)/2.0) SIN2T=SIN4T/(2.0*COS2T) 355 COST= SQRT((1.0+COS2T)/2.0) SINT=SIN2T/(2.0*COST) C C DETERMINE COS PHI AND SIN PHI C IF(B) 370, 370, 360 360 COSP=COST SINP=SINT GO TO 380 370 COSP=CONS*COST+CONS*SINT 375 SINP= ABS(CONS*COST-CONS*SINT) 380 IF(T) 390, 390, 400 390 SINP=-SINP C C PERFORM ROTATION C 400 DO 410 I=1,M L3=L1+I L4=L2+I AA=A(L3)*COSP+A(L4)*SINP A(L4)=-A(L3)*SINP+A(L4)*COSP 410 A(L3)=AA 420 CONTINUE GO TO 130 C C DENORMALIZE VARIMAX LOADINGS C 430 DO 440 I=1,M DO 440 J=1,K L=M*(J-1)+I 440 A(L)=A(L)*H(I) C C CHECK ON COMMUNALITIES C NC=NV-1 DO 450 I=1,M 450 H(I)=H(I)*H(I) DO 470 I=1,M F(I)=0.0 DO 460 J=1,K L=M*(J-1)+I 460 F(I)=F(I)+A(L)*A(L) 470 D(I)=H(I)-F(I) RETURN END C C .................................................................. C C SUBROUTINE WTEST C C PURPOSE C TEST DEGREE OF ASSOCIATION AMONG A NUMBER OF VARIABLES BY C THE KENDALL COEFFICIENT OF CONCORDANCE C C USAGE C CALL WTEST(A,R,N,M,WA,W,CS,NDF,NR) C C DESCRIPTION OF PARAMETERS C A - INPUT MATRIX, N BY M, OF ORIGINAL DATA C R - OUTPUT MATRIX, N BY M, OF RANKED DATA.SMALLEST VALUE C IS RANKED 1, LARGEST IS RANKED N. TIES ARE ASSIGNED C AVERAGE OF TIED RANKS C N - NUMBER OF VARIABLES C M - NUMBER OF CASES C WA - WORK AREA VECTOR OF LENGTH 2*M C W - KENDALL COEFFICIENT OF CONCORDANCE(OUTPUT) C CS - CHI-SQUARE (OUTPUT) C NDF - NUMBER OF DEGREES OF FREEDOM (OUTPUT) C NR - CODE, 0 FOR UNRANKED DATA IN A, 1 FOR RANKED DATA C IN A (INPUT) C C REMARKS C CHI-SQUARE IS SET TO ZERO IF M IS 7 OR SMALLER C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C RANK C TIE C C METHOD C DESCRIBED IN S. SIEGEL, 'NONPARAMETRIC STATISTICS FOR THE C BEHAVIORAL SCIENCES', MCGRAW-HILL, NEW YORK, 1956, C CHAPTER 9 C .................................................................. C C SUBROUTINE WTEST (A,R,N,M,WA,W,CS,NDF,NR) DIMENSION A(1),R(1),WA(1) C FM=M FN=N C C DETERMINE WHETHER DATA IS RANKED C RANK DATA FOR ALL VARIABLES ASSIGNING TIED OBSERVATIONS AVERAGE C OF TIED RANKS AND COMPUTE CORRECTION FOR TIED SCORES C T=0.0 KT=1 DO 20 I=1,N IJ=I-N IK=IJ IF(NR-1) 5,2,5 2 DO 3 J=1,M IJ=IJ+N K=M+J 3 WA(K)=A(IJ) GO TO 15 5 DO 10 J=1,M IJ=IJ+N 10 WA(J)=A(IJ) CALL RANK(WA,WA(M+1),M) 15 CALL TIE(WA(M+1),M,KT,TI) T=T+TI DO 20 J=1,M IK=IK+N IW=M+J 20 R(IK)=WA(IW) C C CALCULATE VECTOR OF SUMS OF RANKS C IR=0 DO 40 J=1,M WA(J)=0.0 DO 40 I=1,N IR=IR+1 40 WA(J)=WA(J)+R(IR) C C COMPUTE MEAN OF SUMS OF RANKS C SM=0.0 DO 50 J=1,M 50 SM=SM+WA(J) SM=SM/FM C C COMPUTE SUM OF SQUARES OF DEVIATIONS C S=0.0 DO 60 J=1,M 60 S=S+(WA(J)-SM)*(WA(J)-SM) C C COMPUTE W C W=S/(((FN*FN)*(FM*FM*FM-FM)/12.0)-FN*T) C C COMPUTE DEGREES OF FREEDOM AND CHI-SQUARE IF M IS OVER 7 C CS=0.0 NDF=0 IF(M-7) 70,70,65 65 CS=FN*(FM-1.0)*W NDF=M-1 70 RETURN END C C .................................................................. C C SUBROUTINE XCPY C C PURPOSE C COPY A PORTION OF A MATRIX C C USAGE C CALL XCPY(A,R,L,K,NR,MR,NA,MA,MS) C C DESCRIPTION OF PARAMETERS C A - NAME OF INPUT MATRIX C R - NAME OF OUTPUT MATRIX C L - ROW OF A WHERE FIRST ELEMENT OF R CAN BE FOUND C K - COLUMN OF A WHERE FIRST ELEMENT OF R CAN BE FOUND C NR - NUMBER OF ROWS TO BE COPIED INTO R C MR - NUMBER OF COLUMNS TO BE COPIED INTO R C NA - NUMBER OF ROWS IN A C MA - NUMBER OF COLUMNS IN A C MS - ONE DIGIT NUMBER FOR STORAGE MODE OF MATRIX A C 0 - GENERAL C 1 - SYMMETRIC C 2 - DIAGONAL C C REMARKS C MATRIX R CANNOT BE IN THE SAME LOCATION AS MATRIX A C MATRIX R IS ALWAYS A GENERAL MATRIX C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C LOC C C METHOD C MATRIX R IS FORMED BY COPYING A PORTION OF MATRIX A. THIS C IS DONE BY EXTRACTING NR ROWS AND MR COLUMNS OF MATRIX A, C STARTING WITH ELEMENT AT ROW L, COLUMN K C C .................................................................. C SUBROUTINE XCPY(A,R,L,K,NR,MR,NA,MA,MS) DIMENSION A(1),R(1) C C INITIALIZE C IR=0 L2=L+NR-1 K2=K+MR-1 C DO 5 J=K,K2 DO 5 I=L,L2 IR=IR+1 R(IR)=0.0 C C LOCATE ELEMENT FOR ANY MATRIX STORAGE MODE C CALL LOC(I,J,IA,NA,MA,MS) C C TEST FOR ZERO ELEMENT IN DIAGONAL MATRIX C IF(IA) 4,5,4 4 R(IR)=A(IA) 5 CONTINUE RETURN END C^ DECEMBER 09 1974 C GIVES AREA UNDER NORMAL DISTRIBUTION CURVE C FOR PROBABILITY P C ABRANOWITZ 26.2.23 FUNCTION ZINV(P) T=SQRT(ALOG(1./(P*P))) ZINV=T-(2.515517+T*(0.802853+T*0.010328))/(1.+T * *(1.432788+T*(0.189269+T*0.001308))) RETURN END