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 <X,X+H> resp. <X-H,X> (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 <X,X+H> resp. <X-H,X>
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 <X,X+H> resp. <X-H,X> (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 <X,X+H> resp. <X-H,X>
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 <XD,XH>,
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 <XD,XH>,
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 <XD,XH>,
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 <XD,XH>,
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
