C01 - MAT1 - vypocet Besselovy funkce 1.druhu C02 - MAT2 - vypocet Besselovy funkce 2.druhu C03 - MAT3 - vypocet modifikovanych Besselovych funkci 1.druhu radu 1-n C04 - MAT4 - vypocet modifikovane Besselovy funkce 1.druhu radu 0 C05 - MAT5 - vypocet modifikovane Besselovy funkce 2.druhu C06 - MAT6 - vypocet Jacobiovych eliptickych funkci C07 - MAT7 - nalezeni lokalniho minima funkce n-promennych (sdruzene gradienty) C08 - MAT8 - nalezeni lokalniho minima funkce n-promennych (nejvetsi spad) C09 - MAT9 - vypocet derivace analyticke funkce C10 - MAT10 - vypocet derivace analyticke funkce C11 - MAT11 - vypocet urciteho integralu analyticke funkce C12 - MAT12 - vypocet Fresnelovych integralu C13 - MAT13 - vypocet uplneho eliptickeho integralu 1.druhu C14 - MAT14 - vypocet uplneho eliptickeho integralu 2.druhu C15 - MAT15 - vypocet eliptickeho integralu 1.druhu C16 - MAT16 - vypocet eliptickeho integralu 2.druhu C17 - MAT17 - vypocet exponencialniho integralu C18 - MAT18 - vypocet sinus a cosinus integralu C19 - MAT19 - vypocet integralu funkce f(x) na intervalu (a,b) C20 - MAT20 - vypocet integralu funkce exp(-x)*f(x) na intervalu (0,inf) C21 - MAT21 - vypocet integralu funkce exp(-x**2)*f(x) na intervalu (-inf,inf) C22 - MAT22 - vypocet integralu funkce exp(-x)*f(x)/sqrt(x) na intervalu (0,inf) C23 - MAT23 - integrace dif. rovnice dy/dx=f(x,y) (Runge-Kutta) C24 - MAT24 - integrace dif. rovnice dy/dx=f(x,y) (Runge-Kutta) C25 - MAT25 - reseni systemu obyc. dif. rovnic 1.radu v normalnim tvaru s poc. podminkami (prediktor-korektor) C26 - MAT26 - reseni lin. systemu obyc. dif. rovnic 1.radu s poc. podminkami (prediktor-korektor) C27 - MAT27 - reseni systemu obyc. dif. rovnic 1.radu v normalnim tvaru s poc. podminkami (Runge-Kutta) C28 - MAT28 - reseni lin. okrajove ulohy systemu lin. dif. rovnic 1.radu (prediktor-korektor) C29 - MAT29 - podprogram volany modulem MAT28 C30 - MAT30 - reseni nelinearni rovnice tvaru F(x)=0 (Muler) C31 - MAT31 - reseni nelinearni rovnice tvaru F(x)=0 (Newton) C32 - MAT32 - reseni nelinearni rovnice tvaru F(x)=0 (Wegstein) C33 - MAT33 - Fourierova analyza 2pi-periodicke analyticke funkce C34 - MAT34 - Fourierova analyza 2pi-periodicke diskretni funkce C35 - MAT35 - vypocet limity posloupnosti C36 - MAT36 - soucet nekonecne rady C01 - PLM1 - soucet dvou polynomu C02 - PLM2 - rozdil dvou polynomu C03 - PLM3 - nasobeni polynomu druhym polynomem C04 - PLM4 - deleni polynomu druhym polynomem C05 - PLM5 - podprogram volany modulem PLM4 C06 - PLM6 - vypocet nejvetsiho spolecneho delitele dvou polynomu C07 - PLM7 - substituce promenne polynomu druhym polynomem C08 - PLM8 - podprogram volany modulem PLM7 C09 - PLM9 - podprogram volany modulem PLM7 C10 - PLM10 - vypocet komplexnich korenu polynomu (Newton-Raphson) C11 - PLM11 - vypocet komplexnich korenu polynomu (QD-algoritmus) C12 - PLM12 - vypocet hodnoty polynomu C13 - PLM13 - vypocet hodnoty polynomu a jeho derivace C14 - PLM14 - podprogram volany modulem PLM13 C15 - PLM15 - urceni derivace polynomu C16 - PLM16 - urceni primitivni funkce polynomu C17 - PLM17 - ekonomizace polynomu (nesymetricky definicni obor) C18 - PLM18 - ekonomizace polynomu (symetricky definicni obor) C19 - PLM19 - substituce promenne polynomu (viz PLM17,PLM18)) C01 - APR1 - interpolace f(x) funkce dane tabulkou [k,f(k)] (schema invertovanych rozdilu) C02 - APR2 - interpolace f(x) funkce dane tabulkou [k,f(k)] (Aitken-schema) C03 - APR3 - interpolace f(x) funkce dane tabulkou [k,f(k),f'(k)] C04 - APR4 - vybrani a usporadani bodu tabulky [k,f(k)] dle distance k od x C05 - APR5 - vybrani a usporadani bodu tabulky [k,f(k)] dle distance k od x (eqidistance bodu k) C06 - APR6 - vybrani a usporadani bodu tabulky [k,f(k)] dle distance k od x (monotonie bodu k) C07 - APR7 - vypocet vektoru vyrovnanych f(x) funkce dane tabulkou [k,f(k)] C08 - APR8 - vypocet vektoru vyrovnanych f(x) funkce dane tabulkou [k,f(k)] (eqidistance bodu k) C09 - APR9 - vypocet vektoru f'(k) funkce dane tabulkou [k,f(k)] C10 - APR10 - vypocet vektoru f'(k) funkce dane tabulkou [k,f(k)] (eqidistance bodu k) C11 - APR11 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k)] C12 - APR12 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k)] (eqidistance bodu k) C13 - APR13 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k),f'(k)] C14 - APR14 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k),f'(k)] (eqidistance bodu k) C15 - APR15 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k),f'(k),f''(k)] C16 - APR16 - vypocet vektoru urcitych integralu funkce dane tabulkou [k,f(k),f'(k),f''(k)] (eqidistance bodu k) C17 - APR17 - aproximace diskretni funkce racionalni funkci C18 - APR18 - podprogram volany modulem APR19 C19 - APR19 - podprogram volany modulem APR17 C20 - APR20 - podprogram volany modulem APR17 C21 - APR21 - aproximace diskretni funkce linearni kombinaci m-spojitych funkci C22 - APR22 - vypocet hodnot Cebysevovych polynomu radu 0-N C23 - APR23 - vypocet hodnoty rozvoje Cebysevovych polynomu C24 - APR24 - vypocet hodnot posunutych Cebysevovych polynomu radu 0-N C25 - APR25 - vypocet hodnoty rozvoje posunutych Cebysevovych polynomu C26 - APR26 - vypocet hodnot Hermiteovych polynomu radu 0-N C27 - APR27 - vypocet hodnoty rozvoje Hermiteovych polynomu C28 - APR28 - vypocet hodnot Lagrangeovych polynomu radu 0-N C29 - APR29 - vypocet hodnoty rozvoje Lagrangeovych polynomu C30 - APR30 - vypocet hodnot Legendreovych polynomu radu 0-N C31 - APR31 - vypocet hodnoty rozvoje Legendreovych polynomu C32 - APR32 - transformace rozvoje Cebysevovych polynomu do polynomu C33 - APR33 - transformace rozvoje posunutych Cebysevovych polynomu do polynomu C34 - APR34 - transformace rozvoje Hermiteovych polynomu do polynomu C35 - APR35 - transformace rozvoje Lagrangeovych polynomu do polynomu C36 - APR36 - transformace rozvoje Legendreovych polynomu do polynomu C01 - MTX1 - zmena zpusobu ukladani ctvercove matice C02 - MTX2 - aplikace funkce na kazdy prvek matice C03 - MTX3 - soucet dvou matic C04 - MTX4 - rozdil dvou matic C05 - MTX5 - soucin dvou matic C06 - MTX6 - transpozice matice C07 - MTX7 - transpozice matice a nasobeni druhou matici C08 - MTX8 - nasobeni matice svou transpozici C09 - MTX9 - inverze matice C10 - MTX10 - inverze symetricke pozitivne definitni matice C11 - MTX11 - faktorizace matice C12 - MTX12 - faktorizace symetricke pozitivne definitni matice C13 - MTX13 - vypocet hodnosti matice, urceni indexu bazickych radku a sloupcu C14 - MTX14 - vypocet hodnosti sym. poz. semidef. matice, faktorizace submatice max. hodnosti (prvni krok modulu MTX15) C15 - MTX15 - reseni systemu linearnich rovnic s faktorizovanou submatici max. hodnosti (druhy krok modulu MTX14) C16 - MTX16 - reseni systemu linearnich rovniv C17 - MTX17 - reseni systemu simultanich linearnich rovnic C18 - MTX18 - reseni systemu simultanich linearnich rovnic se symetrickou matici C19 - MTX19 - reseni preurceneho systemu simultannich linearnich rovnic C20 - MTX20 - redukce matice do horniho skoro-triangularniho tvaru C21 - MTX21 - vypocet vlastnich cisel skoro-triangularni matice C22 - MTX22 - vypocet vlastnich cisel a vektoru symetricke matice C23 - MTX23 - podprogram volany modulem MTX6 C24 - MTX24 - podprogram volany modulem MTX1,MTX2,MTX3,MTX4,MTX5,MTX7,MTX8,MTX23 C01 - STS1 - tabelace cetnosti, prumeru, smerodatne odchylky, minima a maxima pozorovane promenne C02 - STS2 - dtto STS1 (dve pozorovane promenne, dvourozmerne cetnosti) C03 - STS3 - vypocet strednich hodnot, smerodatnych odhylek, korelacnich koeficientu C04 - STS4 - vypocet strednich hodnot, smerodatnych odhylek, sikmosti a spicatosti, korelacnich a regresnich koeficientu C05 - STS5 - vypocet kanonickych korelaci mezi dvemi mnozinami promennych C06 - STS6 - podprogram volany modulem STS5 C07 - STS7 - podprogram volany modulem STS5 C08 - STS8 - vypocet biserialniho korelacniho koeficientu mezi dvemi spojitymi promennymi C09 - STS9 - vypocet bodove biserialniho korelacniho koeficientu mezi binarni a spojitou promennou C10 - STS10 - test korelaci mezi dvema promennymi (Kendalluv koeficient) C11 - STS11 - test korelaci mezi dvema promennymi (Spearmanuv koeficient) C12 - STS12 - podprogram volany modulem STS10,STS11 C13 - STS13 - podprogram volany modulem STS10,STS11 C14 - STS14 - test rozdilu mezi empirickym a teoretickym rozdelenim (K-S test) C15 - STS15 - test rozdilu mezi dvemi empirickymi distribucnimi funkcemi (K-S test) C16 - STS16 - podprogram volany modulem STS14,STS15 C17 - STS17 - vypocet distribucni funkce (gama rozdeleni) C18 - STS18 - vypocet hustoty pravdepodobnosti a distribucni funkce (beta rozdeleni) C19 - STS19 - vypocet hustoty pravdepodobnosti a distribucni funkce (chi-kvadrat rozdeleni) C20 - STS20 - podprogram volany modulem STS18,STS19 C21 - STS21 - vypocet hustoty pravdepodobnosti a distribucni funkce (normalni rozdeleni N(0,1)) C22 - STS22 - vypocet hustoty pravdepodobnosti a inverze distribucni funkce (normalni rozdeleni N(0,1)) C23 - STS23 - generator nahodnych cisel (normalni rozdeleni) C24 - STS24 - generator nahodnych cisel (rovnomerne rozdeleni) C25 - STS25 - vhodne rozmisteni dat pro vypocet faktoroveho experimentu C26 - STS26 - vypocet faktoroveho experimentu uzitim operatoru sigma a delta C27 - STS27 - vypocet souctu ctvercu odchylek, strednich kvadratickych odchylek C28 - STS28 - vypocet kumulativnich procentnich podilu vlastnich cisel symetricke matice C29 - STS29 - vypocet faktorove matice dle vlastnich cisel a vektoru symetricke matice C30 - STS30 - ortogonalni rotace faktorove matice C31 - STS31 - urceni autokovarianci rady C32 - STS32 - urceni vzajemnych kovarianci dvou rad C33 - STS33 - vyrovnani resp. filtrace rady C34 - STS34 - trojite exponencialni vyrovnani rady C01 C CALL MAT1(X,N,Y,P,IER) C X - argument funkce (I) C N - rad funkce (I) C Y - funkcni hodnota (O) C P - pozadovana presnost (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N - zaporne C IER=2 X - nekladne C IER=3 nebylo dosazeno pozadovane presnosti C IER=4 N - nesplnuje podminky (viz pozn.) C pozn. N - musi lezet v intervalech: <0,20+10*X-X**2/3) pro X.LE.15 C <0,90+X/2) pro X.GT.15 C lit. 'Recurrence techniques for calculation of Bessel functions' C (Goldstein,Thaler) M.T.A.C. vol 13 C 'Generation of Bessel functions on high speed computers' C (Stegun,Abramowitz) M.T.A.C. vol 11 1957 C02 C CALL MAT2(X,N,Y,IER) C X - argument funkce (I) C N - rad funkce (I) C Y - funkcni hodnota (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N - zaporne C IER=2 X - nekladne C IER=3 velmi mala hodnota X (preteceni) C lit. 'Polynomial approximations to Bessel functions of order zero and one C and to related functions' C (Hitchcock) M.T.A.C. vol 11 1957 C 'A treatise on the theory of Bessel functions' C (Watson) Cambridge university press 1958 C03 C CALL MAT3(X,N,Z,Y) C X - argument funkci (I) C N - max. rad funkci (I) C Z - funkcni hodnota mod. Bess. funkce radu 0 (I) (viz MAT4) C Y - vektor funkcnich hodnot radu 1-N (O) C lit. 'Numerical evaluation of continued fractions' C (Blanch) Siam review vol 6 1964 C04 C CALL MAT4(X,Y) C X - argument funkce (I) C Y - funkcni hodnota (O) C lit. 'Handbook of mathematics functions' (Abramowitz,Stegun) C National bureau of standards applied mathematics series 1966 C05 C CALL MAT5(X,N,Y,IER) C X - argument funkce (I) C N - rad funkce (I) C Y - funkcni hodnota (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N - zaporne C IER=2 X - nekladne C IER=3 X > 170 (preteceni) C IER=4 Y > 10**38 C lit. 'Polynomial approximations to Bessel functions of order zero and one C and to related functions' C (Hitchcock) M.T.A.C. vol 11 1957 C 'A treatise on the theory of Bessel functions' C (Watson) Cambridge university press 1958 C06 C CALL MAT6(YS,YC,YD,X,S) C YS - funkcni hodnota funkce SN (O) C YC - funkcni hodnota funkce CN (O) C YD - funkcni hodnota funkce DN (O) C X - argument funkci (I) C S - druha mocnina doplnkoveho modulu (I) C lit. 'Numerical calculation of elliptic integrals and elliptic functions' C (Bulirsh) Numerische mathematik vol 7 1965 C07 C | C EXTERNAL FCT C | C CALL MAT7(FCT,N,X,FMIN,GRAD,ODH,EPS,LIM,IER,P) C | C END C SUBROUTINE FCT(N,VX,Y,VG) C | C FCT - uzivavatelem dodany podprogram (I) C N - pocet promennych funkce (I) C VX - vektor argumentu (I) C Y - funkcni hodnota (O) C VG - gradient funkce v bode VX (O) C N - pocet promennych funkce (I) C X - startovaci vektor argumentu (I) C vektor argumentu v nemz funkce nabyva minima (O) C FMIN - minimum funkce (O) C GRAD - gradient funkce v bode X (O) C ODH - odhad minima funkce (I) C EPS - hodnota ocekavane chyby (doporucuje se 10**(-6)) (I) C LIM - max. pocet iteraci (I) C IER - chybovy kod (O) C IER=0 uloha konverguje C IER=1 uloha nekonverguje v limitu iteraci C IER=-1 chyba pri vypoctu gradientu C IER=2 pravdepodobne neexistuje minimum funkce C P - pracovni vektor dimense 2*N (I) C lit. 'Function minimization by conjugate gradients' C (Fletcher,Reeves) Computer journal vol 7 1964 C08 C | C EXTERNAL FCT C | C CALL MAT8(FCT,N,X,FMIN,GRAD,ODH,EPS,LIM,IER,P) C | C END C SUBROUTINE FCT(N,VX,Y,VG) C | C FCT - uzivavatelem dodany podprogram (I) C N - pocet promennych funkce (I) C VX - vektor argumentu (I) C Y - funkcni hodnota (O) C VG - gradient funkce v bode VX (O) C N - pocet promennych funkce (I) C X - startovaci vektor argumentu (I) C vektor argumentu v nemz funkce nabyva minima (O) C FMIN - minimum funkce (O) C GRAD - gradient funkce v bode X (O) C ODH - odhad minima funkce (I) C EPS - hodnota ocekavane chyby (doporucuje se 10**(-6)) (I) C LIM - max. pocet iteraci (I) C IER - chybovy kod (O) C IER=0 uloha konverguje C IER=1 uloha nekonverguje v limitu iteraci C IER=-1 chyba pri vypoctu gradientu C IER=2 pravdepodobne neexistuje minimum funkce C P - pracovni vektor dimense N*(N+7)/2 (I) C lit. 'A rapid descent method for minimization' C (Fletcher,Powell) Computer journal vol 6 1963 C09 C | C EXTERNAL FCT C | C CALL MAT9(X,H,IH,FCT,Z) C | C END C FUNCTION FCT(T) C | C X - argument funkce (I) C H - horni resp. dolni mez intervalu resp. (I) C IH - parametr (I) C IH=0 vnitrni hodnota HI je nastavena na hodnotu H C IH=1 vnitrni hodnota HI se generuje v podprogramu C FCT - uzivatelem dodana funkce (I) C T - argument funkce (I) C Z - hodnota derivace funkce v bode X (O) C pozn. T - musi lezet v intervalu resp. C vypocet je zalozen na extrapolacni metode aplikovane na posloupnost C delenych rozdilu mezi body X a X+(K*HI)/10 K=1,...,10 C lit. 'Altes und neues zur numerischen differentiation' C (Fillipi,Engels) Elektronische datenverarbeitung 1966 C10 C | C EXTERNAL FCT C | C CALL MAT10(X,H,IH,FCT,Z) C | C END C FUNCTION FCT(T) C | C X - argument funkce (I) C H - horni resp. dolni mez intervalu resp. (I) C IH - parametr (I) C IH=0 vnitrni hodnota HI je nastavena na hodnotu H C IH=1 vnitrni hodnota HI se generuje v podprogramu C FCT - uzivatelem dodana funkce (I) C T - argument funkce (I) C Z - hodnota derivace funkce v bode X (O) C pozn. T - musi lezet v intervalu resp. C vypocet je zalozen na extrapolacni metode aplikovane na posloupnost C delenych rozdilu mezi body X-(K*HI)/5 a X+(K*HI)/5 K=1,...,5 C lit. 'Altes und neues zur numerischen differentiation' C (Fillipi,Engels) Elektronische datenverarbeitung 1966 C11 C | C EXTERNAL FCT C | C CALL MAT11(XD,XH,EPS,N,FCT,Y,IER,P) C | C END C FUNCTION FCT(X) C | C XD - dolni mez integralu (I) C XH - horni mez integralu (I) C EPS - horni mez absolutni chyby (I) C N - dimense vektoru P (I) C FCT - uzivatelem dodana funkce (I) C X - argument funkce (I) C Y - hodnota integralu (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=2 nebylo mozne kontrolovat presnost z duvodu male hodnoty N C P - pracovni vektor (I) C pozn. N - max. pocet puleni intervalu (XD,XH) C lit. 'Das verfahren von Romberg-Stiefel-Bauer als spezial des allgemeinen C prinzips von Richardson' C (Fillipi) Mathematik-Technik-Wirtschaft vol 11 1964 C12 C CALL MAT12(YC,YS,X) C YC - hodnota integralu funkce cos(t)/sqrt(t) na (0,X) (O) C YS - hodnota integralu funkce sin(t)/sqrt(t) na (0,X) (O) C X - argument integralni funkce (I) C lit. 'Computation of Fresnel integrals by Boersma' C Mathematical tables and other aids to computation vol 14 1960 C13 C CALL MAT13(Y,RK,IER) C Y - hodnota integralu funkce C C 1/sqrt((1+t**2)*(1+(UK*t)**2)) na (0,inf) (O) C RK - modul (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 RK nelezi v intervalu (-1,1) C pozn. (RK**2)+(UK**2)=1C UK - uplny modul C lit. 'Numerical calculation of elliptic integrals and elliptic functions' C (Bulirsh) Numerische mathematik vol 7 1965 C14 C CALL MAT14(Y,RK,A,B,IER) C Y - hodnota integralu funkce C (A+B*t**2)/sqrt((1+t**2)*(1+(UK*t)**2)*(1+t**2)) na (0,inf) (O) C RK - modul (I) C A - viz dtto (I) C B - viz dtto (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 RK nelezi v intervalu (-1,1) C pozn. (RK**2)+(UK**2)=1C UK - uplny modul C lit. 'Numerical calculation of elliptic integrals and elliptic functions' C (Bulirsh) Numerische mathematik vol 7 1965 C15 C CALL MAT15(Y,X,UK) C Y - hodnota integralu funkce C 1/sqrt((1+t**2)*(1+(UK*t)**2)) na (0,X) (O) C UK - uplny modul (I) C lit. 'Numerical calculation of elliptic integrals and elliptic functions' C (Bulirsh) Numerische mathematik vol 7 1965 C16 C CALL MAT16(Y,X,UK,A,B) C Y - hodnota integralu funkce C (A+B*t**2)/sqrt((1+t**2)*(1+(UK*t)**2)*(1+t**2)) na (0,X) (O) C UK - uplny modul (I) C A - viz dtto (I) C B - viz dtto (I) C lit. 'Numerical calculation of elliptic integrals and elliptic functions' C (Bulirsh) Numerische mathematik vol 7 1965 C17 C CALL MAT17(X,Y,P) C X - argument integralni funkce (I) C Y - hodnota integralu funkce exp(-t)/t na (x,inf) (O) C P - pracovni hodnota (O) C pozn. pro X > 170 resp. X < -170 muze dojit k podteceni resp. preteceni C18 C CALL MAT18(YS,YC,X) C YS - hodnota integralu funkce sin(t)/t na (0,X) (O) C YC - hodnota integralu funkce cos(t)/t na (x,inf) (O) C X - argument integralni funkce (I) C lit. 'Polynomial approximations to integral transforms' (Luke,Wimp) C Mathematical tables and other aids to computation vol 15 1961 C19 C | C EXTERNAL FCT C | C CALL MAT19(XD,XH,FCT,Y) C | C END C FUNCTION FCT(X) C | C XD - dolni mez integralu (I) C XH - horni mez integralu (I) C FCT - uzivatelem dodana funkce (I) C X - argument funkce (I) C Y - hodnota integralu funkce FCT(X) na (XD,XH) (O) C pozn. vypocet bude presny, pokud FCT bude polynom nejvyse stupne 19 (*63) C lit. 'Approximate calculation of integrals' C (Krylov) McMillan New York/London 1962 C20 C | C EXTERNAL FCT C | C CALL MAT20(FCT,Y) C | C END C FUNCTION FCT(X) C | C FCT - uzivatelem dodana funkce (I) C X - argument funkce (I) C Y - hodnota integralu funkce exp(-X)*FCT(X) na (0,inf) (O) C pozn. vypocet bude presny, pokud FCT bude polynom nejvyse stupne 19 (*63) C lit. 'Approximate calculation of integrals' C (Krylov) McMillan New York/London 1962 C21 C | C EXTERNAL FCT C | C CALL MAT21(FCT,Y) C | C END C FUNCTION FCT(X) C | C FCT - uzivatelem dodana funkce (I) C X - argument funkce (I) C Y - hodnota integralu funkce exp(-X*X)*FCT(X) na (-inf,inf) (O) C pozn. vypocet bude presny, pokud FCT bude polynom nejvyse stupne 19 (*127) C lit. 'Approximate calculation of integrals' C (Krylov) McMillan New York/London 1962 C22 C | C EXTERNAL FCT C | C CALL MAT22(FCT,Y) C | C END C FUNCTION FCT(X) C | C FCT - uzivatelem dodana funkce (I) C X - argument funkce (I) C Y - hodnota integralu funkce exp(-X)*FCT(X)/sqrt(X) na (0,inf) (O) C pozn. vypocet bude presny, pokud FCT bude polynom nejvyse stupne 19 (*63) C lit. 'Tables for the evalution of integral by Gauss-Laguerre quadrature' C (Consus,Cassatt,Jaehnig,Melby) M.T.A.C. vol 17 1963 C23 C | C EXTERNAL FCT C | C CALL MAT23(FCT,H,XP,YP,XK,YK,XV,YV,IER) C | C END C FUNCTION FCT(X,Y) C | C FCT - uzivatelem dodana funkce (viz pozn.1) (I) C X - nezavisle promenna (I) C Y - zavisle promenna (I) C H - prirustek nezavisle promenne (I) C XP - pocatecni hodnota nezavisle promenne (I) C YP - pocatecni hodnota zavisle promenne (I) C XK - konecna hodnota nezavisle promenne (I) C YK - konecna hodnota zavisle promenne (I) C XV - vysledna hodnota nezavisle promenne (O) C YV - vysledna hodnota zavisle promenne (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 H=0 C pozn. uloha nalezne reseni pro konecnou hodnotu X C pozn.1 FCT - pocita hodnotu prave strany rovnice C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York 1956 C24 C | C EXTERNAL FCT C | C CALL MAT24(FCT,H,XP,YP,K,N,V) C | C END C FUNCTION FCT(X,Y) C | C FCT - uzivatelem dodana funkce (viz pozn.1) (I) C X - nezavisle promenna (I) C Y - zavisle promenna (I) C H - prirustek nezavisle promenne (I) C XP - pocatecni hodnota nezavisle promenne (I) C YP - pocatecni hodnota zavisle promenne (I) C K - parametr (viz pozn.2) (I) C N - dimense vektoru V (I) C V - vektor hodnot zavisle promenne (O) C pozn. uloha nalezne reseni v N-bodech zadaneho intervalu C pozn.1 FCT - pocita hodnotu prave strany rovnice C pozn.2 hodnoty zavisle promenne se urcuji vzdy po kroku K*H C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York 1956 C25 C | C EXTERNAL FCT,OUT C | C CALL MAT25(V,Y,Z,N,IH,FCT,OUT,P) C | C END C SUBROUTINE FCT(X,Y,Z) C | C END C SUBROUTINE OUT(X,Y,Z,IH,N,V) C | C V - vektor dimense vetsi nebo rovne 5 (viz pozn.4) C V(1) - dolni mez intervalu (I) C V(2) - horni mez intervalu (I) C V(3) - pocatecni prirustek nezavisle promenne (I) C V(4) - horni mez absolutni chyby (viz pozn.1) (I) C V(5) - priznak ukonceni ulohy (viz pozn.2) C V(5)=0 neukoncit (nastaveno automaticky) C V(5)=1 ukoncit C Y - vektor pocatecnich funkcnich hodnot (I) C vektor funkcnich hodnot v bode X (viz pozn.3) (O) C Z - vektor vah chyb (Z(1)+...+Z(N)=1) (I) C vektor hodnot derivaci v bode X (viz pozn.3) (O) C N - pocet rovnic systemu (I) C IH - pocet puleni prirustku V(3) (O) C IH=11 uloha ukoncena z duvodu IH>10 C IH=12 uloha ukoncena z duvodu V(3)=0 C IH=13 uloha ukoncena z duvodu sign(V(3)).ne.sign(V(2)-V(1)) C FCT - uzivatelem dodany podprogram (viz pozn.3) (I) C OUT - uzivatelem dodany podprogram (viz pozn.3) (I) C X - nezavisle promenna (I) C P - pracovni matice dimense 16,N (I) C pozn.1 jestlize je chyba vetsi nez V(4), prirustek je pulen C jestlize je chyba mensi nez V(4)/50, prirustek je zdvojen C uzivatel muze menit hodnotu V(4) v podprogramu OUT C pozn.2 uzivatel muze menit hodnotu V(5) v podprogramu OUT C pozn.3 FCT - pocita hodnoty pravych stran systemu v bode X a vektoru Y C OUT - nesmi menit zadne parametry (krome V(4),V(5),...) C X - probiha (formou prirustku) cely interval , C pro jednotlive hodnoty se vola podprogram OUT C pozn.4 MAT25 - vyuziva pouze prvky V(1),...,V(5), ostatni prvky muze C uzivatel pouzit pro svou potrebu v podprogramu OUT C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C 'Runge-Kutta methods with minimum error bounds' C (Ralston) M.T.A.C. vol 16 1962 C26 C | C EXTERNAL AFCT,HFCT,OUT C | C CALL MAT26(V,Y,Z,N,IH,AFCT,HFCT,OUT,P1,P2) C | C END C SUBROUTINE AFCT(X,A) C | C END C SUBROUTINE HFCT(X,H) C | C END C SUBROUTINE OUT(X,Y,Z,IH,N,V) C | C V - vektor dimense vetsi nebo rovne 5 (viz pozn.4) C V(1) - dolni mez intervalu (I) C V(2) - horni mez intervalu (I) C V(3) - pocatecni prirustek nezavisle promenne (I) C V(4) - horni mez absolutni chyby (viz pozn.1) (I) C V(5) - priznak ukonceni ulohy (viz pozn.2) C V(5)=0 neukoncit (nastaveno automaticky) C V(5)=1 ukoncit C Y - vektor pocatecnich funkcnich hodnot (I) C vektor funkcnich hodnot v bode X (viz pozn.3) (O) C Z - vektor vah chyb (Z(1)+...+Z(N)=1) (I) C vektor hodnot derivaci v bode X (viz pozn.3) (O) C N - pocet rovnic systemu (I) C IH - pocet puleni prirustku V(3) (O) C IH=11 uloha ukoncena z duvodu IH>10 C IH=12 uloha ukoncena z duvodu V(3)=0 C IH=13 uloha ukoncena z duvodu sign(V(3)).ne.sign(V(2)-V(1)) C AFCT - uzivatelem dodany podprogram (viz pozn.3) (I) C HFCT - uzivatelem dodany podprogram (viz pozn.3) (I) C OUT - uzivatelem dodany podprogram (viz pozn.3) (I) C X - nezavisle promenna (I) C P1 - pracovni matice dimense 16,N (I) C P2 - pracovni vektor dimense N*N (I) C pozn.1 jestlize je chyba vetsi nez V(4), prirustek je pulen C jestlize je chyba mensi nez V(4)/50, prirustek je zdvojen C uzivatel muze menit hodnotu V(4) v podprogramu OUT C pozn.2 uzivatel muze menit hodnotu V(5) v podprogramu OUT C pozn.3 AFCT - pocita hodnoty matice A prave strany systemu v bode X C HFCT - pocita hodnoty vektoru H prave strany systemu v bode X C OUT - nesmi menit zadne parametry (krome V(4),V(5),...) C X - probiha (formou prirustku) cely interval , C pro jednotlive hodnoty se vola podprogram OUT C pozn.4 MAT26 - vyuziva pouze prvky V(1),...,V(5), ostatni prvky muze C uzivatel pouzit pro svou potrebu v podprogramu OUT C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C 'Runge-Kutta methods with minimum error bounds' C (Ralston) M.T.A.C. vol 16 1962 C27 C | C EXTERNAL FCT,OUT C | C CALL MAT27(V,Y,Z,N,IH,FCT,OUT,P) C | C END C SUBROUTINE FCT(X,Y,Z) C | C END C SUBROUTINE OUT(X,Y,Z,IH,N,V) C | C V - vektor dimense vetsi nebo rovne 5 (viz pozn.4) C V(1) - dolni mez intervalu (I) C V(2) - horni mez intervalu (I) C V(3) - pocatecni prirustek nezavisle promenne (I) C V(4) - horni mez absolutni chyby (viz pozn.1) (I) C V(5) - priznak ukonceni ulohy (viz pozn.2) C V(5)=0 neukoncit (nastaveno automaticky) C V(5)=1 ukoncit C Y - vektor pocatecnich funkcnich hodnot (I) C vektor funkcnich hodnot v bode X (viz pozn.3) (O) C Z - vektor vah chyb (Z(1)+...+Z(N)=1) (I) C vektor hodnot derivaci v bode X (viz pozn.3) (O) C N - pocet rovnic systemu (I) C IH - pocet puleni prirustku V(3) (O) C IH=11 uloha ukoncena z duvodu IH>10 C IH=12 uloha ukoncena z duvodu V(3)=0 C IH=13 uloha ukoncena z duvodu sign(V(3)).ne.sign(V(2)-V(1)) C FCT - uzivatelem dodany podprogram (viz pozn.3) (I) C OUT - uzivatelem dodany podprogram (viz pozn.3) (I) C X - nezavisle promenna (I) C P - pracovni matice dimense 8,N (I) C pozn.1 jestlize je chyba vetsi nez V(4), prirustek je pulen C jestlize je chyba mensi nez V(4)/50, prirustek je zdvojen C uzivatel muze menit hodnotu V(4) v podprogramu OUT C pozn.2 uzivatel muze menit hodnotu V(5) v podprogramu OUT C pozn.3 FCT - pocita hodnoty pravych stran systemu v bode X a vektoru Y C OUT - nesmi menit zadne parametry (krome V(4),V(5),...) C X - probiha (formou prirustku) cely interval , C pro jednotlive hodnoty se vola podprogram OUT C pozn.4 MAT27 - vyuziva pouze prvky V(1),...,V(5), ostatni prvky muze C uzivatel pouzit pro svou potrebu v podprogramu OUT C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C28 C | C EXTERNAL AFCT,HFCT,DFCT,OUT C | C CALL MAT28(V,B,C,R,Y,Z,N,IH,AFCT,HFCT,DFCT,OUT,P1,P2) C | C END C SUBROUTINE AFCT(X,A) C | C END C SUBROUTINE HFCT(X,H) C | C END C SUBROUTINE DFCT(X,D) C | C END C SUBROUTINE OUT(X,Y,Z,IH,N,V) C | C V - vektor dimense vetsi nebo rovne 5 (viz pozn.4) C V(1) - dolni mez intervalu (I) C V(2) - horni mez intervalu (I) C V(3) - pocatecni prirustek nezavisle promenne (I) C V(4) - horni mez absolutni chyby (viz pozn.1) (I) C V(5) - priznak ukonceni ulohy (viz pozn.2) C V(5)=0 neukoncit (nastaveno automaticky) C V(5)=1 ukoncit C B - vektor obsahujici matici dimense N,N (viz pozn.5) (I) C C - vektor obsahujici matici dimense N,N (viz pozn.5) (I) C R - vektor dimense N (viz pozn.5) (I) C Y - vektor funkcnich hodnot v bode X (viz pozn.3) (O) C Z - vektor vah chyb (Z(1)+...+Z(N)=1) (I) C vektor hodnot derivaci v bode X (viz pozn.3) (O) C N - pocet rovnic systemu (I) C IH - pocet puleni prirustku V(3) (O) C IH=11 uloha ukoncena z duvodu IH>10 C IH=12 uloha ukoncena z duvodu V(3)=0 C IH=13 uloha ukoncena z duvodu sign(V(3)).ne.sign(V(2)-V(1)) C IH=14 uloha ukoncena z duvodu neexistence jednoznacneho reseni C IH<0 ztrata signifikance pri reseni systemu simultanich lin.rovnic C resicich problem pocatecnich hodnot (abs(IH)-cislo posledniho C kroku Gaussova eliminacniho algoritmu, v kterem jeste C nenastala ztrata signifikance) C AFCT - uzivatelem dodany podprogram (viz pozn.3) (I) C HFCT - uzivatelem dodany podprogram (viz pozn.3) (I) C DFCT - uzivatelem dodany podprogram (viz pozn.3) (I) C OUT - uzivatelem dodany podprogram (viz pozn.3) (I) C X - nezavisle promenna (I) C P1 - pracovni matice dimense 20,N (I) C P2 - pracovni vektor dimense N*N (I) C pozn.1 jestlize je chyba vetsi nez V(4), prirustek je pulen C jestlize je chyba mensi nez V(4)/50, prirustek je zdvojen C uzivatel muze menit hodnotu V(4) v podprogramu OUT C pozn.2 uzivatel muze menit hodnotu V(5) v podprogramu OUT C pozn.3 AFCT - pocita hodnoty matice A prave strany systemu v bode X C HFCT - pocita hodnoty vektoru H prave strany systemu v bode X C DFCT - pocita hodnoty vektoru D prave strany systemu v bode X C (D - vektor derivaci vektoru H) C OUT - nesmi menit zadne parametry (krome V(4),V(5),...) C X - probiha (formou prirustku) cely interval , C pro jednotlive hodnoty se vola podprogram OUT C pozn.4 MAT28 - vyuziva pouze prvky V(1),...,V(5), ostatni prvky muze C uzivatel pouzit pro svou potrebu v podprogramu OUT C pozn.5 B * Y(V(1)) + C * Y(V(2)) = RC (lin.okrajove podminky) C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C 'Runge-Kutta methods with minimum error bounds' C (Ralston) M.T.A.C. vol 16 1962 C 'Numerical methods for high speed computers' C (Lance) Iliffe London 1960 C30 C | C EXTERNAL FCT C | C CALL MAT30(X,Y,FCT,XD,XH,EPS,LIM,IER) C | C END C FUNCTION FCT(X) C | C X - koren rovnice (O) C Y - funkcni hodnota korenu X (O) C FCT - uzivatelem dodana funkce (I) C XD - pocatecni dolni mez korenu (I) C XH - pocatecni horni mez korenu (I) C EPS - horni mez chyby (I) C LIM - max. pocet iteraci (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha nekonverguje v limitu iteraci C IER=2 FCT(XD)*FCT(XH).GT.0 C lit. 'Zero of arbitrary function' C (Kristiansen) Bit vol 3 1963 C31 C | C EXTERNAL FCT C | C CALL MAT31(X,Y,Z,FCT,ODH,EPS,LIM,IER) C | C END C SUBROUTINE FCT(X,Y,Z) C | C X - koren rovnice (O) C Y - funkcni hodnota korenu X (O) C Z - hodnota derivace v korenu X (O) C FCT - uzivatelem dodany podprogram (viz pozn.) (I) C ODH - pocatecni odhad korenu X (I) C EPS - horni mez chyby (I) C LIM - max. pocet iteraci (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha nekonverguje v limitu iteraci C IER=2 v nejake iteraci nastalo Z=0 C pozn. FCT - pocita funkcni hodnotu a hodnotu derivace v bode X C lit. 'Praktishe mathematik feur ingenieure und physiker' C (Zurmuehl) Springer Berlin/Goettingen/Heidelberg 1963 C32 C | C EXTERNAL FCT C | C CALL MAT32(X,Y,FCT,ODH,EPS,LIM,IER) C | C END C FUNCTION FCT(X) C | C X - koren rovnice (O) C Y - funkcni hodnota korenu X (O) C FCT - uzivatelem dodana funkce (I) C ODH - pocatecni odhad korenu X (I) C EPS - horni mez chyby (I) C LIM - max. pocet iteraci (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha nekonverguje v limitu iteraci C IER=2 v nejake iteraci byl jmenovatel iteracniho vzorce nulovy C lit. 'Numerical methods for high speed computers' C (Lance) Iliffe London 1960 C 'Algorithm 2' C (Wegsteain) C.A.C.M vol 3 1960 C33 C | C EXTERNAL FCT C | C CALL MAT33(FCT,N,M,A,B,IER) C | C END C FUNCTION FCT(X) C | C FCT - uzivatelem dodana funkce (I) C N - urci interval jako 2*N+1 bodu v rozmezi 0-2pi (I) C M - max. rad harmonickych (I) C A - vektor Fourierovych koeficientu kosinu dimense M+1 (O) C B - vektor Fourierovych koeficientu sinu dimense M+1 (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N < M C IER=2 M < 0 C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C34 C CALL MAT34(Y,N,M,A,B,IER) C Y - vektor funkcnich hodnot dimense 2*N+1 (I) C N - urci interval jako 2*N+1 bodu v rozmezi 0-2pi (I) C M - max. rad harmonickych (I) C A - vektor Fourierovych koeficientu kosinu dimense M+1 (O) C B - vektor Fourierovych koeficientu sinu dimense M+1 (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N < M C IER=2 M < 0 C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) Wiley New York/London 1960 C35 C CALL MAT35(Y,N,YLIM,EPS,IER) C Y - vektor prvku poslupnosti (I) C N - dimense vektoru Y (I) C YLIM - limita posloupnosti (O) C EPS - horni mez chyby (viz pozn.) (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=-1 N < 10 C pozn. relativni (abs(Y(I)).GT.1 I=1,...,N) C absolutni (abs(Y(I)).LT.1 I=1,...,N) C lit. 'Singular rules for certain non-linear algorithms' C (Wynn) Bit vol 3 1963 C36 C | C EXTERNAL FCT C | C CALL MAT36(FCT,S,N,EPS,IER) C | C END C FUNCTION FCT(K) C | C FCT - uzivatelem dodana funkce (viz pozn.) (I) C K - index clenu rady (I) C S - soucet rady (O) C N - max. pocet clenu rady respektovanych pri vypoctu (I) C EPS - horni mez relativni chyby (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=-1 N < 1 C pozn. FCT - pocita hodnotu K-teho clenu rady (K=1,...,inf) C01 C C SUBROUTINE MAT1(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 C02 C C SUBROUTINE MAT2(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 C PERFORM 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.0E38)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 C03 C C SUBROUTINE MAT3(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 C04 C C SUBROUTINE MAT4(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 C05 C C SUBROUTINE MAT5(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.0E38)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 C06 C C SUBROUTINE MAT6(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 C07 C SUBROUTINE MAT7(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 ARGUMEN 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 REDUC 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 C 45 IF(GNRM-EPS)46,46,25 46 IER=0 47 RETURN END C08 C SUBROUTINE MAT8(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 ARGUMEN 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 REDUC 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 C09 C C SUBROUTINE MAT9(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.E38 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.E38 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 C10 C C SUBROUTINE MAT10(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.E38 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.E38 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 C11 C C SUBROUTINE MAT11(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 C12 C C SUBROUTINE MAT12(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 C13 C C SUBROUTINE MAT13(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.E38 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 C14 C C SUBROUTINE MAT14(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.E38 RETURN 4 RES=1.E38 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 C15 C SUBROUTINE MAT15(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 C16 C SUBROUTINE MAT16(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 C17 C SUBROUTINE MAT17(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.E38 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 C18 C C SUBROUTINE MAT18(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.E38 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 C19 C C SUBROUTINE MAT19(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 C20 C C SUBROUTINE MAT20(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 C21 C C SUBROUTINE MAT21(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 C22 C C SUBROUTINE MAT22(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 C23 C C SUBROUTINE MAT23(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER) 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 C24 C C SUBROUTINE MAT24(FUN,H,XI,YI,K,N,VEC) 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 C25 C C C SUBROUTINE MAT25(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 MAT55 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 C26 C C SUBROUTINE MAT26(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) C C C THE FOLLOWING FIRST PART OF SUBROUTINE MAT56 (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 MAT56 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 MAT56 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 C27 C C SUBROUTINE MAT27(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) DO 1 I=1,NDIM 1 AUX(8,I)=.06666667*DERY(I) X=PRMT(1) XEND=PRMT(2) H=PRMT(3) PRMT(5)=0. 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)=.5 A(2)=.2928932 A(3)=1.707107 A(4)=.1666667 B(1)=2. B(2)=1. B(3)=1. B(4)=2. C(1)=.5 C(2)=.2928932 C(3)=1.707107 C(4)=.5 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. 3 AUX(6,I)=0. 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+.5*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=.5*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. DO 24 I=1,NDIM 24 DELT=DELT+AUX(8,I)*ABS(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-.02*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 C28 C C SUBROUTINE MAT28(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 MAT58 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 MAT29(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 MAT58 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 C29 C C SUBROUTINE MAT29(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 C30 C C SUBROUTINE MAT30(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 INTERPOLATIO 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 C31 C C SUBROUTINE MAT31(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 C32 C C SUBROUTINE MAT32(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 C33 C C SUBROUTINE MAT33(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 C34 C C SUBROUTINE MAT34(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 C35 C C SUBROUTINE MAT35(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 C36 C C SUBROUTINE MAT36(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 C01 C CALL PLM1(Z,NZ,X,NX,Y,NY) C Z - vektor koeficientu vysledneho polynomu (O) C NZ - dimense vektoru Z (O) C X - vektor koeficientu prvniho polynomu (I) C NX - dimense vektoru X (I) C Y - vektor koeficientu druheho polynomu (I) C NY - dimense vektoru Y (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C02 C CALL PLM2(Z,NZ,X,NX,Y,NY) C Z - vektor koeficientu vysledneho polynomu (O) C NZ - dimense vektoru Z (O) C X - vektor koeficientu prvniho polynomu (I) C NX - dimense vektoru X (I) C Y - vektor koeficientu druheho polynomu (I) C NY - dimense vektoru Y (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C03 C CALL PLM3(Z,NZ,X,NX,Y,NY) C Z - vektor koeficientu vysledneho polynomu (O) C NZ - dimense vektoru Z (O) C X - vektor koeficientu prvniho polynomu (I) C NX - dimense vektoru X (I) C Y - vektor koeficientu druheho polynomu (I) C NY - dimense vektoru Y (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C04 C CALL PLM4(Z,NZ,X,NX,Y,NY,EPS,IER) C Z - vektor koeficientu polynomu P (viz pozn.) (O) C NZ - dimense vektoru Z (O) C X - vektor koeficientu deleneho polynomu PX (I) C vektor koeficientu polynomu Q (viz pozn.) (O) C NX - dimense vektoru X (I/O) C Y - vektor koeficientu deliciho polynomu PY (I) C NY - dimense vektoru Y (I) C EPS - hodnota tolerance, pod kterou jsou koeficienty polynomu C eliminovany behem normalizace (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nulovy delitel C pozn. PX = PY * P + QC (NX.GE.NY) C koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C06 C CALL PLM6(X,NX,Y,NY,P,EPS,IER) C X - vektor koeficientu prvniho polynomu (I) C NX - dimense vektoru X (I) C Y - vektor koeficientu druheho polynomu (I) C vektor koeficientu N.S.D (O) C NY - dimense vektoru Y (I/O) C P - pracovni vektor dimense NX-NY+1 (I) C EPS - hodnota tolerance, pod kterou jsou koeficienty polynomu C eliminovany behem normalizace (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 prvni nebo druhy polynom je nulovy C pozn. NX.GT.NY C koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C07 C CALL PLM7(Z,NZ,X,NX,Y,NY,P1,P2) C Z - vektor koeficientu vysledneho polynomu PZ (O) C NZ - dimense vektoru Z (O) C X - vektor koeficientu substituovaneho polynomu PX (I) C NX - dimense vektoru X (I) C Y - vektor koeficientu substituujiciho polynomu PY (I) C NY - dimense vektoru Y (I) C P1 - pracovni vektor dimense NZ (I) C P2 - pracovni vektor dimense NZ (I) C pozn. PZ(x) = PX(PY(x)) C koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C10 C CALL PLM10(V,P,N,R,C,IER) C V - vektor koeficientu polynomu (I) C P - pracovni vektor dimense N+1 (I) C N - stupen polynomu (I) C R - vektor realnych casti korenu dimense N (O) C C - vektor imaginarnich casti korenu dimense N (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 N < 1 C IER=2 N > 36 C IER=3 uloha nekonverguje C IER=4 V(N+1) = 0 C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C11 C CALL PLM11(V,N,R,C,W,M,IER) C V - vektor koeficientu polynomu (I) C N - dimense vektoru V (I) C R - vektor realnych casti korenu dimense N (viz pozn.1) (O) C C - vektor imaginarnich casti korenu dimense N (viz pozn.1) (O) C W - vektor koeficientu polynomu po vypoctu korenu dimense N (O) C M - pocet vypoctenych korenu (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha nekonverguje C IER=2 nulovy nebo konstantni polynom C IER=3 vypocet prerusen z duvodu deleni nulou C IER=4 neexistuje S-zlomek C IER=-1 mala presnost vypoctenych korenu C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C pozn.1 R(i) - i-ta real. cast korenu (i=1,...,M) C C(i) - i-ta imag. cast korenu (i=1,...,M) C R(M+1) - obsahuje max. relativni chybu porovnani vektoru V a W, C pouze kdyz M+1=N C lit. 'Der quotienten-differenzen-algorithmus' C (Rutishauser) Birkhaeuser Basel/Stuttgart 1957 C12 C CALL PLM12(P,X,V,N) C P - hodnota polynomu (O) C X - argument polynomu (I) C V - vektor koeficientu polynomu (I) C N - dimense vektoru V (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C13 C CALL PLM13(P,DP,X,V,N) C P - hodnota polynomu (O) C DP - hodnota derivace (O) C X - argument polynomu (I) C V - vektor koeficientu polynomu (I) C N - dimense vektoru V (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C15 C CALL PLM15(X,NX,Y,NY) C X - vektor koeficientu derivace polynomu (O) C NX - dimense vektoru X (O) C Y - vektor koeficientu polynomu (I) C NY - dimense vektoru Y (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C16 C CALL PLM16(X,NX,Y,NY) C X - vektor koeficientu primitivni funkce polynomu (O) C NX - dimense vektoru X (O) C Y - vektor koeficientu polynomu (I) C NY - dimense vektoru Y (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C17 C CALL PLM17(V,N,C,EPS,TOL,P) C V - vektor koeficientu polynomu (I) C vektor koeficientu zekonomizovaneho polynomu (O) C N - dimense vektoru V (I/O) C C - (viz pozn.1) (I) C EPS - pocatecni mez chyby (I) C konecna mez chyby (O) C TOL - tolerance chyby (I) C P - pracovni vektor dimense N (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C pozn.1 ekonomizovany polynom musi byt definovan prave na intervalu (0,C), C pokud je definovan na intervalu (a,b), musi byt provedena C substituce t=(x-a) (viz PLM19) C lit. 'Algorithm 37, Telescope 1' C (Brons) C.A.C.M. vol 4 1961 C18 C CALL PLM18(V,N,C,EPS,TOL,P) C V - vektor koeficientu polynomu (I) C vektor koeficientu zekonomizovaneho polynomu (O) C N - dimense vektoru V (I/O) C C - (viz pozn.1) (I) C EPS - pocatecni mez chyby (I) C konecna mez chyby (O) C TOL - tolerance chyby (I) C P - pracovni vektor dimense N (I) C pozn. koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C pozn.1 ekonomizovany polynom musi byt definovan prave na intervalu C (-C,C), pokud je definovan na intervalu (a,b), musi byt provedena C substituce t=(x-(b-a)/2) (viz PLM19) C lit. 'Algorithm 38, Telescope 2' C (Brons) C.A.C.M. vol 4 1961 C19 C CALL PLM19(X,NX,A) C X - vektor koeficientu polynomu P (viz pozn.) (I) C vektor koeficientu polynomu Q (viz pozn.) (O) C NX - dimense vektoru X (I/O) C A - (viz pozn.) (I) C pozn. Q(x) = P(x-A) C koeficienty polynomu jsou serazeny smerem od 0-te mocniny k C (N-1)-te mocnine (N - dimense vektoru koeficientu polynomu) C01 C C SUBROUTINE PLM1(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 C02 C C SUBROUTINE PLM2(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 C03 C C SUBROUTINE PLM3(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 C04 C C SUBROUTINE PLM4(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER) DIMENSION P(1),X(1),Y(1) C CALL PLM5(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 PLM5(X,IDIMX,TOL) GO TO 30 END C05 C C SUBROUTINE PLM5(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 C06 C C SUBROUTINE PLM6(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 PLM4(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 C07 C C SUBROUTINE PLM7(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 PLM3(WORK2,IW2,Y,IDIMY,WORK1,IW1) CALL PLM9(WORK1,IW1,WORK2,IW2) FACT=X(I) CALL PLM8(Z,IDIMR,Z,IDIMZ,FACT,WORK1,IW1) IDIMZ=IDIMR 5 CONTINUE GO TO 2 END C08 C C SUBROUTINE PLM8(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 C09 C C SUBROUTINE PLM9(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 C10 C C SUBROUTINE PLM10(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 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 C11 C C SUBROUTINE PLM11(C,IC,Q,E,POL,IR,IER) C C DIMENSIONED DUMMY VARIABLES DIMENSION E(1),Q(1),C(1),POL(1) C C NORMALIZATION OF GIVEN POLYNOMIAL C TEST OF DIMENSION C IR CONTAINS INDEX OF HIGHEST COEFFICIENT IER=0 IR=IC EPS=1.E-6 TOL=1.E-3 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./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. E(ISTA)=0. 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. Q(ISTA)=0. 10 NSAV=IR C C COMPUTATION OF DERIVATIVE 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 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(ABS(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(ABS(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(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) 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. NRAN=NSAV-1 22 E(NRAN+1)=0. 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. 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. 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(E(NRAN)) C C TEST FOR CONVERGENCE IF(R-TEPS)30,30,33 33 S=ABS(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. 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(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 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.5*(Q(NRAN)+E(NRAN)+Q(NRAN+1)) O=P*P-Q(NRAN)*Q(NRAN+1) T=SQRT(ABS(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(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 C C THREEFOLD LOOP FOR COMPLEX DISPLACEMENT DO 53 J=JBEG,NRAN O=Q(J+1)+E(J+1)-U-P C C TEST FOR SMALL DIVISOR 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 C C TEST FOR SMALL DIVISOR 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 C C TEST FOR SMALL DIVISOR 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 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. 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 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. 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. 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 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 C12 C C SUBROUTINE PLM12(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 C13 C C SUBROUTINE PLM13(POLY,DVAL,ARGUM,X,IDIMX) DIMENSION X(1) C P=ARGUM+ARGUM Q=-ARGUM*ARGUM C CALL PLM14(DVAL,POLY,P,Q,X,IDIMX) C POLY=ARGUM*DVAL+POLY C RETURN END C14 C C SUBROUTINE PLM14(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 C15 C C SUBROUTINE PLM15(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 C16 C C SUBROUTINE PLM16(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 C17 C C SUBROUTINE PLM17(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 C18 C C SUBROUTINE PLM18(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 C19 C C SUBROUTINE PLM19(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 C01 C CALL APR1(X,VX,VY,Y,N,EPS,IER) C X - argument funkce (I) C VX - vektor argumentu funkce (I) C VY - vektor funkcnich hodnot (I) C Y - vyrovnana funkcni hodnota v bode X (O) C N - dimense vektoru VX,VY (I) C EPS - horni mez absolutni chyby (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=2 nebylo mozne kontrolovat presnost z duvodu male hodnoty N C IER=3 vektor VX obsahuje dve stejne hodnoty C pozn. vektor VX musi byt usporadan vzhledem k X tak, aby G byla C neklesajici funkce (G(k)=abs(VX(k)-X)) (viz APR4,APR5,APR6) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C02 C CALL APR2(X,VX,VY,Y,N,EPS,IER) C X - argument funkce (I) C VX - vektor argumentu funkce (I) C VY - vektor funkcnich hodnot (I) C Y - vyrovnana funkcni hodnota v bode X (O) C N - dimense vektoru VX,VY (I) C EPS - horni mez absolutni chyby (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=2 nebylo mozne kontrolovat presnost z duvodu male hodnoty N C IER=3 vektor VX obsahuje dve stejne hodnoty C pozn. vektor VX musi byt usporadan vzhledem k X tak, aby G byla C neklesajici funkce (G(k)=abs(VX(k)-X)) (viz APR4,APR5,APR6) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C03 C CALL APR3(X,VX,VY,Y,N,EPS,IER) C X - argument funkce (I) C VX - vektor argumentu funkce (I) C VY - vektor funkcnich hodnot a hodnot derivaci (viz pozn.1) (I) C Y - vyrovnana funkcni hodnota v bode X (O) C N - dimense vektoru VX (I) C EPS - horni mez absolutni chyby (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 nebylo dosazeno pozadovane presnosti C IER=2 nebylo mozne kontrolovat presnost z duvodu male hodnoty N C IER=3 vektor VX obsahuje dve stejne hodnoty C pozn. vektor VX musi byt usporadan vzhledem k X tak, aby G byla C neklesajici funkce (G(k)=abs(VX(k)-X)) (viz APR4,APR5,APR6) C pozn.1 kazda funkcni hodnota je nasledovana hodnotou derivace C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C04 C CALL APR4(X,VXI,A,P,K,L,VX,VY,N) C X - viz APR1,APR2,APR3 (I) C VXI - vektor argumentu funkce (I) C A - vektor obsahujici matici dimense K,L (I) C L=1 A(1) - vektor funkcnich hodnot C L=2 A(1) - vektor funkcnich hodnot C A(2) - vektor hodnot derivaci C P - pracovni vektor (I) C K - dimense vektoru VXI,A(1),A(2),P (I) C L - pocet sloupcu matice A (I) C VX - vektor vybrannych a usporadanych argumentu funkce (O) C VY - vektor funkcnich hodnot a pripadne hodnot derivaci (viz APR3) (O) C N - dimense vektoru VX (I) C pozn. tento modul slouzi pro upravu vstupu modulu APR1,APR2,APR3 C05 C CALL APR5(X,XI,H,A,K,L,VX,VY,N) C X - viz APR1,APR2,APR3 (I) C XI - pocatecni hodnota argumentu funkce (I) C H - prirustek argumentu (I) C A - vektor obsahujici matici dimense K,L (I) C L=1 A(1) - vektor funkcnich hodnot C L=2 A(1) - vektor funkcnich hodnot C A(2) - vektor hodnot derivaci C K - dimense vektoru VXI,A(1),A(2) (I) C L - pocet sloupcu matice A (I) C VX - vektor vybrannych a usporadanych argumentu funkce (O) C VY - vektor funkcnich hodnot a pripadne hodnot derivaci (viz APR3) (O) C N - dimense vektoru VX (I) C pozn. tento modul slouzi pro upravu vstupu modulu APR1,APR2,APR3 C06 C CALL APR6(X,VXI,A,K,L,VX,VY,N) C X - viz APR1,APR2,APR3 (I) C VXI - vektor argumentu funkce (viz pozn.1) (I) C A - vektor obsahujici matici dimense K,L (I) C L=1 A(1) - vektor funkcnich hodnot C L=2 A(1) - vektor funkcnich hodnot C A(2) - vektor hodnot derivaci C K - dimense vektoru VXI,A(1),A(2) (I) C L - pocet sloupcu matice A (I) C VX - vektor vybrannych a usporadanych argumentu funkce (O) C VY - vektor funkcnich hodnot a pripadne hodnot derivaci (viz APR3) (O) C N - dimense vektoru VX (I) C pozn. tento modul slouzi pro upravu vstupu modulu APR1,APR2,APR3 C pozn.1 prvky vektoru VXI musi tvorit monotonni posloupnost C07 C CALL APR7(X,Y,Z,N,IER) C X - vektor argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Z - vektor vyrovnanych funkcnich hodnot (O) C N - dimense vektoru X,Y,Z (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 N < 3 C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C08 C CALL APR8(Y,Z,N,IER) C Y - vektor funkcnich hodnot (I) C Z - vektor vyrovnanych funkcnich hodnot (O) C N - dimense vektoru X,Y,Z (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 N < 3 C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C09 C CALL APR9(X,Y,Z,N,IER) C X - vektor argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Z - vektor hodnot derivaci (O) C N - dimense vektoru X,Y,Z (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 N < 3 C IER>0 X(IER)=X(IER-1).OR.X(IER)=X(IER-2) C pozn. IER=-1,2,3 vypocet neprobehl C IER=4,...,N byly vypocteny hodnoty Z(1),...,Z(IER-1) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C10 C CALL APR10(H,Y,Z,N,IER) C H - prirustek argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Z - vektor hodnot derivaci (O) C N - dimense vektoru X,Y,Z (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 N < 3 C IER=1 H = 0 C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C11 C CALL APR11(X,Y,Z,N) C X - vektor argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru X,Y,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C12 C CALL APR12(H,Y,Z,N) C H - prirustek argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru Y,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C13 C CALL APR13(X,Y,Y1,Z,N) C X - vektor argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Y1 - vektor hodnot prvnich derivaci (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru X,Y,Y1,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C 'Praktische mathematik feur ingenieure und physiker' C (Zurmuehl) Springer Berlin/Goettingen/Heidelberg 1963 C14 C CALL APR14(H,Y,Y1,Z,N) C H - prirustek argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Y1 - vektor hodnot prvnich derivaci (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru Y,Y1,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Introduction to numerical analysis' C (Hildebrand) McGraw-Hill New York/Toronto/London 1956 C 'Praktische mathematik feur ingenieure und physiker' C (Zurmuehl) Springer Berlin/Goettingen/Heidelberg 1963 C15 C CALL APR15(X,Y,Y1,Y2,Z,N) C X - vektor argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Y1 - vektor hodnot prvnich derivaci (I) C Y2 - vektor hodnot druhych derivaci (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru X,Y,Y1,Y2,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Praktische mathematik feur ingenieure und physiker' C (Zurmuehl) Springer Berlin/Goettingen/Heidelberg 1963 C16 C CALL APR16(H,Y,Y1,Y2,Z,N) C H - prirustek argumentu funkce (I) C Y - vektor funkcnich hodnot (I) C Y1 - vektor hodnot prvnich derivaci (I) C Y2 - vektor hodnot druhych derivaci (I) C Z - vektor urcitych integralu (viz pozn.) (O) C N - dimense vektoru Y,Y1,Y2,Z (I) C pozn. integraly jsou pocitany na intervalech (X(1),X(2)),...,(X(1),X(N)) C (Z(1) = 0) C lit. 'Praktische mathematik feur ingenieure und physiker' C (Zurmuehl) Springer Berlin/Goettingen/Heidelberg 1963 C17 C CALL APR17(A,N,VH,VK,NP,NQ,IER) C A - vektor obsahujici matici dimense N,3 (I) C A(1) - vektor argumentu funkce C A(2) - vektor funkcnich hodnot C A(3) - vektor vah (viz pozn.2) C N - dimense vektoru A(1),A(2),A(3) (I) C VH - pracovni vektor dimense N*N+5*N+1 (I) C vektor hodnot P(A(i,1)) a Q(A(i,1)) (viz pozn.1) (O) C VK - vektor koeficientu rozvoje P,Q (viz pozn.1) (I/O) C NP - pocet clenu rozvoje P (I) C NQ - pocet clenu rozvoje Q (I) C IER - hodnota indikujici existenci pocatecni aproximace ve vektoru VK (I) C IER=0 neexistence C IER=1 existence C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 formalni chyba C IER=1,2 uloha nekonverguje C pozn. hledana racionalni funkce ma tvar R(x)=P(x)/Q(x) (NP+NQ.LE.N) C P,Q - rozvoje Cebysevovych polynomu, proto argumenty musi byt C linearni transformaci redukovany na interval (-1,1) C pozn.1 VH(N+i)=P(A(i,1)) , VH(2*N+i)=Q(A(i,1)) (i=1,...,N) C VK(i) - i-ty koeficient rozvoje Q (i=1,...,NQ) C VK(NQ+i) - i-ty koeficient rozvoje P (i=1,...,NP) C pozn.2 vahy nemusi byt zadany, pouze prvni prvek vektoru A(3) C musi obsahovat nekladnou hodnotu C lit. 'Ueber daempfung bei minimalisierungsverfaren' C (Braess) Computing vol 1 1966 C 'An algorithm for least-squares estimation of nonlinear parameters' C (Marquardt) J.S.I.A.M. vol 11 1963 C21 C | C EXTERNAL FCT C | C CALL APR21(FCT,N,M,VH,IP,VK,P,NI,IER) C | C END C SUBROUTINE FCT(Y,X,K) C | C FCT - uzivatelem dodany podprogram (viz pozn.) (I) C Y - vektor funkcnich hodnot uzitych M-funkci v X (O) C X - argument uzitych M-funkci (I) C K - hodnota M-1 (I) C N - pocet argumentu diskretni funkce (I) C M - pocet spojitych funkci konstruujicich aproximaci (I) C VH - vektor funkcnich hodnot a argumentu diskret. funkce (viz pozn.1) (I) C vektor chyb (viz pozn.2) (O) C IP - pracovni vektor dimense 3*M+4*N+6 (I) C VK - pracovni vektor dimense 3*M+6 (I) C vektor koeficientu lin. kombinace uzitych M-funkci (viz pozn.3) (O) C P - pracovni vektor dimense (M+2)**2 (I) C NI - pocet dosazenych iteraci (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 pocet iteraci presahl hodnotu M+N C IER=-1 pri nektere iteraci nebyl nalezen pivotujici prvek C chybne hodnoty M nebo N C pozn. na misto FCT lze pouzit moduly APR22,APR24,APR26,APR28,APR30 C pozn.1 VH - vektor dimense 3*N C VH(i) - i-ta funkcni hodnota (i=1,...,N) C VH(N+i) - i-ty argument funkcne (i=1,...,N) C pozn.2 VH(i) - chyba v i-tem argumentu (i=1,...,N) C pozn.3 VK(i) - i-ty koeficient (i=1,...,M) C lit. 'Algorithms for best L-sub-one and L-sub-infinity, C linear approximations on a discrete set' C (Barrodale,Young) Numerische mathematik vol 8 1966 C22 C CALL APR22(Y,X,N) C Y - vektor hodnot polynomu (viz pozn.) (O) C X - argument polynomu (I) C N - rad polynomu (I) C pozn. Y(i) - hodnota polynomu radu i-1 (i=1,...N+1) C23 C CALL APR23(Y,X,V,N) C Y - hodnota rozvoje (O) C X - argument rozvoje (I) C V - vektor koeficientu rozvoje (viz pozn.) (I) C N - dimense vektoru V (I) C pozn. V(i) - koeficient i-teho clenu rozvoje (i=1,...,N) C24 C CALL APR24(Y,X,N) C Y - vektor hodnot polynomu (viz pozn.) (O) C X - argument polynomu (I) C N - rad polynomu (I) C pozn. Y(i) - hodnota polynomu radu i-1 (i=1,...N+1) C25 C CALL APR25(Y,X,V,N) C Y - hodnota rozvoje (O) C X - argument rozvoje (I) C V - vektor koeficientu rozvoje (viz pozn.) (I) C N - dimense vektoru V (I) C pozn. V(i) - koeficient i-teho clenu rozvoje (i=1,...,N) C26 C CALL APR26(Y,X,N) C Y - vektor hodnot polynomu (viz pozn.) (O) C X - argument polynomu (I) C N - rad polynomu (I) C pozn. Y(i) - hodnota polynomu radu i-1 (i=1,...N+1) C27 C CALL APR27(Y,X,V,N) C Y - hodnota rozvoje (O) C X - argument rozvoje (I) C V - vektor koeficientu rozvoje (viz pozn.) (I) C N - dimense vektoru V (I) C pozn. V(i) - koeficient i-teho clenu rozvoje (i=1,...,N) C28 C CALL APR28(Y,X,N) C Y - vektor hodnot polynomu (viz pozn.) (O) C X - argument polynomu (I) C N - rad polynomu (I) C pozn. Y(i) - hodnota polynomu radu i-1 (i=1,...N+1) C29 C CALL APR29(Y,X,V,N) C Y - hodnota rozvoje (O) C X - argument rozvoje (I) C V - vektor koeficientu rozvoje (viz pozn.) (I) C N - dimense vektoru V (I) C pozn. V(i) - koeficient i-teho clenu rozvoje (i=1,...,N) C30 C CALL APR30(Y,X,N) C Y - vektor hodnot polynomu (viz pozn.) (O) C X - argument polynomu (I) C N - rad polynomu (I) C pozn. Y(i) - hodnota polynomu radu i-1 (i=1,...N+1) C31 C CALL APR31(Y,X,V,N) C Y - hodnota rozvoje (O) C X - argument rozvoje (I) C V - vektor koeficientu rozvoje (viz pozn.) (I) C N - dimense vektoru V (I) C pozn. V(i) - koeficient i-teho clenu rozvoje (i=1,...,N) C32 C CALL APR32(A,B,VK,N,V,P) C A - viz pozn. (I) C B - viz pozn. (I) C VK - vektor koeficientu polynomu (viz pozn.1) (O) C N - dimense vektoru VK,V (I) C V - vektor koeficientu rozvoje (viz pozn.1) (I) C P - pracovni vektor dimense 2*N (I) C pozn. transformace z=1/A*(x-B) transformuje interval (-1,1) C na interval (a,b) C ( A=2/(b-a) , B=-(b+a)/(b-a) ) C pozn.1 V(i) - koeficient i-teho clenu rozvoje C VK(i) - i-ty koeficient polynomu (i=1,...,N) C33 C CALL APR33(A,B,VK,N,V,P) C A - viz pozn. (I) C B - viz pozn. (I) C VK - vektor koeficientu polynomu (viz pozn.1) (O) C N - dimense vektoru VK,V (I) C V - vektor koeficientu rozvoje (viz pozn.1) (I) C P - pracovni vektor dimense 2*N (I) C pozn. transformace z=1/A*(x-B) transformuje interval (0,1) C na interval (a,b) C ( A=1/(b-a) , B=-a/(b-a) ) C pozn.1 V(i) - koeficient i-teho clenu rozvoje C VK(i) - i-ty koeficient polynomu (i=1,...,N) C34 C CALL APR34(A,B,VK,N,V,P) C A - viz pozn. (I) C B - viz pozn. (I) C VK - vektor koeficientu polynomu (viz pozn.1) (O) C N - dimense vektoru VK,V (I) C V - vektor koeficientu rozvoje (viz pozn.1) (I) C P - pracovni vektor dimense 2*N (I) C pozn. transformace z=1/A*(x-B) transformuje interval (-c,c) C na interval (a,b) C ( A=2*c/(b-a) , B=-c*(b+a)/(b-a) ) C pozn.1 V(i) - koeficient i-teho clenu rozvoje C VK(i) - i-ty koeficient polynomu (i=1,...,N) C35 C CALL APR35(A,B,VK,N,V,P) C A - viz pozn. (I) C B - viz pozn. (I) C VK - vektor koeficientu polynomu (viz pozn.1) (O) C N - dimense vektoru VK,V (I) C V - vektor koeficientu rozvoje (viz pozn.1) (I) C P - pracovni vektor dimense 2*N (I) C pozn. transformace z=1/A*(x-B) transformuje interval (0,c) C na interval (a,b) C ( A=c/(b-a) , B=-c*a/(b-a) ) C pozn.1 V(i) - koeficient i-teho clenu rozvoje C VK(i) - i-ty koeficient polynomu (i=1,...,N) C36 C CALL APR36(A,B,VK,N,V,P) C A - viz pozn. (I) C B - viz pozn. (I) C VK - vektor koeficientu polynomu (viz pozn.1) (O) C N - dimense vektoru VK,V (I) C V - vektor koeficientu rozvoje (viz pozn.1) (I) C P - pracovni vektor dimense 2*N (I) C pozn. transformace z=1/A*(x-B) transformuje interval (-1,1) C na interval (a,b) C ( A=2/(b-a) , B=-(b+a)/(b-a) ) C pozn.1 V(i) - koeficient i-teho clenu rozvoje C VK(i) - i-ty koeficient polynomu (i=1,...,N) C01 C C SUBROUTINE APR1(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.E38 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.E38 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 C02 C C SUBROUTINE APR2(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 C03 C C SUBROUTINE APR3(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 C04 C C SUBROUTINE APR4(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 C05 C C SUBROUTINE APR5(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 C06 C C SUBROUTINE APR6(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 C07 C C SUBROUTINE APR7(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 C08 C C SUBROUTINE APR8(Y,Z,NDIM,IER) C C DIMENSION Y(1),Z(1) C C TEST OF DIMENSION IF(NDIM-3)3,1,1 C C PREPARE LOOP 1 B=.1666667*(5.*Y(1)+Y(2)+Y(2)-Y(3)) C=.1666667*(5.*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2)) C C START LOOP DO 2 I=3,NDIM A=B B=.3333333*(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 C09 C C SUBROUTINE APR9(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 C10 C C SUBROUTINE APR10(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 C11 C C SUBROUTINE APR11(X,Y,Z,NDIM) C C DIMENSION X(1),Y(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=SUM2+.5*(X(I)-X(I-1))*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END C12 C C SUBROUTINE APR12(H,Y,Z,NDIM) C C DIMENSION Y(1),Z(1) C SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*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 C13 C C SUBROUTINE APR13(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 C14 C C SUBROUTINE APR14(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 C15 C C SUBROUTINE APR15(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 C16 C C SUBROUTINE APR16(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 C17 C C SUBROUTINE APR17(DATI,N,WORK,P,IP,IQ,IER) C C EXTERNAL APR18 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 APR23(WORK(I),T,P(IQP1),IP) K=I+N 9 CALL APR23(WORK(K),T,P,IQ) C C SET UP NORMAL EQUATIONS (MAIN LOOP OF ITERATION) 10 CALL APR19(APR18,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 APR20(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 APR23(WORK(I),T,WORK(K),IRP) M=L+N CALL APR23(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 C18 C C SUBROUTINE APR18(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 APR22(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 C19 C C SUBROUTINE APR19(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 C20 C C SUBROUTINE APR20(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 C21 C C SUBROUTINE APR21(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 P 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 C22 C C SUBROUTINE APR22(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 C23 C C SUBROUTINE APR23(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 C24 C C SUBROUTINE APR24(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 C25 C C SUBROUTINE APR25(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 C26 C C SUBROUTINE APR26(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 C27 C C SUBROUTINE APR27(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 C28 C C SUBROUTINE APR28(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 C29 C C SUBROUTINE APR29(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 C30 C C SUBROUTINE APR30(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 C31 C C SUBROUTINE APR31(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 C32 C C SUBROUTINE APR32(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 C33 C C SUBROUTINE APR33(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 C34 C C SUBROUTINE APR34(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 C35 C C SUBROUTINE APR35(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 C36 C C SUBROUTINE APR36(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 C01 C CALL MTX1(A,B,N,MODA,MODB) C A - vstupni matice (I) C B - vysledna matice (O) C N - rad vstupni matice (I) C MODA - mod ulozeni vstupni matice (I) C MODA=0 obecna C MODA=1 symetricka C MODA=2 diagonalni C MODB - mod ulozeni vysledne matice (I) C MODB=0 obecna C MODB=1 symetricka C MODB=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C MODA MODB C 0 0 A presunuta do B C 0 1 horni trojuhelnik A presunut do B C 0 2 diagonala A presunuta do B C 1 0 A presunuta do horniho i spodniho trojuhelniku B C 1 1 A presunuta do B C 1 2 diagonala A presunuta do B C 2 0 A presunuta do diagonaly B (zbytek doplnen nulami) C 2 1 A presunuta do diagonaly B (zbytek doplnen nulami) C 2 2 A presunuta do B C02 C | C EXTERNAL FCT C | C CALL MTX2(A,FCT,B,N,M,MOD) C | C END C FUNCTION FCT C | C A - vstupni matice (I) C FCT - standardni funkce fortranu resp. uzivatelem dodana funkce (I) C X - prvek vstupni matice (I) C B - vysledna matice (O) C N - pocet radku vstupni matice (I) C M - pocet sloupcu vstupni matice (I) C MOD - mod ulozeni vstupni matice (I) C MOD=0 obecna C MOD=1 symetricka C MOD=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C03 C CALL MTX3(A,B,C,N,M,MODA,MODB) C A - prvni matice (I) C B - druha matice (I) C C - vysledna matice (O) C N - pocet radku prvni a druhe matice (I) C M - pocet sloupcu prvni a druhe matice (I) C MODA - mod ulozeni prvni matice (I) C MODA=0 obecna C MODA=1 symetricka C MODA=2 diagonalni C MODB - mod ulozeni druhe matice (I) C MODB=0 obecna C MODB=1 symetricka C MODB=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C04 C CALL MTX4(A,B,C,N,M,MODA,MODB) C A - prvni matice (I) C B - druha matice (I) C C - vysledna matice (O) C N - pocet radku prvni a druhe matice (I) C M - pocet sloupcu prvni a druhe matice (I) C MODA - mod ulozeni prvni matice (I) C MODA=0 obecna C MODA=1 symetricka C MODA=2 diagonalni C MODB - mod ulozeni druhe matice (I) C MODB=0 obecna C MODB=1 symetricka C MODB=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C05 C CALL MTX5(A,B,C,N,L,MODA,MODB,M) C A - prvni matice (I) C B - druha matice (I) C C - vysledna matice (O) C N - pocet radku prvni matice (I) C L - pocet sloupcu prvni matice a radku druhe matice (I) C MODA - mod ulozeni prvni matice (I) C MODA=0 obecna C MODA=1 symetricka C MODA=2 diagonalni C MODB - mod ulozeni druhe matice (I) C MODB=0 obecna C MODB=1 symetricka C MODB=2 diagonalni C M - pocet sloupcu druhe matice (I) C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C06 C CALL MTX6(A,B,N,M,MOD) C A - vstupni matice (I) C B - vysledna matice (O) C N - pocet radku vstupni matice (I) C M - pocet sloupcu vstupni matice (I) C MOD - mod ulozeni vstupni matice (I) C MOD=0 obecna C MOD=1 symetricka C MOD=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C07 C CALL MTX7(A,B,C,L,N,MODA,MODB,M) C A - prvni matice (I) C B - druha matice (I) C C - vysledna matice (O) C N - pocet sloupcu prvni matice (I) C L - pocet radku prvni a druhe matice (I) C MODA - mod ulozeni prvni matice (I) C MODA=0 obecna C MODA=1 symetricka C MODA=2 diagonalni C MODB - mod ulozeni druhe matice (I) C MODB=0 obecna C MODB=1 symetricka C MODB=2 diagonalni C M - pocet sloupcu druhe matice (I) C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C08 C CALL MTX8(A,B,N,M,MOD) C A - vstupni matice (I) C B - vysledna matice (O) C N - pocet radku vstupni matice (I) C M - pocet sloupcu vstupni matice (I) C MOD - mod ulozeni vstupni matice (I) C MOD=0 obecna C MOD=1 symetricka C MOD=2 diagonalni C pozn. v hlavnim programu musi dimense matic odpovidat C svym radum v podprogramu C09 C CALL MTX9(A,N,D,L1,L2) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici vyslednou matici (O) C N - rad vstupni matice (I) C D - determinant vstupni matice (O) C L1 - pracovni vektor dimense N (I) C L2 - pracovni vektor dimense N (I) C10 C CALL MTX10(A,N,EPS,IER) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici vyslednou matici (O) C N - rad vstupni matice (I) C EPS - relativni tolerance testu ztraty signifikance (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 chybne vstupni parametry C IER=K ztrata signifikance (viz pozn.) C pozn.1 pri K+1 kroku faktorizace byl jeste vytvoreny odmocnenec kladny, C ale ne vetsi jak abs(EPS * A(K+1,K+1)) C11 C CALL MTX11(A,P,N,IER) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici vyslednou matici (viz pozn.) (O) C P - vektor permutaci radku vstupni matice dimense N (O) C N - rad vstupni matice (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha zhavarovala C pozn. vysledna matice obsahuje analogicky ulozeny rozklad T'* D * T C T' - dolni trojuhelnik C D - diagonala C T - horni trojuhelnik C lit. 'The algebraic eigenvalue problem' C (Wilkinson) Clarendon press Oxford 1965 C 'Solution of real and complex systems of linear equations' C (Bowdler,Martin,Peters,Wilkinson) Numerische mathematik vol 8 1966 C12 C CALL MTX12(A,N,EPS,IER) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici vyslednou matici (viz pozn.) (O) C N - rad vstupni matice (I) C EPS - relativni tolerance testu ztraty signifikance (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 chybne vstupni parametry C IER=K ztrata signifikance (viz pozn.1) C pozn. vysledna matice obsahuje analogicky ulozeny rozklad D * T C D - diagonala C T - horni trojuhelnik C pozn.1 pri K+1 kroku faktorizace byl jeste vytvoreny odmocnenec kladny, C ale ne vetsi jak abs(EPS * A(K+1,K+1)) C13 C CALL MTX13(A,N,M,EPS,IH,IV,JV) C A - vektor obsahujici vstupni matici (I) C N - pocet radku vstupni matice (I) C M - pocet sloupcu vstupni matice (I) C EPS - hodnota reprezentujici nulu (zaokrouhlovaci chyby) (I) C IH - hodnost vstupni matice (O) C IV - vektor indexu bazickych radku (O) C JV - vektor indexu bazickych sloupcu (O) C14 C CALL MTX14(A,N,EPS,IH,V) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici faktorizaci submatice max. hodnosti (viz pozn.) (O) C N - rad vstupni matice (I) C EPS - hodnota reprezentujici nulu (zaokrouhlovaci chyby) (I) C IH - hodnost vstupni matice (viz pozn.1) (O) C V - vektor indexu pivotujicich radku a sloupcu (viz pozn.) (O) C pozn. vystupni parametry A,IH,V slouzi jako C vstupni parametry modulu MTX15 C pozn.1 IH.LE.0 - chybne vstupni parametry A,N,EPS C15 C CALL MTX15(A,N,IH,V,IP,B,IER) C A - vektor obsahujici faktorizaci matice systemu (viz pozn.) (I) C N - rad matice systemu (I) C IH - hodnost matice systemu (viz pozn.) (I) C V - vektor indexu pivotujicich radku a sloupcu (viz pozn.) (I) C IP - parametr (I) C IP=0 existuje reseni systemu C IP.NE.0 neexistuje reseni systemu (uloha najde priblizne reseni) C B - vektor prave strany systemu (I) C vektor reseni systemu (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 IH > N C IER=1 faktorizace matice systemu obsahuje nulove delitele nebo C V obsahuje hodnoty mimo interval <1,N> C pozn. vstupni parametry A,IH,V ziskame jako C vystupni parametry modulu MTX14 C16 C CALL MTX16(A,F,B,X,N,EPS,IER,V,P) C A - vektor obsahujici matici systemu (I) C F - vektor obsahujici faktorizaci matice systemu (I) C B - vektor pravych stran systemu (I) C X - vektor reseni systemu (O) C N - rad systemu (I) C EPS - relativni presnost (I/O) C IER - chybovy kod (O) C IER=0 vsechny slozky X splnuji EPS C IER=1 pouze norma X splnuje EPS C IER=2 nebylo dosazeno EPS (EPS-modulem zvetseno) (viz pozn.1) C IER=3 reseni nema smysl C IER=4 nulovy prvek na diagonale faktorizace matice systemu C V - pracovni vektor dimense N (I) C P - vektor permutaci radku faktorizace matice systemu dimense N (I) C pozn. F,P - lze urcit pomoci modulu MTX11 C pozn.1 vypocet muzeme zopakovat s novou hodnotou EPS C lit. 'Solution of real and complex systems of linear equations' C (Bowdler,Martin,Peters,Wilkinson) Numerische mathematik vol 8 1966 C17 C CALL MTX17(B,A,N,M,EPS,IER) C B - vektor obsahujici matici pravych stran systemu (I) C vektor obsahujici matici reseni systemu (O) C A - vektor obsahujici matici systemu (I) C N - rad systemu (I) C M - pocet vektoru pravych stran (I) C EPS - relativni tolerance testu ztraty signifikance (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 nulovy pivotujici prvek v nejakem kroku eliminace C IER=K ztrata signifikance (viz pozn.) C pozn. pri K+1 kroku eliminace byl pivotujici prvek mensi nebo roven C hodnote EPS * max{ abs(A(i,j)); i,j=1,...,N } C18 C CALL MTX18(B,A,N,M,EPS,IER,P) C B - vektor obsahujici matici pravych stran systemu (I) C vektor obsahujici matici reseni systemu (O) C A - vektor obsahujici matici systemu (I) C N - rad systemu (I) C M - pocet vektoru pravych stran (I) C EPS - relativni tolerance testu ztraty signifikance (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 nulovy pivotujici prvek v nejakem kroku eliminace C IER=K ztrata signifikance (viz pozn.) C P - pracovni vektor dimense N-1 (I) C pozn. pri K+1 kroku eliminace byl pivotujici prvek mensi nebo roven C hodnote EPS * max{ abs(A(i,i)); i=1,...,N } C19 C CALL MTX19(A,B,M,N,L,X,IP,EPS,IER,P) C A - vektor obsahujici matici systemu (I) C B - vektor obsahujici matici pravych stran systemu (I) C M - pocet radek matice systemu (I) C N - pocet sloupcu matice systemu (I) C L - pocet sloupcu matice pravych stran systemu (I) C X - vektor obsahujici matici reseni systemu (O) C IP - vektor dimense N (viz pozn.) (O) C EPS - relativni tolerance urceni hodnosti matice systemu (I) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 nulova matice systemu C IER=-2 M < N C IER=K K < N (K-hodnost matice systemu) C P - pracovni vektor dimense max{2*N,L} (I) C pozn. IP(K+1),...,IP(N) - indexy nebazickych sloupcu matice systemu C lit. 'Numerical methods for solving linear least squares problems' C (Golub) Numerische mathematik vol 7 1965 C20 C CALL MTX20(N,A) C N - rad vstupni matice (I) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici vyslednou matici (O) C lit. 'The algebraic eigenvalue problem' C (Wilkinson) Clarendon press Oxford 1965 C21 C CALL MTX21(N,A,VR,VI,IN) C N - rad vstupni matice (I) C A - vektor obsahujici vstupni matici (I) C VR - vektor realnych casti vlastnich cisel (O) C VI - vektor imaginarnich casti vlastnich cisel (O) C IN - vektor (dimense N) obsahujici indikace o zpusobu nalezeni C vlastnich cisel (O) C lit. 'The QR transformation' C (Francis) Computer journal vol 4 1961, vol 4 1962 C 'The algebraic eigenvalue problem' C (Wilkinson) Clarendon press Oxford 1965 C22 C CALL MTX22(A,B,N,IC) C A - vektor obsahujici vstupni matici (I) C vektor obsahujici matici jejiz diagonala obsahuje vlastni cisla C serazena sestupne dle velikosti (O) C B - vektor obsahujici matici jejiz sloupce jsou vlastni vektory C v poradi odpovidajicim vlastnim cislum (O) C N - rad vstupni matice (I) C IC - kod (I) C IC=0 vypocet vlastnich cisel a vektoru C IC=1 vypocet vlastnich cisel C lit. 'Mathematical method for digital computers' C (Ralston,Wilf) John Wiley and sons, New York 1962 C01 C C SUBROUTINE MTX1(A,R,N,MSA,MSR) DIMENSION A(1),R(1) 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 MTX24(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 MTX24(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 C02 C C SUBROUTINE MTX2(A,F,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL MTX24(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 C03 C C SUBROUTINE MTX3(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 MTX24(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 MTX24(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL MTX24(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL MTX24(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 C04 C C SUBROUTINE MTX4(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 MTX24(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 MTX24(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL MTX24(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL MTX24(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 C05 C C SUBROUTINE MTX5(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 MTX24(J,I,IA,N,M,MSA) CALL MTX24(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 C06 C C SUBROUTINE MTX6(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 MTX23(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 C07 C C SUBROUTINE MTX7(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 MTX24(I,J,IA,N,M,MSA) CALL MTX24(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 C08 C C SUBROUTINE MTX8(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 70 I=1,N IF(MS) 20,40,20 20 CALL MTX24(I,J,IA,N,M,MS) CALL MTX24(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) 70 CONTINUE 60 CONTINUE RETURN END C09 C C SUBROUTINE MTX9(A,N,D,L,M) DIMENSION A(1),L(1),M(1) 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 C10 C C SUBROUTINE MTX10(A,N,EPS,IER) C C DIMENSION A(1) DOUBLE PRECISION DIN,WORK C C FACTORIZE GIVEN MATRIX BY MEANS OF SUBROUTINE MFSD C A = TRANSPOSE(T) * T CALL MTX12(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/DBLE(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+DBLE(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+DBLE(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 C11 C SUBROUTINE MTX11(A,PER,N,IER) DIMENSION A(1),PER(1) DOUBLE PRECISION DP IA=N 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=1 RETURN END C12 C C SUBROUTINE MTX12(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 C13 C C SUBROUTINE MTX13(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 31 I=KK,N II=II+M MM=II-L A(II)=A(II)-HOLD*A(MM) IF(ABS(A(II))-ABS(PIV))31,31,18 18 PIV=A(II) IR=J IC=I 31 CONTINUE 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 C14 C C SUBROUTINE MTX14(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 C15 C C SUBROUTINE MTX15(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 C16 C C SUBROUTINE MTX16(A,AF,B,X,N,EPSI,IER,V,PER) DIMENSION A(1),AF(1),B(1),X(1),V(1),PER(1) DOUBLE PRECISION DP IA=N C C INITIALIZATION C D0=0. IER=0 ITE=0 DO 10 I=1,N V(I)=B(I) 10 X(I)=0. 20 ITE=ITE+1 C C THE PERMUTATIONS OF ROWS OF A ARE APPLIED TO V C DO 30 I=1,N K=PER(I) IF (K-I)25,30,25 25 D1=V(K) V(K)=V(I) V(I)=D1 30 CONTINUE C C SOLUTION OF THE LOWER TRIANGULAR SYSTEM C DO 50 I=2,N IM1=I-1 DP=V(I) IK=I DO 40 K=1,IM1 DP=DP-1.D0*AF(IK)*V(K) 40 IK=IK+IA 50 V(I)=DP C C SOLUTION OF THE UPPER TRIANGULAR SYSTEM C IF(AF(IK)) 58,54,58 54 IER=4 GO TO 82 58 V(N)=DP/AF(IK) DO 70 I=2,N IM1=N-I+1 INF=IM1+1 DP=V(IM1) IK=(IM1-1)*IA+IM1 D1=AF(IK) DO 60 K=INF,N IK=IK+IA 60 DP=DP-1.D0*AF(IK)*V(K) 70 V(IM1)=DP/D1 C C TEST OF PRECISION C D1=0. D2=0. KLE=0 DO 80 I=1,N D1=D1+ABS(V(I)) D2=D2+ABS(X(I)) IF (ABS(V(I))-EPSI*ABS(X(I))) 80,80,75 75 KLE=1 80 CONTINUE IF (KLE)140,82,85 82 RETURN 85 IF (ITE-1)140,90,87 C C ITERATIONS ARE STOPPED WHEN THE NORM OF THE CORRECTION IS MORE C THAN HALF OF THE ONE OF THE FORMER C 87 IF (D0-2.*D1)120,90,90 90 DO 95 I=1,N 95 X(I)=X(I)+V(I) DO 110 I=1,N DP=B(I) IK=I DO 100 K=1,N DP=DP-1.D0*A(IK)*X(K) 100 IK=IK+IA 110 V(I)=DP D0=D1 GO TO 20 120 IF(ITE-2)140,140,125 125 IF (D1-EPSI*D2)127,127,130 127 IER=1 RETURN 130 IER=2 EPSI=D1/D2 RETURN 140 IER=3 RETURN END C17 C C SUBROUTINE MTX17(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 C18 C C SUBROUTINE MTX18(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 C19 C C SUBROUTINE MTX19(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 C20 C C SUBROUTINE MTX20(N,A) DIMENSION A(1) DOUBLE PRECISION S IA=N 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 C21 C C SUBROUTINE MTX21(M,A,RR,RI,IANA) DIMENSION A(1),RR(1),RI(1),PRR(2),PRI(2),IANA(1) INTEGER P,P1,Q IA=M 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 C22 C SUBROUTINE MTX22(A,R,N,MV) DIMENSION A(1),R(1) 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 C23 C C SUBROUTINE MTX23(A,R,N,M,MS) DIMENSION A(1),R(1) C C COMPUTE VECTOR LENGTH, IT C CALL MTX24(N,M,IT,N,M,MS) C C COPY MATRIX C DO 1 I=1,IT 1 R(I)=A(I) RETURN END C24 C C SUBROUTINE MTX24(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 C01 C CALL STS1(A,B,M,V,C,D,W,N) C A - vektor obsahujici matici pozorovani (dimense N,x) (I) C B - vektor dimense N (I) C B(i)=0 i-ty radek matice pozorovani neni zahrnut do vypoctu C B(i).ne.0 i-ty radek matice pozorovani je zahrnut do vypoctu C M - index sloupce matice pozorovani (tj. vyhodnocovane promenne) (I) C V - vektor dimense 3 (I) C V(1) - dolni mez zvolene promenne C V(2) - pocet intervalu (viz pozn.) C V(3) - horni mez zvolene promenne C C - vektor cetnosti (dimense V(2)) (O) C D - vektor relativnich cetnosti (dimense V(2)) (O) C W - vektor dimense 5 (O) C W(1) - soucet hodnot C W(2) - stredni hodnota C W(3) - smerodatna odchylka C W(4) - minimum C W(5) - maximum C N - pocet pozorovani (I) C pozn. pocet intervalu musi zahrnovat dve polozky pro hodnoty C nad horni a pod dolni mezi promenne C02 C CALL STS2(A,B,M,V,C,D,W1,W2,N) C A - vektor obsahujici matici pozorovani (I) C B - vektor dimense N (I) C B(i)=0 i-ty radek matice pozorovani neni zahrnut do vypoctu C B(i).ne.0 i-ty radek matice pozorovani je zahrnut do vypoctu C M - vektor dimense 2 (I) C M(1) - index sloupce matice pozorovani (tj. 1.vyhodnocovane promenne) C M(2) - index sloupce matice pozorovani (tj. 2.vyhodnocovane promenne) C V - matice dimense 3,2 (I) C V(1,i) - dolni mez zvolene i-te promenne C V(2,i) - pocet intervalu odp. i-te promenne (viz pozn.) C V(3,i) - horni mez zvolene i-te promenne C C - vektor obsahujici matici (dimense V(2,1),V(2,2)) cetnosti C v 2-rozmerne klasifikaci (O) C D - vektor obsahujici matici (dimense V(2,1),V(2,2)) relativnich cetnosti C v 2-rozmerne klasifikaci (O) C W1 - vektor obsahujici matici dimense 3,V(2,1) (O) C W(1,i) - soucet hodnot pro i-ty interval 1. promenne C W(2,i) - stredni hodnota pro i-ty interval 1. promenne C W(3,i) - smerodatna odchylka pro i-ty interval 1. promenne C W2 - vektor obsahujici matici dimense 3,V(2,2) (O) C W(1,i) - soucet hodnot pro i-ty interval 2. promenne C W(2,i) - stredni hodnota pro i-ty interval 2. promenne C W(3,i) - smerodatna odchylka pro i-ty interval 2. promenne C N - pocet pozorovani (I) C pozn. pocet intervalu musi zahrnovat dve polozky pro hodnoty C nad horni a pod dolni mezi promenne C03 C | C CALL STS3(N,M,IDAT,A,V,W,B,C,D,P1,P2) C | C END C SUBROUTINE DATA(M,VD) C | C RETURN C END C N - pocet pozorovani (N.GE.2) (I) C M - pocet promennych (M.GE.1) (I) C IDAT - parametr (I) C IDAT=0 vstupni data vstoupi pomoci podprogramu DATA (viz pozn.) C IDAT=1 vstupni data budou obsazena ve vektoru A C A - vektor obsahujici matici pozorovani (dimense N,M) (I) C V - vektor obsahujici stredni hodnoty (dimense M) (O) C W - vektor obsahujici smerodatne odchylky (dimense M) (O) C B - vektor obsahujici matici dimense M,M (viz pozn.1) (O) C C - vektor obsahujici symetrickou matici korelacnich koeficientu (O) C D - vektor obsahujici diagonalu matice B (O) C P1 - pracovni vektor dimense M (I) C P2 - pracovni vektor dimense M (I) C pozn. DATA - podprogram dodany uzivatelem C VD - vektor pozorovani dimense M (O) C (IDAT=0,tak do A musime zadat 0) C (IDAT=1,tak DATA je prazdny podprogram) C pozn.1 B(i,j)=(A(1,i)-V(i))*(A(1,j)-V(j))+...+(A(N,i)-V(i))*(A(N,j)-V(j)) C (B - obsahuje soucty soucinu odchylek od stredni hodnoty) C04 C CALL STS4(N,M,X,V1,V2,V3,V4,V5,C,IA,A,B,D,IER) C N - pocet pozorovani (I) C M - pocet promennych (I) C X - vektor obsahujici matici pozorovani (dimense N,M) (I) C V1 - vektor kodu chybejicich pozorovani promennych (dimense M) C (viz pozn.1) (I) C V2 - vektor strednich hodnot (dimense M) (O) C V3 - vektor smerodatnych odchylek (dimense M) (O) C V4 - vektor koeficientu sikmosti (dimense M) (O) C V5 - vektor koeficientu spicatosti (dimense M) (O) C C - vektor obsahujici symetrickou matici (dimense M,M) korelacnich C koeficientu (O) C IA - vektor obsahujici symetrickou matici (dimense M,M) poctu dvojic C pozorovani uzitych pri vypoctu korelacnich koeficientu (O) C A - vektor obsahujici matici (dimense M,M) regresnich koeficientu A C (viz pozn.) (O) C B - vektor obsahujici matici (dimense M,M) regresnich koeficientu B C (viz pozn.) (O) C D - vektor obsahujici matici (dimense M,M) strednich kvadratickych C chyb regresnich koeficientu B (viz pozn.) (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 pocet pozorovani snizeny o pocet chybejicich pozorovani C nektere promenne je mensi nebo roven 2 C IER=2 rozptyl nektere promenne je mensi nez 10**(-20) C pozn. regresni primka j-te a i-te promenne : C X(k,j) = A(i,j) + B(i,j)*X(k,i) (k=1,...,N) (i,j=1,...,M) C pozn.1 je-li nektere pozorovani nektere promenne rovno kodu chybejiciho C pozorovani prislusne promenne, neucastni se vypoctu C lit. 'Multivariate procedures for the behavioral sciences' C (Cooley,Lohnes) John Wiley and sons, New York 1962 C05 C CALL STS5(N,MP,MQ,A,V1,V2,V3,V4,V5,B,C,P) C N - pocet pozorovani (I) C MP - pocet levostrannych promennych (I) C MQ - pocet pravostrannych promennych (I) C A - vektor obsahujici symetrickou matici (dimense MQ+MP,MQ+MP) C korelacnich koeficientu (I) C V1 - vektor vlastnich cisel matice korelacnich koeficientu C (dimense MQ) (O) C V2 - vektor hodnot lambda (dimense MQ) (O) C V3 - vektor kanonickych korelaci (dimense MQ) (O) C V4 - vektor hodnot chi-kvadrat (dimense MQ) (O) C V5 - vektor poctu stupnu volnosti odpovidajicim hodnotam chi-kvadrat C (dimense MQ) (O) C B - vektor obsahujici matici (dimense MQ,MQ) jejiz sloupce jsou C pravostranne koeficienty (O) C C - vektor obsahujici matici (dimense MP,MQ) jejiz sloupce jsou C levostranne koeficienty (O) C P - pracovni vektor (dimense (MQ+MP)**2) (I) C pozn. MP musi byt vetsi nebo rovno MQ C lit. 'Multivariate procedures for the behavioral sciences' C (Cooley,Lohnes) John Wiley and sons, New York 1962 C08 C CALL STS8(N,A,B,C,V,IER) C N - dimense vstupnich vektoru (I) C A - vektor hodnot 1. spojite promenne (I) C B - vektor hodnot 2. spojite promenne (dichotomizovane) (I) C C - mez dichotomizace (viz pozn.) (I) C V - vektor dimense 8 (O) C V(1) - stredni hodnota 1. spojite promenne C V(2) - smerodatna odchylka 1. spojite promenne C V(3) - pomerne zastoupeni hodnot 2. spojite promenne ve vyssi urovni C V(4) - pomerne zastoupeni hodnot 2. spojite promenne v nizsi urovni C V(5) - stredni hodnota 1. spojite promenne odp. vyssi urovni C V(6) - stredni hodnota 1. spojite promenne odp. nizsi urovni C V(7) - biserialni korelacni koeficient C V(8) - stredni kvadraticka chyba biserialniho korelacniho koeficientu C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 prazdna nizsi uroven C IER=-1 prazdna vyssi uroven C pozn. B(I).GE.C - vyssi uroven C B(I).LT.C - nizsi uroven C lit. 'Psychological measurement and prediction' C (Horst) Wadsworth 1966 C09 C CALL STS9(N,A,B,C,V,IER) C N - dimense vstupnich vektoru (I) C A - vektor hodnot spojite promenne (I) C B - vektor hodnot binarni promenne (dichotomizovane) (I) C C - mez dichotomizace (viz pozn.) (I) C V - vektor dimense 9 (O) C V(1) - stredni hodnota spojite promenne C V(2) - smerodatna odchylka spojite promenne C V(3) - pocet hodnot binarni promenne ve vyssi urovni C V(4) - pocet hodnot binarni promenne v nizsi urovni C V(5) - stredni hodnota spojite promenne odp. vyssi urovni C V(6) - stredni hodnota spojite promenne odp. nizsi urovni C V(7) - bodove biserialni korelacni koeficient C V(8) - hodnota T-testu vyznamnosti rozdilu bodove biserialniho C korelacniho koeficientu od nuly C V(9) - pocet stupnu volnosti T-testu C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 prazdna nizsi uroven C IER=-1 prazdna vyssi uroven C pozn. B(I).GE.C - vyssi uroven C B(I).LT.C - nizsi uroven C lit. 'Psychological measurement and prediction' C (Horst) Wadsworth 1966 C10 C CALL STS10(V,W,U,N,RK,S,T,ID) C V - vektor pozorovani 1. promenne C W - vektor pozorovani 2. promenne C U - vektor indexu V a W vzestupne usporadanych dat (dimense 2*N) (O) C N - pocet pozorovani (I) C RK - hodnota K-koeficientu (O) C S - smerodatna odhylka (O) C T - test signifikance RK (O) C T=0 N < 10 C ID - kod dat (I) C ID=0 data v V,W neserazena C ID=1 data v V,W serazena C lit. 'Nonparametric statistics for the behavioral sciences' C (Siegel) McGraw/Hill New York 1956 C11 C CALL STS11(V,W,U,N,RS,T,NS,ID) C V - vektor pozorovani 1. promenne C W - vektor pozorovani 2. promenne C U - vektor indexu V a W vzestupne usporadanych dat (dimense 2*N) (O) C N - pocet pozorovani (I) C RS - hodnota S-koeficientu (O) C T - test signifikance RS (O) C NS - pocet stupnu volnosti (O) C T=0 N < 10 C ID - kod dat (I) C ID=0 data v V,W neserazena C ID=1 data v V,W serazena C lit. 'Nonparametric statistics for the behavioral sciences' C (Siegel) McGraw/Hill New York 1956 C14 C CALL STS14(V,N,RMAX,P,ID,A,B,IER) C V - vektor pozorovani (I) C vektor pozorovani setrideny do neklesajici posloupnosti (O) C N - pocet pozorovani (N.GE.100) (I) C RMAX - maximum funkce sqrt(N)*abs(FN(X)-F(X)) (viz pozn.) (O) C P - pravdepodobnost zamitnuti nulove hypotezy (O) C ID - kod rozdeleni F C ID=1 normalni C ID=2 exponencialni C ID=3 Cauchyovo C ID=4 rovnomerne C A - parametr (O) C ID=1,2 A - stredni hodnota C ID=3 A - median C ID=4 A - levy koncovy bod C B - parametr (O) C ID=1,2 A - smerodatna odchylka C ID=3 (A-B) - prvni kvartil C ID=4 A - pravy koncovy bod C IER - chybovy kod (O) C IER=0 zadna chyba C IER.NE.0 B.LE.0 (ID=1,2), B=0 (ID=3), B.LE.A (ID=4) C pozn. FN - empiricka distribucni funkce C F - teoreticka distribucni funkce C lit. 'On the Kolmogorov-Smirnov limit theorems for C empirical distributions' C (Feller) Annals of math. stat. 19 1948 C 'Mathematical theory of probabiliti and statistics' C (Mises) Academic press New York 1964 C15 C CALL STS15(V,W,N,M,RMAX,P) C V - vektor pozorovani (I) C vektor pozorovani setrideny do neklesajici posloupnosti (O) C W - vektor pozorovani (I) C vektor pozorovani setrideny do neklesajici posloupnosti (O) C N - pocet pozorovani (N.GE.100) (I) C M - pocet pozorovani (M.GE.100) (I) C RMAX - maximum funkce sqrt((N*M)/(N+M))*abs(FN(X)-GM(Y)) (viz pozn.) (O) C P - pravdepodobnost zamitnuti nulove hypotezy (O) C pozn. FN - empiricka distribucni funkce souboru V C GN - empiricka distribucni funkce souboru W C lit. 'On the Kolmogorov-Smirnov limit theorems for C empirical distributions' C (Feller) Annals of math. stat. 19 1948 C 'Mathematical theory of probabiliti and statistics' C (Mises) Academic press New York 1964 C17 C CALL STS17(X,G,IER) C X - argument funkce (I) C G - hodnota funkce (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 X < 0 C IER=2 X > 57 C lit. 'Approximations for digital computers' C (Hastings) Princeton univ. press 1955 C18 C CALL STS18(X,A,B,F,H,IER) C X - argument distribucni funkce (I) C A - paremetr beta rozdeleni (I) C B - paremetr beta rozdeleni (I) C F - hodnota distribucni funkce (O) C H - hodnota hustoty pravdepodobnosti (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 viz modul STS7 C IER=1 viz modul STS7 C IER=-2 X < 0, X > 1, A < 0.5, A > 10**5, B < 0.5, B > 10**5 C IER=2 F < 0, F > 1 C lit. 'Statistical distribution programs for a computer language' C (Bargmann,Ghosh) IBM Research report RC-1094 1963 C19 C CALL STS19(X,S,F,H,IER) C X - argument distribucni funkce (I) C S - pocet stupnu volnosti chi-kvadrat rozdeleni (I) C F - hodnota distribucni funkce (O) C H - hodnota hustoty pravdepodobnosti (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 X < 0, G < 0.5, G > 2*10**5 C IER=1 F < 0, F > 1, uloha nekonverguje C lit. 'Statistical distribution programs for a computer language' C (Bargmann,Ghosh) IBM Research report RC-1094 1963 C21 C CALL STS21(X,F,H) C X - argument distribucni funkce (I) C F - hodnota distribucni funkce (O) C H - hodnota hustoty pravdepodobnosti (O) C lit. 'Approximations for digital computers' C (Hastings) Princeton univ. press 1955 C22 C CALL STS22(F,X,H,IER) C F - hodnota distribucni funkce (I) C X - argument distribucni funkce (O) C H - hodnota hustoty pravdepodobnosti (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=-1 F < 0, F > 1 C lit. 'Approximations for digital computers' C (Hastings) Princeton univ. press 1955 C23 C | C INTEGER*4 IX C | C CALL STS23(IX,SO,SH,C) C | C IX - cele liche nejvice 9-ti mistne cislo (I) C SO - smerodatna odchylka (I) C SH - stredni hodnota (I) C C - nahodne cislo (O) C24 C | C INTEGER*4 IX,IY C | C CALL STS24(IX,IY,C) C | C IX - cele liche nejvice 9-ti mistne cislo (I) C IY - cele nahodne cislo z intervalu <0,2**31> (O) C C - nahodne cislo z intervalu <0,1> (O) C25 C CALL STS25(M,L,N,X,K,IP1,IP2) C M - pocet faktoru (I) C L - vektor poctu urovni faktoru (dimense M) (I) C N - pocet vstupnich dat (I) C X - vektor vstupnich dat (viz pozn.) (I) C K - viz STS26 (O) C IP1 - pracovni vektor (dimense M) (I) C IP2 - pracovni vektor (dimense M) (I) C pozn. vstupni data jsou ve tvaru M-rozmerneho pole : C X(I1,...,IM),I1=1,L(1),...,IM=1,L(M) C dimense vektoru X : (L(1)+1)*...*(L(M)+1) C modul se uziva v posloupnosti STS25,STS26,STS27 C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) John Wiley and sons, New York 1962 C26 C CALL STS26(M,L,X,K,IP1,IP2) C M - viz STS25 (I) C L - viz STS25 (I) C X - viz STS25 (I) C K - viz STS25 (I) C IP1 - viz STS25 (I) C IP2 - viz STS25 (I) C pozn. modul se uziva v posloupnosti STS25,STS26,STS27 C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) John Wiley and sons, New York 1962 C27 C CALL STS27(M,L,X,P,V1,V2,V3,IP1,IP2,IP3) C M - viz STS26 (I) C L - viz STS26 (I) C X - viz STS26 (I) C P - celkovy prumer (O) C V1 - vektor souctu ctvercu odchylek (O) C V2 - vektor poctu stupnu volnosti (O) C V3 - vektor strednich kvadratickych odchylek (O) C IP1 - pracovni vektor (dimense M) (I) C IP2 - pracovni vektor (dimense M) (I) C IP3 - pracovni vektor (dimense M) (I) C pozn. modul se uziva v posloupnosti STS25,STS26,STS27 C lit. 'Mathematical methods for digital computers' C (Ralston,Wilf) John Wiley and sons, New York 1962 C28 C CALL STS28(N,A,P,K,V) C N - dimense vstupni matice (I) C A - vektor obsahujici matici jejiz diagonala obsahuje vlastni C cisla serazena sestupne dle velikosti (I) C P - parametr (viz pozn.1) (I) C K - pocet faktoru (O) C V - vektor kumulativnich procentnich podilu vlastnich cisel C (dimense N) (O) C pozn. modul se obvykle uziva v posloupnosti STS3,MTX22,STS28,STS29,STS30 C pozn.1 provede se vypocet kumulativnich procentnich podilu vlastnich C cisel vetsich nebo rovnych P C29 C CALL STS29(N,K,A,B) C N - dimense vstupnich matic (I) C K - pocet faktoru (I) C A - vektor obsahujici matici jejiz diagonala obsahuje vlastni C cisla serazena sestupne dle velikosti (I) C B - vektor obsahujici matici jejiz sloupce jsou vlastni vektory C v poradi odpovidajicim vlastnim cislum (I) C vektor obsahujici matici (dimense N,K) faktorovych koeficientu (O) C pozn. modul se obvykle uziva v posloupnosti STS3,MTX22,STS28,STS29,STS30 C30 C CALL STS30(N,K,B,M,V,V1,V2,V3,IER) C N - pocet radku vstupni matice (I) C K - pocet sloupcu vstupni matice (I) C B - vektor obsahujici matici faktorovych koeficientu (I) C vektor obsahujici matici faktorovych koeficientu po rotaci (O) C M - pocet iteraci (M < 51) (O) C V - vektor rozptylu matice faktorovych koeficientu po kazde iteraci C (dimense 51) (O) C V1 - vektor relativnich rozptylu faktoru (dimense N) (O) C V2 - vektor relativnich rozptylu faktoru po rotaci (dimense N) (O) C V3 - vektor rozdilu (V1-V2) relativnich rozptylu faktoru (dimense N) (O) C IER - chybovy kod (O) C IER=0 zadna chyba C IER=1 uloha nekonverguje C pozn. modul se obvykle uziva v posloupnosti STS3,MTX22,STS28,STS29,STS30 C31 C CALL STS31(V,N,K,W) C V - vektor obsahujici casovou radu (I) C N - dimense vektoru V (I) C K - viz pozn. (I) C W - vektor obsahujici K-autokovarianci rady (O) C pozn. probehne vypocet autokovarianci radu 0,...,K-1 (N > K) C lit. 'The measurment of power spectra' C (Blackman,Tukey) Dover publications inc. New York 1959 C32 C CALL STS32(V1,V2,N,K,W1,W2) C V1 - vektor obsahujici prvni casovou radu (I) C V2 - vektor obsahujici druhou casovou radu (I) C N - dimense vektoru V1,V2 (I) C K - viz pozn. (I) C W1 - vektor obsahujici K-vzajemnych kovarianci rad V1,V2 (O) C (zpozdeni rady V2) C W2 - vektor obsahujici K-vzajemnych kovarianci rad V1,V2 (O) C (zpozdeni rady V1) C pozn. probehne vypocet vzajemnych kovarianci radu 0,...,K-1 (N > K) C lit. 'The measurment of power spectra' C (Blackman,Tukey) Dover publications inc. New York 1959 C33 C CALL STS33(V,N,U,M,K,W) C V - vektor obsahujici casovou radu (I) C N - dimense vektoru V (I) C U - vektor obsahujici vahove koeficienty (I) C M - dimense vektoru U (M-liche) (I) C K - parametr vyberu (viz pozn.) (I) C W - vektor obsahujici vyrovnanou radu v prvcich W(i),...,W(j) (O) C ( i=(K*(M-1))/2+1, j=N-(K*(M-1))/2 ) C pozn. K=1 - vahy budou aplikovany na sousedni cleny rady C (vytvareni mezimesicnich prumeru) C K=12 - vahy budou aplikovany na kazdy 12. clen rady C (vytvareni mezirocnich prumeru) C N.GE.K*M C lit. 'Fortran subroutines for time series analysis' C (Healy,Bogert) Communications of ACM vol 16 1963 C34 C CALL STS34(V,N,ALFA,A,B,C,W) C V - vektor obsahujici casovou radu (I) C N - dimense vektoru V,W (I) C ALFA - vyrovnavaci konstanta (I) C A - koeficient predikcni rovnice (viz pozn.) (I) C aktualizovany koeficient predikcni rovnice (viz pozn.) (O) C B - koeficient predikcni rovnice (viz pozn.) (I) C aktualizovany koeficient predikcni rovnice (viz pozn.) (O) C C - koeficient predikcni rovnice (viz pozn.) (I) C aktualizovany koeficient predikcni rovnice (viz pozn.) (O) C W - vektor obsahujici vyrovnanou radu (O) C pozn. A + B*T + C*T*T/2 (A=B=C=0 - modul zajisti pocatecni hodnoty) C lit. 'Smoothing, forecasting and prediction of discrete time series' C (Brown) Prentice-hall 1963 C01 C C SUBROUTINE STS1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO) 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.0E38 VMAX=-1.0E38 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 C02 C C SUBROUTINE STS2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO) 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.0E38 VMAX=-1.0E38 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 C03 C C SUBROUTINE STS3(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 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 C04 C C SUBROUTINE STS4(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.0E38 A(KI)=1.0E38 B(KI)=1.0E38 S(KI)=1.0E38 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.0E38 SKEW(J)=1.0E38 CURT(J)=1.0E38 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.0E38 A(KI)=1.0E38 B(KI)=1.0E38 S(KI)=1.0E38 A(KJ)=1.0E38 B(KJ)=1.0E38 S(KJ)=1.0E38 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 C05 C C SUBROUTINE STS5(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 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 MTX9(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 STS6(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))* LOG(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 C06 C C SUBROUTINE STS6(M,A,B,XL,X) DIMENSION A(1),B(1),XL(1),X(1) 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 STS7(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 STS7(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 C07 C SUBROUTINE STS7(A,R,N,MV) DIMENSION A(1),R(1) 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 C08 C C SUBROUTINE STS8(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.E38 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 STS22(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 C09 C C SUBROUTINE STS9(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.E38 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 CORRELATIO 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 C10 C C SUBROUTINE STS10(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 STS12(A,R,N) CALL STS12(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(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 STS13(R,N,KT,TA) CALL STS13(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 C11 C C SUBROUTINE STS11(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 STS12(A,R,N) CALL STS12(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 STS13(R,N,KT,TSA) CALL STS13(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 C12 C C SUBROUTINE STS12(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 C13 C C SUBROUTINE STS13(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 C14 C C SUBROUTINE STS14(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 STS21(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 STS16(Z,PROB) PROB=1.0-PROB 29 RETURN END C15 C C SUBROUTINE STS15(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 STS16(Z,PROB) PROB=1.0-PROB RETURN END C16 C C SUBROUTINE STS16(X,Y) IF(X-.27)1,1,2 1 Y=0.0 GO TO 9 2 IF(X-1.0)3,6,6 3 Q1=EXP(-1.233701/X**2) C 3 Q1=DEXP(-1.233700550136170/X**2) Q2=Q1*Q1 Q4=Q2*Q2 Q8=Q4*Q4 IF(Q8-1.0E-25)4,5,5 4 Q8=0.0 5 Y=(2.506628/X)*Q1*(1.0+Q8*(1.0+Q8*Q8)) C 5 Y=(2.506628274631001/X)*Q1*(1.0D0+Q8*(1.0D0+Q8*Q8)) GO TO 9 6 IF(X-3.1)8,7,7 7 Y=1.0 GO TO 9 8 Q1=EXP(-2.0*X*X) C 8 Q1=DEXP(-2.0D0*X*X) Q2=Q1*Q1 Q4=Q2*Q2 Q8=Q4*Q4 Y=1.0-2.0*(Q1-Q4+Q8*(Q1-Q8)) 9 RETURN END C17 C C SUBROUTINE STS17(XX,GX,IER) IF(XX-57.)6,6,4 4 IER=2 GX=1.E38 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 C18 C C SUBROUTINE STS18(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 STS20(AA,G1,IOK) CALL STS20(BB,G2,IOK) CALL STS20(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.E38 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.E38 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 STS19(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 STS19(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 STS20(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 STS20(AA+BB,G1,IOK) CALL STS20(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.E38 P=-1.E38 GO TO 670 650 IER=+2 P= 1.E38 GO TO 670 660 IER=0 670 RETURN END C19 C C SUBROUTINE STS19(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.E38 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 STS20(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.E38 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 STS21(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 STS20(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 STS20(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 STS20(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 STS20(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 STS20(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.E38 P=-1.E38 GO TO 620 600 IER=+1 P= 1.E38 GO TO 620 610 IER=0 620 RETURN END C20 C C SUBROUTINE STS20(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.D70) 8,9,9 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.D75 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.D75 10 RETURN END C21 C C SUBROUTINE STS21(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 C22 C C SUBROUTINE STS22(P,X,D,IE) C IE=0 X=.99999E+38 D=X IF(P)1,4,2 1 IE=-1 GO TO 12 2 IF (P-1.0)7,5,1 4 X=-.999999E+38 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 C23 C C SUBROUTINE STS23(IX,S,AM,V) A=0.0 DO 50 I=1,12 CALL STS24(IX,IY,Y) IX=IY 50 A=A+Y V=(A-6.0)*S+AM RETURN END C24 C C SUBROUTINE STS24(IX,IY,YFL) IY=IX*65539 IF(IY)5,6,6 5 IY=IY+2147483647+1 6 YFL=IY YFL=YFL*.4656613E-9 RETURN END C25 C C SUBROUTINE STS25(K,LEVEL,N,X,L,ISTEP,KOUNT) DIMENSION LEVEL(1),X(1),ISTEP(1),KOUNT(1) 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 C26 C C SUBROUTINE STS26(K,LEVEL,X,L,ISTEP,LASTS) DIMENSION LEVEL(1),X(1),ISTEP(1),LASTS(1) 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 C27 C C SUBROUTINE STS27(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 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 SECON 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 C28 C C SUBROUTINE STS28(M,R,CON,K,D) DIMENSION R(1),D(1) 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 C29 C C SUBROUTINE STS29(M,K,R,V) DIMENSION R(1),V(1) 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 C30 C C SUBROUTINE STS30(M,K,A,NC,TV,H,F,D,IER) DIMENSION A(1),TV(1),H(1),F(1),D(1) 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 C31 C C SUBROUTINE STS31(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 C32 C C SUBROUTINE STS32(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 C33 C C SUBROUTINE STS33(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 C34 C SUBROUTINE STS34(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