├── LICENSE ├── README.md ├── debug_hybrid.f90 ├── documentation ├── PowellHybrid.pdf ├── PowellHybrid.tex └── aer.bst ├── fzero.f90 ├── hybrid.f90 └── myutility.f90 /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2012-2015 Yoki Okawa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Optimization 2 | ============ 3 | 4 | Fortran 90 non-linear equations solver with documentation using Brent's method and Powells modified Hybrid method. 5 | 6 | 7 | What it does 8 | ---------- 9 | * It solves a system of nonlinear equations (hybrid.f90). 10 | * It solves a nonlinear equation with Brent's method (fzero.f90). The single equation problem should not be treated as one case of the system of equations problem. Brent's method is only applicable to the single equation model, but it won't be stuck in the local solution, unlike hybrid.f90. 11 | * It provides detailed documentation that explains the intuition behind the algorithm and every subroutine in the code. The documentation contains details about why your model doesn't converge and what to do. 12 | * As a bonus, it does not depend on any external library. 13 | 14 | Motivation 15 | ---------- 16 | Canned optimization packages are useful when it works. But when it doesn't, I can do very little. Error messages didn't make sense. I didn't have a clue for the reason of non-convergence. I realized that I have to open the can. 17 | 18 | The challenge of opening the can is not about code itself. It is about documentations which closely follows the code. Comments in the code are usually not enough because we need to understand the derivations of formulas and intuitions behind the formulas. This package provides serious documentation. Symbols and subroutine structure in the documentation exactly match with code. 19 | 20 | 21 | License 22 | ------- 23 | MIT 24 | -------------------------------------------------------------------------------- /debug_hybrid.f90: -------------------------------------------------------------------------------- 1 | program mydebug 2 | use hybrid 3 | ! call test1() 4 | ! call qrtest() 5 | 6 | ! call finitedifftest 7 | ! call doglegtest 8 | call FsolveHybridTest 9 | write(*,*) 'press any key to continue' 10 | read(*,*) 11 | 12 | 13 | end program mydebug 14 | 15 | 16 | 17 | 18 | 19 | subroutine doglegtest 20 | use myutility; use hybrid 21 | ! subroutine to test dogleg 22 | 23 | implicit none 24 | real(kind=db), dimension(3,3) :: jacob, Q, R 25 | real(kind=db), dimension(3) :: x0, p, Qtf 26 | external :: funs2 27 | real(kind=db), dimension(3) :: fval 28 | real(kind=db) :: delta 29 | integer :: flag 30 | ! real(kind=db), dimension(2,2) :: GetJacobian 31 | 32 | x0(1) = 0.5_db 33 | x0(2) = 1.0_db 34 | x0(3) = 1.5_db 35 | delta = 0.10_db 36 | 37 | call funs2(x0,fval) 38 | write(*,*) 'funs2([0.50, 1.00. 1.50 ]):' 39 | write(*,*) fval 40 | 41 | x0 = x0+1 42 | call funs2(x0,fval) 43 | call GetJacobian(jacob, funs2, x0, 0.0001_db,fval) 44 | call QRfactorization(jacob,Q,R) 45 | 46 | Qtf = matmul(transpose(Q), fval) 47 | call dogleg(p,Q,R,delta,Qtf,flag) 48 | 49 | write(*,*) 'p:' 50 | write(*,*) p 51 | write(*,*) 'flag:' 52 | write(*,*) flag 53 | 54 | end subroutine doglegtest 55 | 56 | 57 | 58 | subroutine finitedifftest() 59 | use myutility; use hybrid, only : GetJacobian 60 | ! test finite difference 61 | implicit none 62 | 63 | real(kind=db), dimension(2,2) :: jacob 64 | real(kind=db), dimension(2) :: x0 65 | external :: funs1 66 | real(kind=db), dimension(2) :: fval 67 | ! real(kind=db), dimension(2,2) :: GetJacobian 68 | 69 | x0(1) = 2.0_db 70 | x0(2) = 3.0_db 71 | 72 | call funs1(x0, fval) 73 | call GetJacobian(jacob, funs1, x0, 0.001_db,fval) 74 | 75 | call MatrixWrite(jacob) 76 | 77 | end subroutine finitedifftest 78 | 79 | subroutine funs1(x, fval0) 80 | use myutility; 81 | implicit none 82 | real(kind=db), intent(IN), dimension(:) :: x 83 | real(kind=db), intent(OUT), dimension(:) :: fval0 84 | 85 | fval0(1) = x(2) - x(1)**2 86 | fval0(2) = 2 - x(1) - x(2) 87 | 88 | end subroutine funs1 89 | 90 | 91 | 92 | subroutine funs3(x, fval0) 93 | use myutility; 94 | implicit none 95 | real(kind=db), intent(IN), dimension(:) :: x 96 | real(kind=db), intent(OUT), dimension(:) :: fval0 97 | 98 | fval0(1) = 10_db*(x(2) - x(1)**2) 99 | fval0(2) = 2 - x(1) - x(2) 100 | 101 | end subroutine funs3 102 | 103 | 104 | subroutine funs2(x, fval0) 105 | use myutility; 106 | ! a little difficult function 107 | ! solution x = [0.50, 1.00. 1.50 ] (+ 2pi*n) 108 | 109 | implicit none 110 | real(kind=db), intent(IN), dimension(:) :: x 111 | real(kind=db), intent(OUT), dimension(:) :: fval0 112 | 113 | fval0(1) = 1.20_db * sin(x(1)) -1.40_db*cos(x(2))+ 0.70_db*sin(x(3)) & 114 | - 0.517133908732486_db 115 | 116 | fval0(2) = 0.80_db * cos(x(1)) -0.50_db*sin(x(2))+ 1.00_db*cos(x(3)) & 117 | - 0.352067758776053_db 118 | 119 | fval0(3) = 3.50_db * sin(x(1)) -4.25_db*cos(x(2))+ 2.80_db*cos(x(3)) & 120 | + 0.4202312501553165_db 121 | 122 | end subroutine funs2 123 | 124 | 125 | subroutine qrtest 126 | use myutility; use hybrid, only : QRfactorization, QRupdate 127 | ! test QR factorization and update 128 | 129 | implicit none 130 | real(kind=db), dimension(5,5) :: Q, A3 131 | real(kind=db), dimension(5,5) :: A, R ,A2, A4, A5, A6, B1, B2 132 | real(kind=db), dimension(5) :: u,v 133 | INTEGER :: isize 134 | INTEGER,ALLOCATABLE :: iseed(:) 135 | 136 | ! set a seed. 137 | CALL RANDOM_SEED(SIZE=isize) 138 | ALLOCATE( iseed(isize) ) 139 | CALL RANDOM_SEED(GET=iseed) 140 | iseed = 1 141 | CALL RANDOM_SEED(PUT = iseed) 142 | 143 | CALL RANDOM_NUMBER(A) ! generate random number 144 | A = A - 0.5 145 | write(*,*) 'A:' 146 | call MatrixWrite( A ) 147 | 148 | Q = 1 149 | R = 1 150 | call QRfactorization(A,Q,R) 151 | 152 | A2 = matmul(Q , R) 153 | A3 = matmul(Q , transpose(Q)) 154 | 155 | write(*,*) 'Q:' 156 | call MatrixWrite( Q ) 157 | write(*,*) 'R:' 158 | call MatrixWrite( R ) 159 | write(*,*) 'Q*R:' 160 | call MatrixWrite( A2) 161 | write(*,*) "Q*Q':" 162 | call MatrixWrite( A3) 163 | A3 = A2 - A 164 | write(*,*) "Q*R - A:" 165 | call MatrixWrite( A3) 166 | 167 | ! update test 168 | call RANDOM_NUMBER(u) 169 | call RANDOM_NUMBER(v) 170 | u = (u-0.5) * 1 171 | v = (v-0.5) * 1 172 | 173 | write(*,*) ' ' 174 | write(*,*) 'update A ' 175 | call MatrixWrite( A+outer(u,v)) 176 | call QRupdate(Q,R,u,v) 177 | 178 | 179 | write(*,*) 'update Q:' 180 | call MatrixWrite( Q ) 181 | write(*,*) 'update R:' 182 | call MatrixWrite( R ) 183 | write(*,*) "Q*Q':" 184 | call MatrixWrite( matmul(Q , transpose(Q))) 185 | write(*,*) "Q*R - A:" 186 | call MatrixWrite( matmul(Q , R) - (A + outer(u,v))) 187 | 188 | 189 | ! write(*,*) "Q*Q':" 190 | ! call MatrixWrite( A3) 191 | ! 192 | 193 | end subroutine qrtest 194 | 195 | 196 | subroutine temp 197 | ! temp place to put code 198 | 199 | 200 | end subroutine temp 201 | 202 | -------------------------------------------------------------------------------- /documentation/PowellHybrid.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yoki/Optimization/49f3707ab5778b23c440ebc67dfa35354662565d/documentation/PowellHybrid.pdf -------------------------------------------------------------------------------- /documentation/PowellHybrid.tex: -------------------------------------------------------------------------------- 1 | \documentclass[12pt]{article} 2 | \usepackage{amssymb, amsmath,algorithmic,algorithm,natbib} 3 | 4 | % \usepackage[dvipdfm,bookmarks=true,bookmarksnumbered=false,bookmarkstype=toc,hyperfootnotes=false, citebordercolor={1 1 1} ,linkbordercolor={1 1 1} ]{hyperref} 5 | 6 | \def\d{{\mathrm{d}}} 7 | \def\E{{\mathrm{E}}} 8 | \def\Var{{\mathrm{Var}}} 9 | \def\Cov{{\mathrm{Cov}}} 10 | \def\max#1{{\underset{#1}{\mathrm{max}}}} 11 | \def\min#1{{\underset{#1}{\mathrm{min}}}} 12 | \def\({\left(} 13 | \def\){\right)} 14 | \def\R{{\mathbb{R}}} 15 | \def\pdiff#1#2{\frac{\partial #1}{\partial #2}} 16 | \def\xb{{\mathbf{x}}} 17 | \def\fb{{\mathbf{f}}} 18 | \def\nub{{\mathbf{\nu}}} 19 | \def\gb{{\mathbf{g}}} 20 | \def\gammab{{\mathbf{\gamma}}} 21 | \def\pb{{\mathbf{p}}} 22 | \def\db{{\mathbf{d}}} 23 | \def\0{{\mathbf{0}}} 24 | \def\1b{{\mathbf{1}}} 25 | \def\deltab{{\boldsymbol{\delta}}} 26 | \newcommand{\Gammab}{{\mathbf{\Gamma}}} 27 | \newcommand{\be}{\begin{equation}} 28 | \newcommand{\ee}{\end{equation}} 29 | \setlength{\oddsidemargin}{0 in} 30 | \setlength{\evensidemargin}{0 in} 31 | \setlength{\textwidth}{6.5 in} 32 | \setlength{\topmargin}{-.5 in} 33 | \setlength{\textheight}{9 in} 34 | 35 | \pagestyle{plain} 36 | \begin{document} 37 | 38 | \begin{center} 39 | {\Large A manual for the Modified Powell's Hybrid Method} {\large by Yoki Okawa }\\[0.5cm] 40 | {\large \today}\\[0.5cm] 41 | \end{center} 42 | 43 | \section{Introduction} 44 | 45 | 46 | In this document, I explain the modified Powell's Hybrid method to solve the system of nonlinear 47 | equations. The modified Powell's Hybrid method has several advantages: avaiability of public domain high quality code; and popularity in various packages. This method seems ``the method'' used in almost all packages I checked so far. It includes IMSL, NAG, Matlab, 48 | and Octave. The algorithm is based on \cite{Powell1970, Powell1970a}. This 49 | algorithm was implemented in MINPACK, a high-quality optimization package in public 50 | domain\footnote{You can access MINPACK from http://www.netlib.org/minpack/ }. It is implemented in 51 | Fortran 77 without the detail of the algorithm. 52 | 53 | This document is intended to provide the code and explanation at the same time. There are many good 54 | explanations of the idea behind this algorithm. For example, see \cite{NocedalWright2000}. Also, 55 | there are high-quality free codes like MINPACK. But it is hard to connect two. It is easy to get confused with what is "psi" or "flag3" in the code. So I am trying to build a 56 | bridge between algorithm and code by creating a one-to-one mapping of code and documentation. 57 | 58 | \section{Basic Idea} 59 | For the basic idea of trust region method and nonlinear optimization in general, 60 | \cite{NocedalWright2000} provide readable yet detailed explanation. 61 | 62 | We consider a following problem. 63 | \[ 64 | \begin{pmatrix} 65 | f_1(x_1,\dots,x_n)\\ 66 | f_2(x_1,\dots,x_n) \\ 67 | \vdots\\ 68 | f_n(x_1,\dots,x_n) \\ 69 | \end{pmatrix} 70 | = 71 | \begin{pmatrix} 72 | 0\\ 73 | 0 \\ 74 | \vdots\\ 75 | 0\\ 76 | \end{pmatrix} 77 | \] 78 | Or, equivalently, 79 | \be \label{eq:prob} 80 | \fb (\xb) = \0. 81 | \ee 82 | 83 | Instead of solving the equation directly, we consider the minimization of the residual function 84 | \[ 85 | r(\xb) = \|\fb(\xb)\|^2 = \sum_{i=1}^n f_i(\xb)^2 86 | \] 87 | 88 | The nonlinear equations are solved by repeatedly solving the locally Quadratic approximation of 89 | the minimization problem of $r(\xb)$ around the point $\xb_i$: 90 | 91 | \be \label{eq:unconditionalQuadratic} 92 | \min{\pb} \left[ r(\xb_i) + \tilde{\pb}^T J^T\fb(\xb_i) + 93 | \frac{1}{2} \pb^T J^T(\xb_i) J(\xb_i)\pb\right] 94 | \ee 95 | where $J$ is a Jacobian matrix and 96 | \[ 97 | J_{kj} =\pdiff{f_k(\xb)}{x_j} 98 | \] 99 | Quadratic approximation, which takes advantage of second derivative. Benefit of using second derivative is substantial. The first order convergence, only using first derivative will typically make the error half per iteration. This means $10^{3}$ improvement requires 10 iterations. In the second order convergence, the error becomes square of the original error. If original error was $10^{-3}$, $10^{3}$ improvement can be obtained by only one iteration. 100 | 101 | The challenge for second order methods are calculating the second order derivative, or the Hessian. The nice point here is that we do not explicitly calculate the Hessian of $r(\xb)$ because its functional form of the sum of the square implies simple form of the Hessian, $ J^T(\xb_i) 102 | J(\xb_i)$ 103 | The solution to the problem is 104 | \[ 105 | \pb = - J^{-1}\fb(x_i),\qquad \xb _{i+1} = \xb_i + \pb_i 106 | \] 107 | This is the Newton-Raphson algorithm. 108 | 109 | Newton-Raphson update can fail spectacularly when Jacobian changes fast. For illustration, let's 110 | consider one dimensional problem $f(x) = x^3+1 = 0.$. It has a unique solution at $x = -1 $. Note that $f'(x) = 2 x^2$, which is a strictly concave function. Someone may expect nice convergence features. However, 111 | if we start from $x_0=0.01$ and apply the Newton-Raphson update, $x_1 $ is 3090. It is not approaching to the true solution at all. 112 | 113 | Why the Newton Raphson failed? Since $f'(0.01) = 0.003$, the algorithm thinks $f(x)$ does not 114 | respond sharply with the change $x$. And $f(0.01)$ is $ 1.0303$, which is not too close to zero. So 115 | the algorithm thinks it has to take a large step to make $f(x)$ zero. 116 | 117 | The problem is that the Newton-Raphson algorithm is taking locally Quadratic approximation too 118 | seriously. The approximation is valid for the region such that Jacobian is not moving too fast. In 119 | our example, $f'(-0.1) = 0.3$, which is more than hundred times larger than the case of $x=0.01$. So it 120 | is not a good idea to move $x$ by three thousands. One solution is restricting the step size endogenously. We modify \eqref{eq:unconditionalQuadratic} by the following manner: 121 | \begin{align} 122 | \min{\pb} &\left[ r(\xb_i) + \tilde{\pb}^T J^{T}\fb(\xb) + 123 | \frac{1}{2} \pb^T J^T(\xb_i) J(\xb_i)\pb\right] 124 | \label{eq:conditionalQuadratic} \\ 125 | &\mathrm{subject \ to}\qquad \|\pb\| \le \Delta 126 | \end{align} 127 | $\Delta$ is our parameter for the size of the region we trust the quadratic approximation. We 128 | adjust $\Delta$ smartly (details below). 129 | 130 | 131 | 132 | \section{Algorithm} 133 | \subsection{Overview} 134 | This is a basic component of the algorithm. 135 | \begin{algorithm}[ht] 136 | \caption{Main Algorithm (Subroutine Hybrid())} 137 | \label{al:main} 138 | \begin{algorithmic}[1] 139 | \STATE Set Initial Value of $\Delta$ and $J$ 140 | \STATE Do QR Decomposition of $J$: $QR = J$ 141 | \WHILE{$\text{abs}(F(\xb))>tol$} 142 | \STATE Calculate $\pb$ given $Q,R$ and $\Delta$ 143 | \IF{$F(\xb+\pb) 1$ OR $\frac{r(\xb)- r(\xb+\pb)}{r(\xb)-\Phi} >0.5 $} 287 | \STATE $\Delta = \max{}(\Delta, 2\|\pb\| )$ 288 | \ELSIF{ abs$\big(\frac{r(\xb+\pb)-\Phi}{r(\xb)-\Phi}\big)< 0.1 $} 289 | \STATE $\Delta =2\|\pb\| $ 290 | \ENDIF 291 | \ENDIF 292 | \IF {BadJacobian = 2} 293 | \STATE Recalculate Jacobian by forward differences. 294 | \STATE BadJacobian = 0 295 | \ENDIF 296 | \end{algorithmic} 297 | \end{algorithm} 298 | 299 | Line \ref{al:delta2:l1} checks if $J$ is good or not. If $J$ is a good prediction, 300 | the predicted reduction of the objective function $r(\xb)-\Phi $ is almost equal to the 301 | actual reduction. If the actual reduction is less than 10\% of the predicted reduction, 302 | there is something wrong with $J$. It is either $\fb(\xb)$ is very nonlinear or 303 | calculated $J$ contains too much error from the history. These errors generally become 304 | smaller if the trust region $\Delta$ shrinks. 305 | 306 | If the reduction is relatively satisfactory, we start to weakly increase $\Delta$. There is not 307 | too much justification for this increase. But Powell found that the result is numerically quite 308 | satisfactory. Note that usually $\|\pb\|$ is equal to $\Delta$. We do not want to modify 309 | $\Delta$ all the time because we might fall into the oscillation of increase $\rightarrow$ 310 | decrease $\rightarrow $ increase $\cdot \cdot \cdot$. To avoid that, GoodJacobian is checking if 311 | it is the first attempt to increase $\Delta$. If it is after the second attempt to increase $\Delta$ and 312 | we attain a modest increase in the objective function, which is that actual reduction is more than 50\% 313 | of predicted reduction, we double the trust region. If our Jacobian is a pretty good estimate 314 | ($r(\xb+\pb)-\Phi$ is small), we also expand the trust region. 315 | 316 | BadJacobian is counting the number of consecutive failures of predicting changes in the objective 317 | function. If the algorithm fails to predict the change twice consecutively, we suspect that 318 | the current Jacobian contains a serious error which came from previous updates. The previous points may 319 | be far from the current $\xb$. We recalculate it based on the forward difference from scratch, instead of 320 | updating it. 321 | 322 | \subsection{Update of J} 323 | We update Jacobian using the Broyden's rank 1 update. For the detail, see Numerical Recipes 324 | Ch. 9.7., Broyden's method. : 325 | \begin{align*} 326 | J \leftarrow J +\frac{1}{\|\pb\|^2} (\fb(\xb+\delta)-f(\xb) -J\pb )\pb^T 327 | \end{align*} 328 | 329 | 330 | 331 | \subsection{QR Decomposition} 332 | QR decomposition is decomposing a matrix $A$ to multiple of $Q$, orthogonal matrix ($Q^{-1}=Q^T$), 333 | and upper triangular matrix $R$. So $A=QR$. It is useful because solving $Ax=b$ takes $O(n^2)$ 334 | step once we know QR decomposition of A, which is faster than $O(n^3)$. Although QR decomposition 335 | itself takes $O(n^3)$, once we calculate the decomposition, its update only takes $O(n^2)$. So it 336 | is useful when we have to solve the linear equation repeatedly with slightly different 337 | coefficients. It is the case when we calculate the Newton direction, which requires to solve 338 | $J\delta = \fb(\xb)$ in every iteration. In this subsection, I assume that input is a square 339 | matrix. The Fortran code is written in the way it accepts the rectangular matrix. 340 | 341 | \subsubsection{Decomposition} 342 | This is called at first and whenever $J$ is recalculated using finite difference. The code uses 343 | Householder transformation repeatedly. Let $a_j$ as an arbitrary vector and we want to find $P_j$ 344 | such that $P_j$ is orthogonal and $P_ja_j = (b_1, 0, \dots,0)^T$. We can set 345 | \[ 346 | P_j = I - \frac{2}{\|u_j\|^2} u_ju_j^T, \qquad u_j = a_j - \|a_j\|e_1 347 | \] 348 | where $I$ is identity matrix and $e_1= (1,0,\dots,0)^T$ is a unit vector. We can apply this 349 | repeatedly until all matrix becomes upper triangular. Many books about numerical algorithm covers 350 | QR decomposition with Householder transformation. 351 | 352 | 353 | 354 | 355 | \subsubsection{Update} 356 | The update is called at the end of each iteration. Our goal is given 357 | \[ 358 | A^{next} = A + uv^T, \qquad A = QR 359 | \] 360 | find $Q^{next}$ and $R^{next}$ such that $Q^{next}R^{next}=A^{next}$. For more information, see \cite{BjorckDahlquist2008} 361 | section 8.4. 362 | 363 | \paragraph{transform a bit} 364 | Let $w=Q^Tu$. Using this, 365 | \[ 366 | A^{next} = Q^{next}(R+wv^T) 367 | \] 368 | We are going to make $R+wv^T$ upper triangular matrix using Givens transformation. 369 | 370 | \paragraph{Givens transformation of $w$} 371 | We find a sequence of Givens transformation such that 372 | \[ 373 | P_1\dots P_{n-1}w = \alpha e_1. 374 | \] 375 | Givens transformation is very similar to Jacobi transformation. It is a matrix defined by three 376 | parameters $(k,l,\theta)$ such that $(i,j)$ 377 | element is 378 | \[ 379 | P(k,l,\theta)_{i,j} = \begin{cases} 380 | \cos \theta & i=j=k \\ 381 | \cos \theta & i=j = l\\ 382 | -\sin \theta & k = i , l = j \\ 383 | \sin \theta & k = j, l=i \\ 384 | 1 & i = j \neq k, i = j \neq l\\ 385 | 0 & otherwise 386 | \end{cases} 387 | \] 388 | It is zero other than diagonal elements, $(k,l)$ element, and $(l,k)$ element. $P$ is orthogonal 389 | matrix. Consider 390 | $P(n-1,n,\theta) w$. $n$th element of $P(n-1,n,\theta) w$ is zero if 391 | \[ 392 | \cos \theta = \frac{1}{\sqrt{t^2+1}}, \qquad 393 | \sin \theta = t \cos \theta, \qquad t = \frac{w_n}{w_{n-1}} 394 | \] 395 | We can repeat this until all element other than the first element is zero. 396 | Let 397 | \[ 398 | P^w = P_1\dots P_{n-1} 399 | \] 400 | 401 | \paragraph{Transform upper Hessenberg matrix to upper triangular matrix} 402 | Now, 403 | \[ 404 | A^{next} = Q (P^w)^T(P^WR+P^wwv^T) 405 | \] 406 | Note that elements in $P^wwv^T$ are zero other than the first row and $P^WR$ is upper Hessenberg 407 | matrix. So $P^WR+P^wwv^T$ is an upper Hessenberg matrix. We are going to eliminate (1,2) elements to 408 | (n-1,n) elements using Givens transformation. Let $H =P^WR+P^wwv^T$. To eliminate (1,2) element, 409 | we need Givens transformation such that 410 | \[ 411 | \cos \theta = \frac{1}{\sqrt{t^2+1}}, \qquad 412 | \sin \theta = t \cos \theta, \qquad t = \frac{h_{21}}{w_{11}} 413 | \] 414 | We can repeat this until all lower triangular elements are zero. Let $P^H$ as the accumulation of 415 | the transformation. We complete the algorithm by 416 | \[ 417 | Q^{next} = Q (P^w)^T(P^H)^T, \qquad R^{next} = P^H(P^WR+P^wwv^T) 418 | \] 419 | 420 | 421 | 422 | 423 | \subsection{Termination of the Algorithm} 424 | There are several conditions for the termination of this algorithm. 425 | 426 | \paragraph{Successful Convergence} 427 | We call it successful if 428 | \[ 429 | \frac{1}{\sqrt{n}}\|\fb(\xb)\|=\sqrt{\frac{1}{n}\sum_{i=1}^m(f_i(\xb))^2} < ftol 430 | \] 431 | This means that the average squared residual is small. If this condition is satisfied, $|\fb_i(\xb)|$ 432 | is at most $n\cdot ftol1$ 433 | 434 | \paragraph{Trust region size shrinks to the tolerance level} 435 | The program stops execution if $\Delta < xtol(\|\xb\|+xtol)$, the relative size of the trust 436 | region is smaller than $xtol$. This happens if the Jacobian changes rapidly and wildly around the 437 | point the program terminated. This is the most common type of unsuccessful termination. It can 438 | happen for the following reasons: 439 | \begin{itemize} 440 | \item The problem you are going to solve has large second order derivatives. In this case, 441 | Jacobian is sensitive to where it is evaluated. The local quadratic approximation is inappropriate. This might be the case if you have highly discontinuous Jacobian, for example. 442 | \item You set the $ftol$ too small. You might get this message even if the algorithm is in indeed 443 | the solution. If $ftol$ is too small, the algorithm can not attain it with the precision 444 | required. 445 | \item You set the speed of shrinking $\Delta$ too small. 446 | \item Your subroutine to be solved contains bugs. My personal experience suggests this explains 447 | most of this error message. 448 | \end{itemize} 449 | 450 | Here are possible solutions: 451 | \begin{itemize} 452 | \item Check the $\fb(\xb)$ and see if it is small enough or not. 453 | \item Increase \textit{DeltaSpeed} 454 | \item Increase \textit{ftol} 455 | \item Decrease $JacobianStep$ 456 | \item Use different initial guesses 457 | \item If you are using single precision real numbers, use double precision instead. 458 | \end{itemize} 459 | 460 | 461 | \paragraph{Too much function call} 462 | If the number of function call exceeds MaxFunEval, the program stops the execution. 463 | 464 | \paragraph{Algorithm reaches Local minima} 465 | If the program terminates for the reason other than ``Successful Convergence'', we recalculate the 466 | gradient of the objective function $\nabla r(\xb) = J^T\fb(\xb)$ by finite difference. If 467 | $\|\nabla r(\xb)\| < gtol(\|\xb\|+gtol)$, we are at the locally optimal point, although average 468 | residual is not close enough to zero in the tolerance required. This happens if the algorithm is 469 | captured in the local minima. The solution is trying the different initial guess. This can also 470 | happen if $ftol$ is too small to attain. You can check that by seeing the $\fb(\xb)$ at the 471 | output. 472 | 473 | 474 | 475 | 476 | \section{Usage of the Subroutine} 477 | I explain inputs and outputs of this subroutine. Many arguments are optional. 478 | \begin{description} 479 | \item[fun] Subroutine which returns the residual vector. It should take two arguments, and 480 | first argument should be $\xb$ and second argument should be the $\fb(\xb)$. 481 | \item[x0] Initial value of $\xb$ 482 | \item[xout] Solution of the least square problem. 483 | \item[info] (optional) Variable for the information of the termination of the algorithm. For 484 | the detail of the conditions, see the Termination of the Algorithm. 485 | \begin{description} 486 | \item[info = 0] Improper input values 487 | \item[info = 1] Successful convergence. 488 | \item[info = 2] First order optimality satisfied 489 | \item[info = 3] Trust region size shrinks to the tolerance level 490 | \item[info = 4] Too much function call 491 | \end{description} 492 | \item[fvalout] (Optional) Output vector of residuals at $\xb = xout$. 493 | \item[Jacobianout] (Optional) Output Jacobian Matrix at $xout$ 494 | \item[xtol] (Optional) Tolerance of the x. If trust region size is smaller than 495 | $xtol(\|\xb\|+xtol)$, the program terminates. If this is not provided, it would be set to 496 | the default value of $10^{-8}$ 497 | \item[ftol] (Optional) Tolerance of the residual. The program terminates if 498 | $\sqrt{\sum_{i=1}^m(f_i(\xb))^2/m} < ftol $. If this is not provided, it would be set to 499 | the default value is $10^{-8}$. 500 | \item[gtol] (Optional) Tolerance of the gradient. If $ \|\nabla r(\xb)\| < 501 | gtol(\|\xb\|+gtol)$ holds, we regard it first order optimality is satisfied. The default 502 | value is $10^{-8}$ 503 | \item[JacobianStep] (Optional) Relative step size for calculating the Jacobian by Finite 504 | difference. Default value is $10^{-3}$. 505 | \item[display] (Optional) Option to specify the display preference. If display is 2, the 506 | algorithm shows the iteration. If display is 0, the algorithm shows nothing. Default value 507 | is 0. 508 | \item[maxFunctionCall] (Optional) Number of function to be called before 509 | terminating the algorithm. Default value is $100n$, where $n$ is number of equations. 510 | \item[noupdate] (Optional) Dummy variable for the Broyden's rank 1 update. If noupdate is 1, 511 | the algorithm recalculate Jacobian with finite difference in each iteration. This would 512 | almost always make the algorithm converged with fewer iteration. But this does not mean it 513 | would speed up in terms of CPU time because in general the calculation of the Jacobian is 514 | costly if the evaluation of the objective function is costly or $n$ is large. Turning off 515 | the update can speed up the total computation time when $n$ is very small, (say less than 516 | 5). Default value is 0, so the Broyden's update is the default. 517 | \item[DeltaSpeed] (Optional) Controls the speed of $\Delta$ when it shrinks. In algorithm 518 | \ref{al:delta2}, line \ref{line1}, the trust region size $\Delta$ shrinks if the actual 519 | reduction do not match with predicted reduction. DeltaSpeed controls how fast it should 520 | shrink. It should always be always less than one. The smaller the value is, the faster the 521 | $\Delta$ shrinks. The default value is $1/4$. 522 | \end{description} 523 | 524 | 525 | 526 | \section{Other issues} 527 | 528 | 529 | \subsection{Improving Performance} 530 | Current implementation prefer the readability of the code to performance. If you are dealing with 531 | large scale problems, you might want to change some parts of the code. In general, this code is 532 | written for the case that number of parameters to be solved is not that large, (for example, less 533 | than 50) and evaluation of the objective function is costly. If this is not your problem, you 534 | might be able to get better performance for the following modifications. 535 | 536 | 537 | \paragraph{QR factorization} 538 | Other than the evaluation of the objective function, $QR$ decomposition would take most of the 539 | time in this algorithm. It is called at first and called occasionally afterward if the current 540 | approximation is suspected to contain substantial errors. If $n$ or $m$ is large (more than a few 541 | hundred $n$ or more than 10,000 $m$) and the evaluation of the objective function is not 542 | expensive, MINPACK's slow implementation of QR decomposition is likely to be a bottleneck. You 543 | should consider using high-quality linear algebra package like LAPACK. Also, LAPACK routine would 544 | improve the numerical stability of QR decomposition. 545 | 546 | \paragraph{Better solution of Locally quadratic problem} 547 | Also, faster speed can be attained by improving the dogleg method to the nearly exact solution 548 | using Cholesky factorization. It takes more time than the dogleg method per iteration. But improvement 549 | per iteration will be better. This appropriate when the evaluation of the function is costly and 550 | the number of the variables are small. 551 | 552 | 553 | \paragraph{Memory} 554 | The memory should not be a concern for modern computers if $n$ is less than 1000. 555 | 556 | If $n$ is larger than that, it might create a problem. This code stores a few $n$ by $n$ 557 | matrixes. To give you an idea for how serious this constraint is, here is the memory required to 558 | store matrixes: To store a 1,000 by 1,000 matrix with 8 bytes (double) precision, it requires 8 559 | Megabytes of memory. For 5,000 by 5,000 matrix, that is 190 Megabytes and for 10,000 by 10,000 560 | matrix, that is 762 Megabytes. In case memory binds, it is not too difficult to decrease the 561 | memory usage by 50\% or more with a little modification. For more memory savings, probably you 562 | need a substantial rewrite of the code based on conjugate gradient method instead of Newton Based or 563 | use sparse matrix. 564 | 565 | 566 | \subsection{Comparison with various methods} 567 | Here is the comparison of various methods with this method. 568 | 569 | \paragraph{Compared to Newton-Raphson method with BFGS, DFP, or BHHH} Great advantage of 570 | Newton-Raphson type method is its speed. But it is unstable, even if we update Jacobian/Hessian 571 | smartly using BFGS, DFP, or BHHH. The Newton Raphson method just has local convergence. It 572 | might fall into a cycle or diverge even if the function is smooth and globally concave unless the 573 | initial guess is sufficiently close to the true value. So here is the origin of the agony of 574 | initial guess. Also, Newton's method might take you to the saddle point. (see 575 | \cite{BjorckDahlquist2008} section 11.3 for more discussion) On the other hand, the modified 576 | Powell's Hybrid has global convergence property. It always converges if the first derivative is 577 | continuous and bounded, no matter what the initial point is. This is a great improvement in terms 578 | of convergence. For speed, the Hybrid method tries to use Newton-Raphson update whenever it looks 579 | safe. The Hybrid method is as good as that in Newton-Raphson if the initial guess is good. If the 580 | initial guess is not so good, only the Hybrid method has guaranteed converges. 581 | 582 | \paragraph{Compared to Newton-Raphson with Line search} 583 | (see \cite{BjorckDahlquist2008} section 11.3 for more discussion) To obtain global convergence, 584 | there are two ways. One is the trust region method which the Hybrid method is relied on, and the 585 | other is the line search method. They are different in what to do after we get the direction for 586 | improvement. For line search, it searches the extremum along the direction. And trust-region 587 | picks step size without function evaluation by local quadratic approximation. 588 | 589 | \paragraph{Compared to Conjugate Gradient and its derivatives} 590 | The Conjugate Gradient method stops relying on second order derivative entirely. Second order derivative is $n$ by $n$ matrix, which won't fit in the memory if $n$ is very large, such as the deep learning. The Powell's method cannot be applied for that case. 591 | 592 | 593 | \paragraph{Compared to Ameba/Downhill Simplex } Their advantage is an ability to deal with 594 | discontinuity. If the objective function contains severe discontinuities near the solution, you 595 | should consider this type. But it is VERY slow. In my experience, the Hybrid method is not that fragile to the mild discontinuity in both objective function and its derivative because of its trust region feature, although there is no mathematics to support the claim. I suggest trying to the Hybrid method first because it is much 596 | faster. Sophisticated termination criterion might be fooled by the discontinuity so you might want 597 | to restart it once it converges. 598 | 599 | \paragraph{Compared to Grid Search/Simulated annealing} 600 | The global convergence property of the Hybrid method is that it would converge to local 601 | extrema. Like any derivative-based method, it does not guarantees the global property of the point 602 | obtained. If there are many local extrema and you need a global solution, probably there is no 603 | choice other than Grid search or other globally convergent methods like the simulated annealing. 604 | 605 | \paragraph{Compared to bisection/Brent's method} If the problem contains only one equation, we 606 | have completely different algorithms. Bisection and its improvement, Brent's method, is regarded 607 | as robust algorithms that can be applied to highly discontinuous functions. The problem is that it 608 | requires two initial guesses which brackets the solution. It is not always easy to find them. I am 609 | not sure if they are so robust or fast if we consider the step of finding the bracket. The hybrid 610 | algorithm is faster than these algorithms with only one initial guess. But it may be trapped at 611 | the local extrema of the function. So it is your call to pick. 612 | 613 | \paragraph{Fixed point approach} \cite{SuJudd2008} is fiercely criticizing this approach. It 614 | makes some sense. But their solution, extensive usage of the canned package is not always a good idea. It is 615 | not so hard to understand the algorithm, once we have nice documentation. 616 | 617 | 618 | \section{Glossary} 619 | Here, $\fb(\xb)$ is system of equations which we want to make it zero, and $F(\xb)$ is scalar 620 | objective function which we want to minimize. 621 | \begin{description} 622 | \item[Jacobian] Jacobian is a matrix of first order derivatives, which comes from a vector 623 | valued function. \[ 624 | J_{ij} =\pdiff{f_i(\xb))}{x_j}\qquad J = \begin{pmatrix} 625 | \pdiff{f_1(\xb))}{x_1} & \cdots & \pdiff{f_1(\xb))}{x_n} \\ 626 | \vdots & \ddots & \vdots \\ 627 | \pdiff{f_n(\xb))}{x_1} & \cdot 628 | & \pdiff{f_n(\xb))}{x_n} \\ 629 | \end{pmatrix} 630 | \] 631 | \item[Gradient] Gradient is a vector of first order derivatives, which comes from a scalar 632 | valued function. This is another name of first order conditions. $\bigtriangledown F(\xb) = 633 | (\pdiff{F(\xb))}{x_1},\dots,\pdiff{F(\xb))}{x_N} )$ 634 | \item[Hessian] Hessian is a matrix of second order derivatives, which comes from a scalar 635 | valued function. $H = \bigtriangledown^2 F(\xb) =\bigtriangleup F(\xb)$. $ 636 | H_{ij}=\frac{\partial^2 F(\xb)}{\partial x_i \partial x_j}$. Hessian is a symmetric and 637 | positive semidefinite. 638 | \item[Hessian and Jacobian] Since the optimization problem is the same as finding zero in the first 639 | order conditions, Hessian of the objective function is Jacobian of first order 640 | conditions. But Jacobian from the first order conditions behaves better than ordinary 641 | Jacobian, because Hessian has several special features. Many variants of the Newton-Raphson 642 | algorithm exploit the fact for an efficient algorithm. 643 | \item[Newton-Raphson algorithm] This algorithm is both for solving a system of nonlinear 644 | equations and optimization. If it is applied for solving a system of nonlinear equations, it uses the locally linear approximation of the equations. Linear approximation requires a slope, 645 | which is Jacobian. If it is applied for the optimization problem, it uses a locally linear 646 | approximation to the first order conditions. Jacobian of the first order conditions is 647 | Hessian. So it requires Hessian. 648 | \item[BFGS/DFP update] Smart way to calculate Hessian in the Newton Raphson algorithm for 649 | optimization. BFGS update is weakly better than DFP update in a sense that BFGS and DFP 650 | performs almost identically for most of the problems and there are some cases BFGS is 651 | clearly better than DFP update. 652 | \item[BHHH update] Another smart way to calculate Hessian in the Newton Raphson algorithm for 653 | maximum likelihood problems. Although this is popular for econometricians, plain-vanilla 654 | implementation of the BHHH update is usually inferior to BFGS/DFP update. 655 | \item[Gauss-Newton's algorithm] Yet another smart way to calculate Hessian applicable to 656 | nonlinear least square problem. 657 | \item[Steepest Descent algorithm/Cauchy algorithm] This algorithm is for solving a 658 | optimization problem. It simply picks a direction which is inverse of gradient. If the step size 659 | is sufficiently small, it always improves the value of the objective function. For the 660 | determination of step size, a line search is usually used. It is also called the Cauchy 661 | algorithm. 662 | \end{description} 663 | 664 | \bibliographystyle{aer} 665 | 666 | 667 | \ifx\undefined\bysame 668 | \newcommand{\bysame}{\leavevmode\hbox to\leftmargin{\hrulefill\,\,}} 669 | \fi 670 | \begin{thebibliography}{xx} 671 | 672 | \harvarditem[Bjorck and Dahlquist]{Bjorck and 673 | Dahlquist}{2008}{BjorckDahlquist2008} 674 | {\bf Bjorck, Ake and Germund Dahlquist}, {\it Numerical Methods in Scientific 675 | Computing Volume II} 2008. 676 | 677 | \harvarditem[Nocedal and Wright]{Nocedal and Wright}{2000}{NocedalWright2000} 678 | {\bf Nocedal, Jorge and Stephen Wright}, {\it Numerical Optimization}, 679 | Springer, 2000. 680 | 681 | \harvarditem[Powell]{Powell}{1970a}{Powell1970a} 682 | {\bf Powell, Michael~J.D.}, ``A Fortran Subroutine For Solving Systems of 683 | Nonlinear Algebraic Equations,'' in Philip Rabnowitz, ed., {\it Nonlinear 684 | Methods for Nonlinear Algebraic Equations}, Gordon and Breach, Science 685 | Publishers Ltd., 1970, chapter~7. 686 | 687 | \harvarditem[Powell]{Powell}{1970b}{Powell1970} 688 | {\bf \bysame{}}, ``A Hybrid Method For Nonlinear Equations,'' in Philip 689 | Rabnowitz, ed., {\it Nonlinear Methods for Nonlinear Algebraic Equations}, 690 | Gordon and Breach, Science Publishers Ltd., 1970, chapter~6. 691 | 692 | \harvarditem[Su and Judd]{Su and Judd}{2008}{SuJudd2008} 693 | {\bf Su, Che-Lin and Kenneth~L. Judd}, ``Constrainted Optimization Approaches 694 | to Estimation of Structural Models,'' January 2008, (1460). 695 | 696 | \end{thebibliography} 697 | 698 | \end{document} -------------------------------------------------------------------------------- /documentation/aer.bst: -------------------------------------------------------------------------------- 1 | % BibTeX bibliography style `aer' (American Economic Review) 2 | % this file is based on the `harvard' family of files 3 | % version 0.99a for BibTeX versions 0.99a or later, LaTeX version 2.09. 4 | % Copyright (C) 1991, all rights reserved. 5 | % Copying of this file is authorized only if either 6 | % (1) you make absolutely no changes to your copy, including name, or 7 | % (2) if you do make changes, you name it something other than 8 | % btxbst.doc, plain.bst, unsrt.bst, alpha.bst, abbrv.bst, agsm.bst, 9 | % dcu.bst, cje.bst, aer.bst, or kluwer.bst. 10 | % This restriction helps ensure that all standard styles are identical. 11 | 12 | % ACKNOWLEDGEMENT: 13 | % This document is a modified version of alpha.bst to which it owes much of 14 | % its functionality. 15 | 16 | % AUTHOR 17 | % Peter Williams, Key Centre for Design Quality, Sydney University 18 | % e-mail: peterw@archsci.arch.su.oz.au 19 | 20 | ENTRY 21 | { address author booktitle chapter edition editor howpublished institution 22 | journal key month note number organization pages publisher school 23 | series title type volume year} 24 | { field.used } 25 | { label.touse extra.label sort.label list.year } 26 | 27 | 28 | FUNCTION {not} 29 | { { #0 } 30 | { #1 } 31 | if$ 32 | } 33 | 34 | FUNCTION {and} 35 | { {} 36 | { pop$ #0 } 37 | if$ 38 | } 39 | 40 | FUNCTION {or} 41 | { { pop$ #1 } 42 | {} 43 | if$ 44 | } 45 | 46 | INTEGERS {quoted italic bold plain attribute 47 | space comma tiedcomma semicolon colon period block empty separator 48 | prev.separator next.separator next.attribute} 49 | 50 | STRINGS { s temp f name.list first.name.format later.name.formats name.style} 51 | 52 | FUNCTION {init.state.consts} 53 | { 54 | #100 'quoted := 55 | #200 'italic := 56 | #300 'bold := 57 | #400 'plain := 58 | 59 | #7 'space := 60 | #6 'comma := 61 | % #5 'tiedcomma := 62 | % #4 'semicolon := 63 | #3 'colon := 64 | #2 'period := 65 | #1 'block := 66 | #0 'empty := 67 | } 68 | 69 | FUNCTION {output2} 70 | { 71 | % Wrap the attribute. 72 | attribute bold = {"{\bf " swap$ * "}" *} {} if$ 73 | attribute italic = {"{\it " swap$ * "}" *} {} if$ 74 | attribute quoted = {"``" swap$ * "''" *} {} if$ 75 | % Append additional separators 76 | separator comma = {"," * space 'separator :=} {} if$ 77 | % separator tiedcomma = {",~" * empty 'separator :=} {} if$ 78 | separator space = {" " *} {} if$ 79 | write$ 80 | separator block = {newline$ "\newblock " write$} {} if$ 81 | % Update variables, and put the new string back on the stack 82 | next.attribute 'attribute := 83 | next.separator 'separator := 84 | temp 85 | } 86 | 87 | % output 88 | FUNCTION {output.nonnull} 89 | { 'next.separator := 90 | 'next.attribute := 91 | 'temp := 92 | 'prev.separator := 93 | % If the new separator is stronger than the previous one, use it. 94 | prev.separator separator < {prev.separator 'separator :=} {} if$ 95 | % Append most separators to the string. 96 | separator block = {add.period$} {} if$ 97 | separator period = {add.period$ space 'separator :=} {} if$ 98 | % separator semicolon = {";" * space 'separator :=} {} if$ 99 | separator colon = {":" * space 'separator :=} {} if$ 100 | separator comma = attribute quoted = and 101 | {"," * space 'separator :=} {} if$ 102 | output2 103 | } 104 | 105 | FUNCTION {output} 106 | { 'next.separator := 107 | 'next.attribute := 108 | duplicate$ empty$ 109 | {pop$ pop$} 110 | {next.attribute next.separator output.nonnull} 111 | if$ 112 | } 113 | 114 | FUNCTION {output.check} 115 | { 's := 116 | 'next.separator := 117 | 'next.attribute := 118 | duplicate$ empty$ 119 | {pop$ pop$ "empty " s * " in " * cite$ * warning$ } 120 | {next.attribute next.separator output.nonnull} 121 | if$ 122 | } 123 | 124 | FUNCTION {item.check} 125 | { 'temp := 126 | empty$ 127 | { "empty " temp * " in " * cite$ * warning$ } 128 | {} 129 | if$ 130 | } 131 | 132 | FUNCTION {plain.space} { plain space } 133 | 134 | FUNCTION {plain.space.output} { plain.space output } 135 | 136 | FUNCTION {plain.comma} { plain comma } 137 | 138 | FUNCTION {fin.entry} 139 | { 140 | block note plain.space.output 141 | period "" plain empty output.nonnull pop$ 142 | newline$ 143 | } 144 | 145 | FUNCTION {field.or.null} 146 | { duplicate$ empty$ 147 | { pop$ "" } 148 | {} 149 | if$ 150 | } 151 | 152 | FUNCTION {emphasize} 153 | { duplicate$ empty$ 154 | { pop$ "" } 155 | { "{\em " swap$ * "}" * } 156 | if$ 157 | } 158 | 159 | FUNCTION {quote} 160 | { duplicate$ empty$ 161 | { pop$ "" } 162 | { add.period$ "`" swap$ * "'" * } 163 | if$ 164 | } 165 | 166 | 167 | % compare.names 168 | INTEGERS {len1 len2 i} 169 | FUNCTION {compare.names} 170 | { 's := 171 | 'temp := 172 | temp num.names$ 'len1 := 173 | s num.names$ 'len2 := 174 | % len1 := min(len1,len2) 175 | len1 len2 > {len2 'len1 :=} {} if$ 176 | % start with an empty string, then while the components are the same 177 | % add "\bysame" 178 | "" 179 | #1 'i := 180 | {i len1 > not} 181 | { temp i "{ff }{vv }{ll}{ jj}" format.name$ 182 | % duplicate$ i int.to.str$ * warning$ 183 | s i "{ff }{vv }{ll}{ jj}" format.name$ 184 | % duplicate$ i int.to.str$ * warning$ 185 | = 186 | { #1 i < {" and " *} {} if$ 187 | "\bysame{}" * i #1 + 'i :=} 188 | {#-1 'len1 :=} 189 | if$ 190 | } 191 | while$ 192 | % add the rest of the second string 193 | {i len2 > not} 194 | { #1 i < {" and " *} {} if$ 195 | s i "{ff }{vv }{ll}{ jj}" format.name$ * 196 | i #1 + 'i := 197 | } 198 | while$ 199 | % duplicate$ warning$ 200 | } 201 | 202 | INTEGERS { nameptr namesleft numnames } 203 | 204 | FUNCTION {format.names} 205 | { 'name.list := 206 | 'name.style := 207 | 'later.name.formats := 208 | 's := % binary separator 209 | 'first.name.format := 210 | #1 'nameptr := 211 | name.list num.names$ 'numnames := 212 | % If we're to make this entry bold or something, prepend to the string of names 213 | name.style "" = {} {"{" name.style *} if$ 214 | numnames 'namesleft := 215 | { namesleft #0 > } 216 | { name.list nameptr nameptr #1 = {first.name.format} {later.name.formats} if$ 217 | format.name$ 'temp := 218 | nameptr #1 > 219 | { namesleft #1 > 220 | { ", " * temp * } 221 | { temp "others" = 222 | { " et~al." * } 223 | {nameptr #2 = % handle ", and" vs " and " 224 | {s * temp *} 225 | {", and " * temp * } 226 | if$ 227 | } 228 | if$ 229 | } 230 | if$ 231 | } 232 | 'temp 233 | if$ 234 | nameptr #1 + 'nameptr := 235 | namesleft #1 - 'namesleft := 236 | } 237 | while$ 238 | % If we're to make this entry bold or something, append to the string of names 239 | name.style "" = {} {"}" * *} if$ 240 | } 241 | 242 | FUNCTION {format.authors} 243 | { 'temp := 244 | "{vv~}{ll}{, jj}{, ff}" " and " "{ff~}{vv~}{ll}{, jj}" "" temp 245 | format.names 246 | } 247 | 248 | FUNCTION {format.editors} 249 | { 'temp := 250 | "{vv~}{ll}{, jj}{, ff}" " and " "{ff~}{vv~}{ll}{, jj}" "" 251 | temp format.names 252 | editor num.names$ #1 > 253 | { ", eds" * } 254 | { ", ed." * } 255 | if$ 256 | } 257 | 258 | FUNCTION {format.editors.notkey} 259 | { editor empty$ 260 | { "" } 261 | { "{ff~}{vv~}{ll}{, jj}" " and " "{ff~}{vv~}{ll}{, jj}" "" 262 | editor format.names 263 | editor num.names$ #1 > {", eds."} {", ed."} if$ 264 | * 265 | } 266 | if$ 267 | } 268 | 269 | FUNCTION {format.title} 270 | { space title quoted comma } 271 | 272 | FUNCTION {n.dashify} 273 | { 'temp := 274 | "" 275 | { temp empty$ not } 276 | { temp #1 #1 substring$ "-" = 277 | { temp #1 #2 substring$ "--" = not 278 | { "--" * 279 | temp #2 global.max$ substring$ 'temp := 280 | } 281 | { { temp #1 #1 substring$ "-" = } 282 | { "-" * 283 | temp #2 global.max$ substring$ 'temp := 284 | } 285 | while$ 286 | } 287 | if$ 288 | } 289 | { temp #1 #1 substring$ * 290 | temp #2 global.max$ substring$ 'temp := 291 | } 292 | if$ 293 | } 294 | while$ 295 | } 296 | 297 | FUNCTION {format.btitle} 298 | { title emphasize 299 | } 300 | 301 | FUNCTION {tie.or.space.connect} 302 | { duplicate$ text.length$ #3 < 303 | { "~" } 304 | { " " } 305 | if$ 306 | swap$ * * 307 | } 308 | 309 | FUNCTION {either.or.check} 310 | { empty$ 311 | 'pop$ 312 | { "can't use both " swap$ * " fields in " * cite$ * warning$ } 313 | if$ 314 | } 315 | 316 | FUNCTION {format.bvolume} 317 | { volume empty$ 318 | { "" } 319 | { "Vol." volume tie.or.space.connect 320 | series empty$ 321 | {} 322 | { " of " * series emphasize * } 323 | if$ 324 | "volume and number" number either.or.check 325 | } 326 | if$ 327 | } 328 | 329 | FUNCTION {format.bvolume.output} 330 | {comma format.bvolume plain.space.output} 331 | 332 | FUNCTION {mid.sentence.q} 333 | { 334 | separator empty = separator block = separator period = or or not 335 | } 336 | 337 | FUNCTION {format.number.series} 338 | { volume empty$ 339 | { number empty$ 340 | {series field.or.null} 341 | { mid.sentence.q 342 | { "number" } 343 | { "Number" } 344 | if$ 345 | number tie.or.space.connect 346 | series empty$ 347 | { "there's a number but no series in " cite$ * warning$ } 348 | { add.period$ " In " * series quote * } 349 | if$ 350 | } 351 | if$ 352 | } 353 | { "" } 354 | if$ 355 | } 356 | 357 | FUNCTION {format.edition.output} 358 | { edition empty$ 359 | { } 360 | { comma edition 361 | mid.sentence.q { "l" } { "t" } if$ 362 | change.case$ " ed." * 363 | plain.space.output 364 | } 365 | if$ 366 | } 367 | 368 | FUNCTION {format.publisher.address} 369 | { 370 | address empty$ 371 | {comma publisher plain.comma output} 372 | {publisher empty$ 373 | {} 374 | {comma address plain colon output 375 | colon publisher plain.comma output} 376 | if$} 377 | if$ 378 | } 379 | 380 | INTEGERS { multiresult } 381 | 382 | FUNCTION {multi.page.check} 383 | { 'temp := 384 | #0 'multiresult := 385 | { multiresult not 386 | temp empty$ not 387 | and 388 | } 389 | { temp #1 #1 substring$ 390 | duplicate$ "-" = 391 | swap$ duplicate$ "," = 392 | swap$ "+" = 393 | or or 394 | { #1 'multiresult := } 395 | { temp #2 global.max$ substring$ 'temp := } 396 | if$ 397 | } 398 | while$ 399 | multiresult 400 | } 401 | 402 | FUNCTION {format.pages} 403 | { pages empty$ 404 | { "" } 405 | { pages multi.page.check 406 | { "pp.~" pages n.dashify * } 407 | { "p.~" pages * } 408 | if$ 409 | } 410 | if$ 411 | } 412 | 413 | FUNCTION {output.month.year} 414 | { 415 | space month plain.space.output 416 | space year plain.comma "year" output.check 417 | } 418 | 419 | FUNCTION {output.vol.num.pages} 420 | { space volume italic space output 421 | number empty$ 422 | {} 423 | { space "(" number * ")" * plain.comma output.nonnull 424 | volume empty$ 425 | { "there's a number but no volume in " cite$ * warning$ } 426 | {} 427 | if$ 428 | } 429 | if$ 430 | % "*** a" warning$ 431 | comma 'next.separator := % hack 432 | pages empty$ 433 | {} 434 | { number empty$ volume empty$ and 435 | { comma format.pages plain.space.output } 436 | { comma pages n.dashify plain.space.output } 437 | if$ 438 | } 439 | if$ 440 | } 441 | 442 | FUNCTION {format.chapter.pages} 443 | { chapter empty$ 444 | 'format.pages 445 | { type empty$ 446 | { "chapter" } 447 | { type "l" change.case$ } 448 | if$ 449 | chapter tie.or.space.connect 450 | pages empty$ 451 | {} 452 | { ", " * format.pages * } 453 | if$ 454 | } 455 | if$ 456 | } 457 | 458 | FUNCTION {output.in.ed.booktitle} 459 | { booktitle "booktitle" item.check 460 | comma "in" plain.space output.nonnull 461 | editor empty$ 462 | { space booktitle quoted space output.nonnull} 463 | { space format.editors.notkey plain.space output.nonnull 464 | comma booktitle italic comma output.nonnull 465 | } 466 | if$ 467 | } 468 | 469 | FUNCTION {empty.misc.check} 470 | { author empty$ title empty$ howpublished empty$ 471 | month empty$ year empty$ note empty$ 472 | and and and and and 473 | key empty$ not and 474 | { "all relevant fields are empty in " cite$ * warning$ } 475 | {} 476 | if$ 477 | } 478 | 479 | FUNCTION {format.thesis.type} 480 | { type empty$ 481 | {} 482 | { pop$ 483 | type "t" change.case$ 484 | } 485 | if$ 486 | } 487 | 488 | FUNCTION {format.tr.number} 489 | { type empty$ 490 | { "Technical Report" } 491 | 'type 492 | if$ 493 | number empty$ 494 | { } 495 | { number tie.or.space.connect } 496 | if$ 497 | } 498 | 499 | FUNCTION {format.article.crossref} 500 | { key empty$ 501 | { journal empty$ 502 | { "need key or journal for " cite$ * " to crossref " * crossref * 503 | warning$ 504 | "" 505 | } 506 | { "in {\it " journal * "\/} \cite{" * crossref * "}" *} 507 | if$ 508 | } 509 | { add.period$ "In \citeasnoun{" crossref * "}" * } 510 | if$ 511 | 512 | } 513 | 514 | FUNCTION {format.book.crossref} 515 | { volume empty$ 516 | { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ 517 | "in " 518 | } 519 | { "Vol." volume tie.or.space.connect 520 | " of " * 521 | } 522 | if$ 523 | editor empty$ 524 | editor field.or.null author field.or.null = 525 | or 526 | { key empty$ 527 | { series empty$ 528 | { "need editor, key, or series for " cite$ * " to crossref " * 529 | crossref * warning$ 530 | "" * 531 | } 532 | { "{\it " * series * "\/} \cite{" * crossref * "}" *} 533 | if$ 534 | } 535 | { " \citeasnoun{" * crossref * "}" * } 536 | if$ 537 | } 538 | { " \citeasnoun{" * crossref * "}" * } 539 | if$ 540 | } 541 | 542 | FUNCTION {output.incoll.inproc.crossref} 543 | { editor empty$ 544 | editor field.or.null author field.or.null = 545 | or 546 | { key empty$ 547 | { booktitle empty$ 548 | { "need editor, key, or booktitle for " cite$ * " to crossref " * 549 | crossref * warning$ 550 | } 551 | { period "In {\it " booktitle * "\/}" * " \cite{" * crossref * "}" * plain.space output.nonnull} 552 | if$ 553 | } 554 | { period "In \citeasnoun{" crossref * "}" * plain.space output.nonnull} 555 | if$ 556 | } 557 | { period "In \citeasnoun{" crossref * "}" * plain.space output.nonnull} 558 | if$ 559 | } 560 | 561 | INTEGERS { len } 562 | 563 | FUNCTION {chop.word} 564 | { 's := 565 | 'len := 566 | s #1 len substring$ = 567 | { s len #1 + global.max$ substring$ } 568 | 's 569 | if$ 570 | } 571 | 572 | INTEGERS { author.field editor.field organization.field title.field key.field } 573 | 574 | FUNCTION {init.field.constants} 575 | { #0 'author.field := 576 | #1 'editor.field := 577 | #2 'organization.field := 578 | #3 'title.field := 579 | #4 'key.field := 580 | } 581 | 582 | FUNCTION {format.lab.names.abbr} 583 | { 'name.list := 584 | name.list num.names$ 'numnames := 585 | numnames #1 > 586 | { numnames #2 > 587 | { name.list #1 "{vv~}{ll}" format.name$ " et al." * } 588 | { name.list #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = 589 | { name.list #1 "{vv~}{ll}" format.name$ " et al." * } 590 | { name.list #1 "{vv~}{ll}" format.name$ " and " * 591 | name.list #2 "{vv~}{ll}" format.name$ * 592 | } 593 | if$ 594 | } 595 | if$ 596 | field.used editor.field = {", eds" *} {} if$ 597 | } 598 | { 599 | name.list #1 "{vv~}{ll}" format.name$ 600 | field.used editor.field = {", ed" *} {} if$ 601 | } 602 | if$ 603 | } 604 | 605 | FUNCTION {format.lab.names.full} 606 | { 'name.list := 607 | #1 'nameptr := 608 | name.list num.names$ 'numnames := 609 | numnames 'namesleft := 610 | { namesleft #0 > } 611 | { name.list nameptr "{vv~}{ll}" format.name$ 'temp := 612 | nameptr #1 > 613 | { namesleft #1 > 614 | { ", " * temp * } 615 | { temp "others" = 616 | { " et~al." * } 617 | { " and " * temp * } 618 | if$ 619 | } 620 | if$ 621 | } 622 | 'temp 623 | if$ 624 | nameptr #1 + 'nameptr := 625 | namesleft #1 - 'namesleft := 626 | } 627 | while$ 628 | numnames #1 > field.used editor.field = and {", eds" *} {} if$ 629 | numnames #1 = field.used editor.field = and {", ed" *} {} if$ 630 | } 631 | 632 | STRINGS { prev.author } 633 | 634 | FUNCTION {make.list.label} 635 | {author.field field.used = 636 | { prev.author author compare.names format.authors 637 | author 'prev.author :=} 638 | { editor.field field.used = 639 | { prev.author editor compare.names format.editors 640 | editor 'prev.author := } 641 | { organization.field field.used = 642 | { "The " #4 organization chop.word 643 | duplicate$ prev.author = {pop$ "\bysame{}"} 644 | {duplicate$ 'prev.author :=} if$} 645 | { "foo" 'prev.author := 646 | title.field field.used = 647 | { format.btitle } 648 | { key.field field.used = 649 | { key #3 text.prefix$ } 650 | { "Internal error :001 on " cite$ * " label" * warning$ } 651 | if$ 652 | } 653 | if$ 654 | } 655 | if$ 656 | } 657 | if$ 658 | } 659 | if$ 660 | } 661 | 662 | FUNCTION {make.full.label} 663 | { author.field field.used = 664 | { author format.lab.names.full } 665 | { editor.field field.used = 666 | { editor format.lab.names.full } 667 | { organization.field field.used = 668 | { "The " #4 organization chop.word #3 text.prefix$ } 669 | { title.field field.used = 670 | { format.btitle } 671 | { key.field field.used = 672 | { key #3 text.prefix$ } 673 | { "Internal error :001 on " cite$ * " label" * warning$ } 674 | if$ 675 | } 676 | if$ 677 | } 678 | if$ 679 | } 680 | if$ 681 | } 682 | if$ 683 | } 684 | 685 | FUNCTION {make.abbr.label} 686 | { author.field field.used = 687 | { author format.lab.names.abbr } 688 | { editor.field field.used = 689 | { editor format.lab.names.abbr } 690 | { organization.field field.used = 691 | { "The " #4 organization chop.word #3 text.prefix$ } 692 | { title.field field.used = 693 | { format.btitle } 694 | { key.field field.used = 695 | { key #3 text.prefix$ } 696 | { "Internal error :001 on " cite$ * " label" * warning$ } 697 | if$ 698 | } 699 | if$ 700 | } 701 | if$ 702 | } 703 | if$ 704 | } 705 | if$ 706 | } 707 | 708 | FUNCTION {output.bibitem} 709 | { newline$ 710 | "\harvarditem[" write$ 711 | make.abbr.label write$ 712 | "]{" write$ 713 | make.full.label write$ 714 | "}{" write$ 715 | list.year write$ 716 | "}{" write$ 717 | cite$ write$ 718 | "}" write$ 719 | newline$ 720 | "" 721 | empty 'separator := 722 | plain 'attribute := 723 | % } 724 | % 725 | % FUNCTION {list.label.output} 726 | % { 727 | space make.list.label bold comma output.nonnull 728 | } 729 | 730 | FUNCTION {author.item.check} {author "author" item.check} 731 | 732 | FUNCTION {format.title.if.not.sortkey.check} 733 | {title.field field.used = 734 | {} 735 | { format.title "title" output.check } 736 | if$} 737 | 738 | FUNCTION {article} 739 | { output.bibitem 740 | author.item.check 741 | format.title.if.not.sortkey.check 742 | crossref missing$ 743 | { space journal italic comma "journal" output.check 744 | output.month.year 745 | output.vol.num.pages 746 | } 747 | { space format.article.crossref plain.space output.nonnull 748 | comma format.pages plain.space.output 749 | } 750 | if$ 751 | fin.entry 752 | } 753 | 754 | FUNCTION {book} 755 | { output.bibitem 756 | author empty$ 757 | { editor "author and editor" item.check } 758 | { crossref missing$ 759 | { "author and editor" editor either.or.check } 760 | {} 761 | if$ 762 | } 763 | if$ 764 | title.field field.used = 765 | {} 766 | { space title italic space "title" output.check } 767 | if$ 768 | crossref missing$ 769 | { 770 | space format.number.series plain.space.output 771 | format.edition.output 772 | format.bvolume.output 773 | format.publisher.address 774 | output.month.year 775 | } 776 | { space format.book.crossref plain.space output.nonnull 777 | format.edition.output 778 | } 779 | if$ 780 | fin.entry 781 | } 782 | 783 | FUNCTION {booklet} 784 | { output.bibitem 785 | format.title.if.not.sortkey.check 786 | space howpublished plain.space.output 787 | space address plain.space.output 788 | output.month.year 789 | fin.entry 790 | } 791 | 792 | FUNCTION {inbook} 793 | { output.bibitem 794 | author empty$ 795 | { editor "author and editor" item.check } 796 | { crossref missing$ 797 | { "author and editor" editor either.or.check } 798 | {} 799 | if$ 800 | } 801 | if$ 802 | title.field field.used = 803 | {} 804 | { space title italic space "title" output.check } 805 | if$ 806 | crossref missing$ 807 | { space format.number.series plain.space.output 808 | format.edition.output 809 | comma format.bvolume plain.comma output 810 | format.publisher.address 811 | output.month.year 812 | } 813 | { space format.book.crossref plain.space output.nonnull 814 | format.edition.output 815 | } 816 | if$ 817 | format.chapter.pages "chapter and pages" output.check 818 | fin.entry 819 | } 820 | 821 | FUNCTION {incollection} 822 | { output.bibitem 823 | format.title.if.not.sortkey.check 824 | author.item.check 825 | crossref missing$ 826 | { output.in.ed.booktitle 827 | format.edition.output 828 | format.bvolume.output 829 | space format.number.series plain.space.output 830 | format.publisher.address 831 | output.month.year 832 | } 833 | { output.incoll.inproc.crossref } 834 | if$ 835 | space format.chapter.pages plain.space.output 836 | fin.entry 837 | } 838 | 839 | FUNCTION {inproceedings} 840 | { output.bibitem 841 | format.title.if.not.sortkey.check 842 | author.item.check 843 | crossref missing$ 844 | { output.in.ed.booktitle 845 | format.bvolume.output 846 | space format.number.series plain.space.output 847 | address empty$ 848 | { space organization plain.space.output 849 | space publisher plain.space.output 850 | } 851 | { space organization plain.space.output 852 | space publisher plain.space.output 853 | space address plain.space output.nonnull 854 | } 855 | if$ 856 | output.month.year 857 | } 858 | { output.incoll.inproc.crossref} 859 | if$ 860 | space format.pages plain.space.output 861 | fin.entry 862 | } 863 | 864 | FUNCTION {conference} { inproceedings } 865 | 866 | FUNCTION {manual} 867 | { output.bibitem 868 | title.field field.used = 869 | {} 870 | {author empty$ {comma}{space} if$ title italic space "title" output.check } 871 | if$ 872 | organization.field field.used = organization empty$ or 873 | {} {space organization plain.space output.nonnull} if$ 874 | format.edition.output 875 | format.publisher.address 876 | output.month.year 877 | fin.entry 878 | } 879 | 880 | FUNCTION {mastersthesis} 881 | { output.bibitem 882 | author.item.check 883 | format.title.if.not.sortkey.check 884 | space "Master's thesis" format.thesis.type plain.space output.nonnull 885 | comma school plain.space "school" output.check 886 | comma address plain.space.output 887 | output.month.year 888 | fin.entry 889 | } 890 | 891 | FUNCTION {misc} 892 | { output.bibitem 893 | format.title.if.not.sortkey.check 894 | space howpublished plain.space.output 895 | output.month.year 896 | fin.entry 897 | empty.misc.check 898 | } 899 | 900 | FUNCTION {phdthesis} 901 | { output.bibitem 902 | author.item.check 903 | title.field field.used = 904 | {} 905 | { space title quoted period "title" output.check } 906 | if$ 907 | space "PhD dissertation" format.thesis.type plain.space output.nonnull 908 | comma school plain.space "school" output.check 909 | comma address plain.space.output 910 | output.month.year 911 | fin.entry 912 | } 913 | 914 | FUNCTION {proceedings} 915 | { output.bibitem 916 | title.field field.used = 917 | {} 918 | { space title italic space "title" output.check } 919 | if$ 920 | format.bvolume.output 921 | space format.number.series plain.space.output 922 | address empty$ 923 | { editor empty$ 924 | {} 925 | { space organization plain.space.output 926 | } 927 | if$ 928 | space publisher plain.space.output 929 | } 930 | { editor empty$ 931 | {} 932 | { space organization plain.space.output } 933 | if$ 934 | space publisher plain.space.output 935 | space address plain.space output.nonnull 936 | } 937 | if$ 938 | output.month.year 939 | fin.entry 940 | } 941 | 942 | FUNCTION {techreport} 943 | { output.bibitem 944 | author.item.check 945 | format.title.if.not.sortkey.check 946 | space format.tr.number plain.space output.nonnull 947 | institution empty$ 948 | {} 949 | { comma institution plain.space "institution" output.check } 950 | if$ 951 | comma address plain.space.output 952 | output.month.year 953 | fin.entry 954 | } 955 | 956 | FUNCTION {unpublished} 957 | { output.bibitem 958 | author.item.check 959 | format.title.if.not.sortkey.check 960 | output.month.year 961 | note "note" item.check 962 | fin.entry 963 | } 964 | 965 | FUNCTION {default.type} { misc } 966 | 967 | MACRO {jan} {"January"} 968 | 969 | MACRO {feb} {"February"} 970 | 971 | MACRO {mar} {"March"} 972 | 973 | MACRO {apr} {"April"} 974 | 975 | MACRO {may} {"May"} 976 | 977 | MACRO {jun} {"June"} 978 | 979 | MACRO {jul} {"July"} 980 | 981 | MACRO {aug} {"August"} 982 | 983 | MACRO {sep} {"September"} 984 | 985 | MACRO {oct} {"October"} 986 | 987 | MACRO {nov} {"November"} 988 | 989 | MACRO {dec} {"December"} 990 | 991 | READ 992 | 993 | EXECUTE {init.field.constants} 994 | 995 | FUNCTION {sortify} 996 | { purify$ 997 | "l" change.case$ 998 | } 999 | 1000 | FUNCTION {author.editor.key.label} 1001 | { author empty$ 1002 | { editor empty$ 1003 | { title empty$ 1004 | { key.field 'field.used := } 1005 | { title.field 'field.used := } 1006 | if$ 1007 | } 1008 | { editor.field 'field.used := } 1009 | if$ 1010 | } 1011 | { author.field 'field.used := } 1012 | if$ 1013 | } 1014 | 1015 | FUNCTION {key.organization.label} 1016 | {organization empty$ 1017 | { title empty$ 1018 | { key.field 'field.used := } 1019 | { title.field 'field.used := } 1020 | if$ 1021 | } 1022 | { organization.field 'field.used := } 1023 | if$} 1024 | 1025 | FUNCTION {author.key.organization.label} 1026 | { author empty$ 1027 | { key.organization.label} 1028 | { author.field 'field.used := } 1029 | if$ 1030 | } 1031 | 1032 | FUNCTION {editor.key.organization.label} 1033 | { editor empty$ 1034 | { key.organization.label} 1035 | { editor.field 'field.used := } 1036 | if$ 1037 | } 1038 | 1039 | FUNCTION {sort.format.title} 1040 | { 'temp := 1041 | "A " #2 1042 | "An " #3 1043 | "The " #4 temp chop.word 1044 | chop.word 1045 | chop.word 1046 | sortify 1047 | #1 global.max$ substring$ 1048 | } 1049 | 1050 | FUNCTION {calc.label} 1051 | { type$ "book" = 1052 | type$ "inbook" = 1053 | or 1054 | 'author.editor.key.label 1055 | { type$ "proceedings" = 1056 | 'editor.key.organization.label 1057 | { type$ "manual" = 1058 | 'author.key.organization.label 1059 | 'author.editor.key.label % don't really use .editor. 1060 | if$ 1061 | } 1062 | if$ 1063 | } 1064 | if$ 1065 | make.abbr.label 1066 | title.field field.used = 1067 | { sort.format.title } 1068 | { sortify } 1069 | if$ 1070 | year field.or.null purify$ #-1 #4 substring$ sortify 1071 | * 1072 | 'sort.label := 1073 | } 1074 | 1075 | FUNCTION {first.presort} 1076 | { "abcxyz" 'prev.author := 1077 | calc.label 1078 | sort.label 1079 | title.field field.used = 1080 | {} 1081 | { " " 1082 | * 1083 | make.list.label sortify 1084 | * 1085 | " " 1086 | * 1087 | title field.or.null 1088 | sort.format.title 1089 | * 1090 | } 1091 | if$ 1092 | #1 entry.max$ substring$ 1093 | 'sort.key$ := 1094 | } 1095 | 1096 | 1097 | ITERATE {first.presort} 1098 | 1099 | SORT 1100 | 1101 | STRINGS { last.sort.label next.extra } 1102 | 1103 | INTEGERS { last.extra.num } 1104 | 1105 | FUNCTION {initialize.last.extra.num} 1106 | { #0 int.to.chr$ 'last.sort.label := 1107 | "" 'next.extra := 1108 | #0 'last.extra.num := 1109 | } 1110 | 1111 | FUNCTION {forward.pass} 1112 | { last.sort.label sort.label = 1113 | { last.extra.num #1 + 'last.extra.num := 1114 | last.extra.num int.to.chr$ 'extra.label := 1115 | } 1116 | { "a" chr.to.int$ 'last.extra.num := 1117 | "" 'extra.label := 1118 | sort.label 'last.sort.label := 1119 | } 1120 | if$ 1121 | } 1122 | 1123 | FUNCTION {reverse.pass} 1124 | { next.extra "b" = 1125 | { "a" 'extra.label := } 1126 | {} 1127 | if$ 1128 | year empty$ 1129 | { "n.d." extra.label * 'list.year := } 1130 | { year extra.label * 'list.year := } 1131 | if$ 1132 | extra.label 'next.extra := 1133 | } 1134 | 1135 | EXECUTE {initialize.last.extra.num} 1136 | 1137 | ITERATE {forward.pass} 1138 | 1139 | REVERSE {reverse.pass} 1140 | 1141 | FUNCTION {second.presort} 1142 | { "abcxyz" 'prev.author := 1143 | make.list.label 1144 | title.field field.used = 1145 | { sort.format.title } 1146 | { sortify } 1147 | if$ 1148 | " " 1149 | * 1150 | list.year field.or.null sortify 1151 | * 1152 | " " 1153 | * 1154 | title.field field.used = 1155 | {} 1156 | { title field.or.null 1157 | sort.format.title 1158 | * 1159 | } 1160 | if$ 1161 | #1 entry.max$ substring$ 1162 | 'sort.key$ := 1163 | } 1164 | 1165 | ITERATE {second.presort} 1166 | 1167 | SORT 1168 | 1169 | 1170 | INTEGERS { number.label } 1171 | 1172 | FUNCTION {initialize.longest.label} 1173 | { 1174 | #1 'number.label := 1175 | "abcxyz" 'prev.author := 1176 | } 1177 | 1178 | FUNCTION {longest.label.pass} 1179 | { 1180 | "" 'extra.label := 1181 | author empty$ { editor empty$ {"foo"} {editor} if$} 1182 | {author} 1183 | if$ 1184 | 'f := 1185 | % remember this entry to compare to the next one 1186 | author empty$ { editor empty$ {"abcxyz"} {editor} if$} {author} if$ 1187 | 'prev.author := 1188 | } 1189 | 1190 | EXECUTE {initialize.longest.label} 1191 | 1192 | ITERATE {longest.label.pass} 1193 | 1194 | FUNCTION {begin.bib} 1195 | { preamble$ empty$ 1196 | {} 1197 | { preamble$ write$ newline$ } 1198 | if$ 1199 | "\ifx\undefined\bysame" write$ newline$ 1200 | "\newcommand{\bysame}{\leavevmode\hbox to\leftmargin{\hrulefill\,\,}}" 1201 | write$ newline$ 1202 | "\fi" write$ newline$ 1203 | "\begin{thebibliography}{xx}" write$ newline$ 1204 | } 1205 | 1206 | EXECUTE {begin.bib} 1207 | 1208 | EXECUTE {init.state.consts} 1209 | 1210 | FUNCTION {init.call} 1211 | { "abcxyz" 'prev.author := } 1212 | 1213 | EXECUTE {init.call} 1214 | 1215 | ITERATE {call.type$} 1216 | 1217 | FUNCTION {end.bib} 1218 | {newline$ "\end{thebibliography}" write$ newline$ } 1219 | 1220 | EXECUTE {end.bib} 1221 | 1222 | -------------------------------------------------------------------------------- /fzero.f90: -------------------------------------------------------------------------------- 1 | 2 | module fzero 3 | ! This module is for finding a root of function(s). This contains 4 | ! following items: 5 | ! 6 | ! FUNCTIONS: 7 | ! brent (fun, x0, tol, LowerBound, UpperBound, detail) 8 | ! Find root of a function using Brent's method. This function tries to 9 | ! find x1 and x2 such that sign of f(x1) and f(x2) are not equal. Then it 10 | ! calls brent0(). 11 | ! 12 | ! brent0 (fun, x1, x2, tol, detail) 13 | ! Fund root of function fun given TWO intial values. 14 | ! 15 | ! fun1(x) ... fun3(x) 16 | ! Test functions for maximization problem 17 | ! 18 | ! SUBROUTINES: 19 | ! test_functions() 20 | ! It tests functions defined in this module. 21 | 22 | 23 | 24 | 25 | contains 26 | function brent0 (fun, x1, x2, tol, detail) 27 | ! Find zero in a fucntion fun using the Brent's method 28 | ! 29 | ! Description of algorithm: 30 | ! Find a root of function f(x) given intial bracketing interval [a,b] 31 | ! where f(a) and f(b) must have opposite signs. At a typical step we have 32 | ! three points a, b, and c such that f(b)f(c)<0, and a may coincide with 33 | ! c. The points a, b, and c change during the algorithm, and the root 34 | ! always lies in either [b,c] or [c, b]. The value b is the best 35 | ! approximation to the root and a is the previous value of b. 36 | ! 37 | ! The iteration uses following selection of algorithms 38 | ! when bracket shrinks reasonablly fast, 39 | ! - Linear interporation if a == b 40 | ! - Quadratic interporation if a != b and the point is in the bracket. 41 | ! othrwise 42 | ! - Bisection. 43 | ! 44 | ! Inputs: 45 | ! fun: function to be solved 46 | ! x0, x1: Upper bound and lower bound for a function 47 | ! tol: error tolerance. 48 | ! detail (optional): output result of iteration if detail is some value. 49 | ! 50 | ! Date: Jan 30, 09 51 | ! Based on zeroin.f in netlib 52 | 53 | implicit none 54 | integer, parameter :: d = selected_real_kind(p=13,r=200) 55 | real(kind=d) :: brent0 56 | real(kind=d), intent(IN) :: x1, x2, tol 57 | real(kind=d), external :: fun 58 | integer, intent(IN), optional :: detail 59 | integer :: i, exitflag, disp 60 | real(kind=d) :: a, b, c, diff,e, fa, fb, fc, p, q, r, s, tol1,xm,tmp 61 | real(kind=d), parameter :: EPS = epsilon(a) 62 | integer, parameter :: imax = 100 ! maximum number of iteration 63 | ! values from Numerical Recipe 64 | 65 | exitflag = 0 66 | if (present(detail) .and. detail /= 0) then 67 | disp = 1 68 | else 69 | disp = 0 70 | end if 71 | 72 | ! intialize values 73 | a = x1 74 | b = x2 75 | c = x2 76 | fa = fun(a) 77 | fb = fun(b) 78 | fc=fb 79 | 80 | ! check sign 81 | if ( (fa>0. .and. fb>0. ) .or. (fa>0. .and. fb>0. )) then 82 | write(*,*) 'Error (brent.f90): Root must be bracked by two imputs' 83 | write(*, "('f(x1) = ', 1F8.4, ' f(x2) = ', 1F8.4)") fa,fb 84 | write(*,*) 'press any key to halt the program' 85 | read(*,*) 86 | stop 87 | end if 88 | 89 | if (disp == 1 ) then 90 | write(*,*) 'Brents method to find a root of f(x)' 91 | write(*,*) ' ' 92 | write(*,*) ' i x bracketsize f(x)' 93 | end if 94 | 95 | ! main iteration 96 | do i = 1, imax 97 | ! rename c and adjust bounding interval if both a(=b) and c are same sign 98 | if ((fb > 0. .and. fc > 0) .or. (fb <0. .and. fc < 0. ) ) then 99 | c = a 100 | fc = fa 101 | e = b-a 102 | diff = e 103 | end if 104 | 105 | ! if c is better guess than b, use it. 106 | if (abs(fc) < abs(fb) ) then 107 | a=b 108 | b=c 109 | c=a 110 | fa=fb 111 | fb=fc 112 | fc= fa 113 | end if 114 | 115 | ! convergence check 116 | tol1=2.0_d* EPS * abs(b) + 0.5_d*tol 117 | xm = 0.5_d * (c - b) 118 | if (abs(xm) < tol1 .or. fb == 0.0_d ) then 119 | exitflag = 1 120 | exit 121 | end if 122 | 123 | if (disp == 1) then 124 | tmp = c-b 125 | write(*,"(' ', 1I2, 3F16.6)") i, b, abs(b-c), fb 126 | end if 127 | 128 | ! try inverse quadratic interpolation 129 | if (abs(e) >= tol1 .and. abs(fa) > abs(fb) ) then 130 | s = fb/fa 131 | if (abs(a - c) < EPS) then 132 | p = 2.0_d *xm * s 133 | q = 1.0_d - s 134 | else 135 | q = fa/fc 136 | r = fb/fc 137 | p = s * (2.0_d * xm * q * (q -r ) - (b - a) * (r - 1.0_d)) 138 | q = (q - 1.0_d ) * (r - 1.0_d) * (s - 1.0_d) 139 | end if 140 | 141 | ! accept if q is not too small to stay in bound 142 | if (p > 0.0_d) q = -q 143 | p = abs(p) 144 | if (2.0 * p < min(3.0 * xm * q - abs(tol1* q), abs(e *q))) then 145 | e = d 146 | diff = p / q 147 | else ! interpolation failed. use bisection 148 | diff= xm 149 | e = d 150 | end if 151 | else ! quadratic interpolation bounds moves too slowly, use bisection 152 | diff = xm 153 | e = d 154 | end if 155 | 156 | ! update last bound 157 | a = b 158 | fa = fb 159 | 160 | ! move the best guess 161 | if (abs(d) > tol1) then 162 | b = b + diff 163 | else 164 | b = b + sign(tol1, xm) 165 | end if 166 | 167 | ! evaluate new trial root 168 | fb = fun(b) 169 | end do 170 | 171 | ! case for non convergence 172 | if (exitflag /= 1 ) then 173 | write(*,*) 'Error (brent.f90) : convergence was not attained' 174 | write(*,*) 'Initial value:' 175 | write(*,"(4F10.5)" ) x1, x2, fun(x1), fun(x2) 176 | write(*,*) ' ' 177 | write(*,*) 'final value:' 178 | write(*,"('x = ' ,1F6.4, ': f(x1) = ' , 1F6.4 )" ) b, fb 179 | else if( disp == 1) then 180 | write(*,*) 'Brents method was converged.' 181 | write(*,*) '' 182 | end if 183 | brent0 = b 184 | return 185 | 186 | end function brent0 187 | 188 | function brent (fun, x0, tol, LowerBound, UpperBound, detail) 189 | ! Root finding using brent(). 190 | ! find an initial guess of bracket and call brent() 191 | ! 192 | ! Inputs 193 | ! fun: function to evaluate 194 | ! x0: Initial guess 195 | ! 196 | ! Optional Inputs: 197 | ! LowerBound, UpperBound : Lower and upper bound of the function 198 | ! detail : Output result of iteration if detail is there. 199 | ! 200 | ! Date: Jan 30, 09 201 | 202 | implicit none 203 | integer, parameter :: d = selected_real_kind(p=13,r=200) 204 | real(kind=d) :: brent 205 | real(kind=d), intent(IN) :: x0, tol 206 | real(kind=d), external :: fun 207 | real(kind=d), intent(IN), optional :: LowerBound, UpperBound 208 | integer, intent(IN), optional :: detail 209 | 210 | real(kind=d) :: a , b , olda, oldb, fa, fb 211 | real(kind=d), parameter :: sqrt2 = sqrt(2.0_d)! change in dx 212 | integer, parameter :: maxiter = 40 213 | real(kind=d) :: dx ! change in bracket 214 | integer :: iter, exitflag, disp 215 | real(kind=d) :: sgn 216 | 217 | a = x0 ! lower bracket 218 | b = x0 ! upper bracket 219 | olda = a 220 | oldb = b 221 | exitflag = 0 ! flag to see we found the bracket 222 | sgn =fun(x0) ! sign of initial guess 223 | 224 | ! set disp variable 225 | if (present(detail) .and. detail /= 0) then 226 | disp = 1 227 | else 228 | disp = 0 229 | end if 230 | 231 | 232 | ! set initial change dx 233 | if (abs(x0)<0.00000002_d) then 234 | dx = 1.0_d/50.0_d 235 | else 236 | dx = 1.0_d/50.0_d * x0 237 | end if 238 | 239 | if (disp == 1) then 240 | write(*,*) 'Search for initial guess for Brents method' 241 | write(*,*) 'find two points whose sign for f(x) is different ' 242 | write(*,*) 'x1 searches downwards, x2 searches upwards with increasing increment' 243 | write(*,*) ' ' 244 | write(*,*) ' i x1 x2 f(x1) f(x2)' 245 | end if 246 | 247 | 248 | ! main loop to extend a and b 249 | do iter = 1, maxiter 250 | fa = fun(a) 251 | fb = fun(b) 252 | 253 | if (disp == 1) write(*,"(1I4,4F14.7)") iter, a, b, fa, fb 254 | 255 | ! check if sign of functions changed or not 256 | if ( (sgn >= 0 ) .and. (fa <= 0) ) then ! sign of a changed 257 | ! use a and olda as bracket 258 | b = olda 259 | exitflag = 1 260 | exit 261 | else if ( (sgn <= 0 ) .and. (fa >= 0 ) ) then ! sign of b changed 262 | b = olda 263 | exitflag = 1 264 | exit 265 | else if ( (sgn >= 0 ) .and. (fb <= 0 ) ) then ! sign of a changed 266 | a = oldb 267 | exitflag = 1 268 | exit 269 | else if ( (sgn <= 0 ) .and. (fb >= 0 ) ) then ! sign of a changed 270 | a = oldb 271 | exitflag = 1 272 | exit 273 | end if 274 | 275 | ! update boundary 276 | olda = a 277 | oldb = b 278 | a = a - dx 279 | b = b+ dx 280 | dx = dx * sqrt2 281 | 282 | ! boundary check 283 | if (present(LowerBound)) then 284 | if (a < LowerBound ) a = LowerBound + tol 285 | end if 286 | if (present(UpperBound) ) then 287 | if (b > UpperBound ) b = UpperBound - tol 288 | end if 289 | end do 290 | 291 | 292 | if (exitflag /= 1 ) then 293 | write(*,*) ' Error (brent2) : Proper initial value for Brents method could not be found' 294 | write(*,*) ' Change initial guess and try again. ' 295 | write(*,*) ' You might want to try disp = 1 option too' 296 | write(*,*) 'i x1 x2 fx1 fx2' 297 | write(*,"(1I4,4F12.7)") iter, a, b, fa, fb 298 | write(*,*) ' press any key to abort the program' 299 | read(*,*) 300 | stop 301 | else if (disp == 1) then 302 | write(*,*) ' Initial guess was found.' 303 | write(*,*) '' 304 | end if 305 | 306 | if (present (detail)) then 307 | brent = brent0(fun,a,b,tol,detail) 308 | else 309 | brent = brent0(fun,a,b,tol) 310 | end if 311 | 312 | end function brent 313 | 314 | 315 | 316 | 317 | subroutine TestFunctions() 318 | ! test various functions defined in this module 319 | implicit none 320 | integer, parameter :: d = selected_real_kind(p=13,r=200) 321 | 322 | real(kind=d) :: out 323 | 324 | ! test function 1 with a few more options 325 | ! write(*,*) 'Function 1: answer = 0.09534 ' 326 | ! out = brent(fun =fun1, x0 = 4.0_d, tol = 0.0000001_d, & 327 | ! LowerBound= 0.0_d, detail = 1) 328 | 329 | ! test function 2 330 | ! write(*,*) 'Function 2: answer = -3 ' 331 | ! out = brent(fun2, 3.0_d,0.00001_d, detail = 1) 332 | 333 | write(*,*) 'Function 3: answer = 8.10451, 10, 11.8955' 334 | out = brent(fun3, 0.0_d, 0.000001_d, detail = 34) 335 | 336 | 337 | write(*,*) ' ' 338 | 339 | write(*,*) 'press any key to continue' 340 | read(*,*) 341 | 342 | end subroutine testfunctions 343 | 344 | function fun1 (x) 345 | ! test function for root finding 346 | ! f(x) = exp(x) - 1 / (10 * x) ** 2 347 | ! answer = 0.095344 348 | implicit none 349 | integer, parameter :: d = selected_real_kind(p=13,r=200) 350 | real(kind=d) :: fun1 351 | real(kind=d) , intent(IN) :: x 352 | 353 | fun1 = exp(x) - 1 / (10 * x) ** 2 354 | end function fun1 355 | 356 | function fun2 (x) 357 | ! test function for root finding 358 | ! f(x) = (x+3) * (x - 1) ** 2 359 | ! answer: -3, 1 360 | implicit none 361 | integer, parameter :: d = selected_real_kind(p=13,r=200) 362 | real(kind=d) :: fun2 363 | real(kind=d) , intent(IN) :: x 364 | 365 | fun2 = (x+3) * (x - 1) ** 2 366 | end function fun2 367 | 368 | function fun3 (x) 369 | ! test function for root finding 370 | ! f(x) = sin(x-10) - 0.5 * (x - 10) 371 | ! answer = 10 372 | implicit none 373 | integer, parameter :: d = selected_real_kind(p=13,r=200) 374 | real(kind=d) :: fun3 375 | real(kind=d) , intent(IN) :: x 376 | 377 | fun3 = sin(x-10) - 0.5 * (x - 10) 378 | end function fun3 379 | 380 | 381 | end module fsolve 382 | -------------------------------------------------------------------------------- /hybrid.f90: -------------------------------------------------------------------------------- 1 | module hybrid 2 | use MyUtility 3 | ! This module is for solving system of nonlinear equations using modified Powell's 4 | ! Hybrid method. Original code is from in MINPACK. 5 | 6 | ! subroutine list 7 | ! FsolveHybrid : main subroutine to perform the modified Powell's Hybrid 8 | ! method. It calls UpdateDelta, dogleg, QRfactorization, QRupdate 9 | ! and GetJacobian. 10 | ! UpdateDelta : It updates Delta, the size of the trust region 11 | ! dogleg : It finds the next step p within the trust region 12 | ! QRfactorization : It performs QR factorization 13 | ! QRupdate : It updates QR factorization after the Broyden's update 14 | ! applyGivens : It apply Givens transformation. It is called by QRupdate. 15 | ! 16 | ! FsolveHybridTest: Sample subroutine to illustrate the usage of FsolveHybrid 17 | ! It contains funstest1 and funstest2. 18 | ! Just call FsolveHybrid from the main program. 19 | 20 | ! Last Updated : Feb 17, 2009 21 | 22 | 23 | contains 24 | subroutine FsolveHybrid(fun, x0, xout, xtol, info, fvalout, JacobianOut, & 25 | JacobianStep, display, MaxFunCall, factor, NoUpdate,deltaSpeed) 26 | ! Solve system of nonlinear equations using modified Powell's Hybrid method. 27 | implicit none 28 | INTERFACE 29 | SUBroutine fun (x, fval0) 30 | use myutility; 31 | implicit none 32 | real(kind=db), intent(IN), dimension(:) :: x 33 | real(kind=db), intent(OUT), dimension(:) :: fval0 34 | end subroutine fun 35 | END INTERFACE 36 | 37 | !. Declearation of variables 38 | real(kind=db), intent(IN), dimension(:) :: x0 ! Initial value 39 | real(kind=db), intent(OUT),dimension(size(x0)) :: xout ! solution 40 | real(kind=db), intent(IN), optional :: xtol ! Relative tol of X 41 | integer , intent(OUT), optional :: info ! Information on output 42 | 43 | 44 | ! output function value and Jacobian 45 | real(kind=db), intent(OUT), dimension(size(x0)), optional :: fvalOut 46 | real(kind=db), intent(OUT), dimension(size(x0),size(x0)), optional :: JacobianOut 47 | 48 | 49 | real(kind=db), intent(IN), optional :: JacobianStep ! Relative step for Derivative 50 | real(kind=db), intent(IN), optional :: factor ! inital value of delta 51 | integer , intent(IN), optional :: display ! Controls display on iteration 52 | integer , intent(IN), optional :: MaxFunCall ! Max number of Function call 53 | integer , intent(IN), optional :: NoUpdate ! Jacobian Recalculation info 54 | real(kind=db), intent(IN), optional :: deltaSpeed ! How fast Delta should decrease 55 | 56 | integer :: n ! number of variables 57 | integer :: IterationCount ! number of iterations 58 | integer :: FunctionCount ! number of function calls 59 | integer :: GoodJacobian ! number of concective sucessfull iterations 60 | integer :: BadJacobian ! number of concective failing iterations 61 | integer :: SlowJacobian ! Degree of slowness after repeated Jacobian Update 62 | integer :: SlowFunction ! number of concective failure of improving 63 | integer :: info2 ! information for the termination 64 | integer :: i ! index for the loop 65 | integer :: display2 ! varible to control displaying information 66 | integer :: MaxFunCall2 ! Maximum number of Function call 67 | integer :: NoUpdate2 ! variable to control Jacobian Update 68 | integer :: DirectionFlag ! Flag for the output of dogleg 69 | integer :: UpdateJacobian ! Mark for the updating Jacobian 70 | 71 | real(kind=db) :: temp 72 | real(kind=db) :: Delta ! size of trust region 73 | real(kind=db) :: pnorm ! norm of step 74 | real(kind=db) :: ActualReduction ! 1 - norm(fvalold)/norm(fvalnew) 75 | real(kind=db) :: ReductionRatio ! ActuanReduction / PredictedReduction 76 | real(kind=db) :: xtol2 ! torelance of x 77 | real(kind=db) :: JacobianStep2 ! Finite difference step size 78 | real(kind=db) :: factor2 ! initial value of delta 79 | real(kind=db) :: DeltaOld ! Used for display purpose 80 | real(kind=db) :: deltaSpeed2 ! How fast Delta should decrease 81 | 82 | 83 | real(kind=db), dimension(size(x0)) :: xbest ! best x so far 84 | real(kind=db), dimension(size(x0)) :: xold ! x befor update 85 | real(kind=db), dimension(size(x0)) :: xnew ! xold + p 86 | real(kind=db), dimension(size(x0)) :: fvalbest ! fun(xbest) 87 | real(kind=db), dimension(size(x0)) :: fvalpredicted ! fun(xold)+ J*p 88 | real(kind=db), dimension(size(x0)) :: fvalold ! fun(xold) 89 | real(kind=db), dimension(size(x0)) :: fvalnew ! fun(xold+p) 90 | real(kind=db), dimension(size(x0)) :: p ! predicted direction 91 | real(kind=db), dimension(size(x0)) :: Psidiag ! Normaization coefs 92 | real(kind=db), dimension(size(x0)) :: Qtfval ! Q^T * fvalbest 93 | 94 | real(kind=db), dimension(size(x0),size(x0)) :: Q,R ! results of QR factorization 95 | real(kind=db), dimension(size(x0),size(x0)) :: J ! Jacobian 96 | real(kind=db), dimension(size(x0),size(x0)) :: PsiInv ! Inverse of nomarization mat 97 | 98 | CHARACTER(LEN=79) :: st1, st2 ! used for output 99 | CHARACTER(LEN=6) :: st6 ! used for output 100 | CHARACTER(LEN=12) :: st12 ! used for output 101 | 102 | 103 | !. Initialize values 104 | ! counters 105 | IterationCount = 0 106 | FunctionCount = 0 107 | GoodJacobian = 0 108 | BadJacobian = 0 109 | SlowFunction = 0 110 | SlowJacobian = 0 111 | info2 = 0 112 | n = size(x0) 113 | 114 | ! Set default values for optional inputs 115 | xtol2 = p0001 116 | display2 = 0 117 | MaxFunCall2 = n*100 118 | NoUpdate2 = 0 119 | factor2 = 100 120 | deltaSpeed2 = 0.25_db 121 | 122 | if (present(xtol)) xtol2 = xtol 123 | if (present(display)) display2 = display 124 | if (present(MaxFunCall)) MaxFunCall2 = MaxFunCall 125 | if (present(NoUpdate)) NoUpdate2 = NoUpdate 126 | if (present(factor)) factor2 = factor 127 | if (present(deltaSpeed)) deltaSpeed2 = deltaSpeed 128 | 129 | 130 | JacobianStep2 = xtol * p1 131 | if (present(JacobianStep)) JacobianStep2 = JacobianStep 132 | 133 | ! Jacobian and function values 134 | xbest = x0 135 | call fun(xbest, fvalbest) ! output: fvalbest 136 | FunctionCount = FunctionCount + 1 137 | call GetJacobian(J, fun, xbest, JacobianStep2,fvalbest) ! output : J 138 | FunctionCount = FunctionCount + n 139 | call QRfactorization(J,Q,R) ! output: Q, R 140 | Qtfval = matmul(transpose(Q),fvalbest) 141 | 142 | ! calculate normalzation matrix Psi 143 | PsiInv = 0 144 | do i = 1, n 145 | ! normalization factor is R(i,i) unless R(i,i) = 0 146 | temp = 1 147 | if(R(i,i) /= zero) temp = abs(R(i,i)) 148 | PsiInv(i,i) = 1/temp 149 | PsiDiag(i) = temp 150 | end do 151 | 152 | ! calculate initial value of Delta 153 | Delta = factor2 * norm(PsiDiag * xbest) 154 | if(Delta == 0 ) Delta = 1 155 | 156 | ! check initial guess is good or not 157 | if (norm(fvalbest) == zero) info2 = 1 158 | 159 | ! display first line 160 | if(display2 ==1) then 161 | write(*,*) 'FsolveHybrid:' 162 | st1= " Norm Actual Trust-Region Step Jacobian Direction" 163 | st2= " iter f(x) Reduction Size Size Recalculate Type" 164 | write(*,*) st1 165 | write(*,*) st2 166 | st1 = "(' 0 ',1G11.5)" 167 | write(*,st1) norm(fvalbest) 168 | end if 169 | 170 | 171 | ! **************************** 172 | ! main loop 173 | ! **************************** 174 | do 175 | IterationCount = IterationCount + 1 176 | 177 | ! old values are values at the start of the iteration 178 | fvalold = fvalbest 179 | xold = xbest 180 | 181 | !. *** calculate the best direction *** 182 | call dogleg(p,Q,matmul(R,PsiInv),Delta,Qtfval,DirectionFlag) 183 | ! output: p, DirectionFlag 184 | p = matmul(PsiInv, p) 185 | 186 | !. update the trust region 187 | call fun(xold + p, fvalnew) 188 | FunctionCount = FunctionCount +1 189 | fvalpredicted = fvalbest + matmul(Q,matmul(R,p)) 190 | DeltaOld = Delta 191 | call UpdateDelta(Delta,GoodJacobian,BadJacobian,& 192 | ActualReduction, ReductionRatio,fvalold,fvalnew,& 193 | fvalpredicted, PsiDiag*p,deltaSpeed2 ) 194 | ! output: Delta, GoodJacobian, BadJacobian, 195 | ! ActualReduction, ReductionRatio 196 | 197 | ! get the best value so far 198 | if(norm(fvalnew) < norm(fvalold) .and. ReductionRatio > p0001) then 199 | xbest = xold +p 200 | fvalbest = fvalnew 201 | end if 202 | 203 | 204 | !. *** Check convergence *** 205 | ! Sucessful Convergence 206 | if(Delta < xtol*norm(PsiDiag*xbest) .or. norm(fvalbest) == 0) info2 = 1 207 | 208 | ! Too much function call 209 | if(FunctionCount > MaxFunCall2) info = 2 210 | 211 | ! tol is too small 212 | if(Delta < 100 * epsilon(Delta) * norm(PsiDiag * xbest)) info2 = 3 213 | 214 | ! Not successful based on Jacobian 215 | if(ActualReduction > p1) SlowJacobian = 0 216 | if(SlowJacobian == 5) info2 = 4 217 | ! if Jacobian is recalculated every time, we do not performe this test 218 | if(noupdate2 == 1) SlowJacobian = 0 219 | 220 | ! Not sucessful based on Function Value 221 | SlowFunction = SlowFunction + 1 222 | if(ActualReduction > p01) SlowFunction = 0 223 | if( SlowFunction == 10) info2 = 5 224 | 225 | 226 | !.*** Update Jacobian *** 227 | pnorm = norm(p) 228 | UpdateJacobian = 0 229 | if(BadJacobian == 2 .or. pnorm == 0 .or. noupdate == 1) then 230 | ! calculate Jacobian using finite difference 231 | call GetJacobian(J, fun, xbest, JacobianStep2,fvalbest) ! output : J 232 | FunctionCount = FunctionCount + n 233 | call QRfactorization(J,Q,R) ! output: Q, R 234 | Qtfval = matmul(transpose(Q),fvalbest) 235 | 236 | ! recalculate normalzation matrix Psi 237 | do i = 1, n 238 | ! normalization factor is R(i,i) unless R(i,i) = 0 239 | temp = 1 240 | if(R(i,i) /= zero) temp = abs(R(i,i)) 241 | PsiInv(i,i) = min(PsiInv(i,i), 1/temp) 242 | PsiDiag(i) = 1/PsiInv(i,i) 243 | end do 244 | 245 | ! take care of counts 246 | BadJacobian = 0 247 | SlowJacobian = SlowJacobian +1 248 | UpdateJacobian = 1 249 | else if (ReductionRatio > p0001) then 250 | ! Broyden's Rank 1 update 251 | call QRupdate(Q,R,fvalnew - fvalpredicted,p/((pnorm)**2)) 252 | Qtfval = matmul(transpose(Q),fvalbest) 253 | end if 254 | 255 | ! display iteration 256 | if(display2 ==1) then 257 | st1 = "(1I4,' ',1G11.5,' ',1G11.5,' ', 1G11.5,' ', 1G11.5,' ', 2A)" 258 | st6 = " " 259 | if(UpdateJacobian == 1) st6 = ' Yes ' 260 | select case (DirectionFlag) 261 | case (1) 262 | st12 = 'Newton' 263 | case (2) 264 | st12 = 'Cauchy' 265 | case (3) 266 | st12 = 'Combination' 267 | end select 268 | write(*,st1) IterationCount, norm(fvalbest), 100.0_db * ActualReduction, & 269 | DeltaOld, norm(PsiDiag *p),st6, st12 270 | end if 271 | 272 | 273 | ! exit check 274 | if( info2 /= 0) exit 275 | end do 276 | 277 | !. prepare output 278 | xout = xbest 279 | fvalOut = fvalbest 280 | JacobianOut = J 281 | 282 | ! display result 283 | if(display2 ==1) then 284 | select case (info2) 285 | case (0) 286 | write(*,*) 'Bad input' 287 | case (1) 288 | if(norm(fvalbest)>p1) then 289 | write(*,*) ' Trust Region shrinks enough so no progress is possible.' 290 | write(*,*) ' Make sure function value is close to zero enough' 291 | else 292 | write(*,*) ' Sucessful convergence' 293 | end if 294 | case (2) 295 | write(*,*) ' Too much Function call' 296 | case (3) 297 | write(*,*) ' Tol too small' 298 | case (4) 299 | write(*,*) ' Too much Jacobian ' 300 | case (5) 301 | write(*,*) ' Slow Objective function Improvement' 302 | end select 303 | if (norm(fvalbest)1 .or. ReductionRatio > p5 ) then 351 | ! prediction was fair. expand trust egion 352 | Delta = max(Delta, two * pnorm) 353 | 354 | else if (abs(1 -ReductionRatio) < p1 ) then 355 | ! prediction was very good. (the ratio is close to one). 356 | ! Expand trust region 357 | Delta = two * pnorm 358 | end if 359 | end if 360 | 361 | end subroutine updateDelta 362 | 363 | 364 | 365 | pure subroutine dogleg(p,Q,R,delta,Qtf,flag) 366 | ! find linear combination of newton direction and steepest descent 367 | ! direction. 368 | 369 | ! flag : it indicates the type of the p (optional) 370 | ! flag = 1 : newton direction 371 | ! flag = 2 : Steepest descent direction 372 | ! flag = 3 : Linear combination of bot 373 | 374 | implicit none 375 | real(kind=db), intent(out), dimension(:) :: p ! output direction 376 | real(kind=db), intent(in), & 377 | dimension(size(p),size(p)) :: Q, R ! QR decomposition of Jacobian 378 | real(kind=db), intent(in) :: delta ! trust region parameter 379 | real(kind=db), intent(in), & 380 | dimension(size(p)) :: Qtf ! Q^T * f(x) 381 | integer, intent(out), optional :: flag ! flag about the type of p 382 | 383 | integer :: i, tempflag 384 | integer :: n ! number of variables = size(p) 385 | real(kind=db) :: gnorm, mu, nunorm, theta, mugnorm, temp 386 | real(kind=db) :: Jgnorm 387 | real(kind=db), dimension(size(p)) :: nu ! Newton direction 388 | real(kind=db), dimension(size(p)) :: g ! Steepest descent direction 389 | real(kind=db), dimension(size(p)) :: mug 390 | 391 | n = size(p) 392 | 393 | ! ****************************** 394 | ! calculate newton direction 395 | ! ****************************** 396 | ! prepare a small value in case diagonal element of R is zero 397 | temp = epsilon(mu) * maxval(abs(diag(R))) 398 | 399 | nu(n) = -1* Qtf(n) /temp ! this is special value in case 400 | if (R(n,n) /= zero) nu(n) = -1* Qtf(n) / R(n,n) ! normal case 401 | 402 | ! solve backwards 403 | do i = n-1, 1, -1 404 | if (R(i,i)==0) then 405 | ! special value 406 | nu(i) = (-1*Qtf(i) - dot_product(R(i,i+1:n),nu(i+1:n))) / temp 407 | else 408 | ! normal value 409 | nu(i) = (-1*Qtf(i) - dot_product(R(i,i+1:n),nu(i+1:n))) / R(i,i) 410 | end if 411 | end do 412 | nunorm = norm(nu) 413 | 414 | 415 | if (nunorm < delta) then 416 | ! newton direction 417 | p = nu 418 | tempflag = 1 419 | else 420 | ! newton direction was not accepted. 421 | g = - one * matmul(transpose(R),Qtf) ! Steepest descent 422 | gnorm = norm(g) 423 | Jgnorm = norm(matmul(Q,matmul(R,g))) 424 | 425 | if (Jgnorm == 0) then 426 | ! special attention if steepest direction is zero 427 | p = delta * nu/nunorm 428 | flag = 3 429 | 430 | else if ((gnorm**2) *gnorm / (Jgnorm**2) > delta) then 431 | ! accept steepest descent direction 432 | p = delta *g /gnorm 433 | tempflag = 2 434 | else 435 | ! linear combination of both 436 | ! calculate the weight of each direction 437 | mu = gnorm**2 / Jgnorm**2 438 | mug = mu *g 439 | mugnorm = norm(mug) 440 | theta = (delta**2 - mugnorm**2) / (dot_product(mug, nu-mug) + & 441 | ((dot_product(nu,mug)-delta**2)**2 + (nunorm**2-delta**2) & 442 | * (delta**two - mugnorm**2))**p5) 443 | 444 | p = (1-theta) * mu * g + theta*nu 445 | tempflag = 3 446 | 447 | end if 448 | end if 449 | 450 | if (present(flag)) flag = tempflag 451 | end subroutine dogleg 452 | 453 | subroutine QRfactorization(A,Q,R) 454 | ! Calculate QR factorizaton using Householder transformation. 455 | ! You can obtain better speed and stability by using LAPACK routine. 456 | 457 | ! It finds ortogonal matrix Q and upper triangular R such that 458 | ! 459 | ! A = Q * [R; ZeroMatrix] 460 | ! 461 | ! Arguments for this subroutine 462 | ! A: m by n (m>=n) input matrix for the QR factorization to be computed 463 | ! Q: m by m output orthogonal matrix 464 | ! R: m by n output upper triangular matrix. 465 | ! 466 | ! Written by Yoki Okawa 467 | ! Date: Feb 10, 08 468 | 469 | 470 | implicit none 471 | 472 | real(kind=db), INTENT(IN), dimension(:,:) :: A 473 | real(kind=db), INTENT(INOUT), dimension(:,:) :: Q,R 474 | real(kind=db), allocatable, dimension(:,:) :: X2 475 | 476 | real(kind=db), dimension(size(A,1)) :: u 477 | real(kind=db), dimension(size(A,1),size(A,1)) :: P 478 | 479 | integer :: m, n, mQ1,mQ2, nR, mR,i,j 480 | 481 | m = size(A,1) ! number of rows in A 482 | n = size(A,2) ! number of columns in A 483 | 484 | ! check size of the outputs 485 | mQ1 = size(Q,1) ! number of rows in Q 486 | mQ2 = size(Q,2) ! number of columns in Q 487 | mR = size(R,1) ! number of rows in R 488 | nR = size(R,2) ! number of columns in R 489 | if (n /= nR .or. m /= mQ1 .or. m /= mQ2 .or. m/=mR ) then 490 | call myerror & 491 | ('QRfactorization : output matrix dimensions do not match with inputs') 492 | end if 493 | 494 | if (m QR +u*v 532 | ! Q: (inout) n by n Orthogonal matrix 533 | ! R: (inout) n by n upper triangular matrix 534 | ! u,v: n dimensional vector 535 | 536 | implicit none 537 | real(kind=db), intent(INOUT), dimension(:,:) :: Q,R 538 | real(kind=db), intent(IN), dimension(:) :: u, v 539 | 540 | integer :: N ! dimension of Q or R 541 | real(kind=db), allocatable, dimension(:) :: w ! Qt * w 542 | real(kind=db), allocatable, dimension(:,:) ::Qt ! transpose(Q) 543 | integer :: i, j 544 | real(kind=db) :: s,c, t, wnorm ! sin, cos, tan 545 | 546 | N = size(u) 547 | allocate(w(N)) 548 | allocate(Qt(N,N)) 549 | 550 | Qt = transpose(Q) 551 | w = matmul(Qt,u) 552 | wnorm = norm(w) ! norm of w 553 | 554 | ! make w to unit vector 555 | do i = N, 2,-1 556 | ! calculate cos and sin 557 | if (w(i-1) == zero) then 558 | c = zero 559 | s = one 560 | else 561 | t = w(i)/w(i-1) 562 | c = one /( (t**2+one)**p5) 563 | s = t * c 564 | end if 565 | 566 | call applyGivens(R,c,s,i-1,i) 567 | call applyGivens(Qt,c,s,i-1,i) 568 | w(i-1) = c *w(i-1) + s* w(i) 569 | w(i) = c*w(i) - s*w(i-1) 570 | end do 571 | 572 | ! update R 573 | R(1,:) = R(1,:) + w(1) *v 574 | 575 | ! Transform upper Hessenberg matrix R to upper triangular matrix 576 | ! H in the documentation is currentry R 577 | do i = 1, N-1 578 | if (R(i,i) == zero) then 579 | c = zero 580 | s = one 581 | else 582 | t = R(i+1,i)/R(i,i) 583 | c = one /( (t**2+one)**p5) 584 | s = t * c 585 | end if 586 | call applyGivens(R,c,s,i,i+1) 587 | call applyGivens(Qt,c,s,i,i+1) 588 | end do 589 | 590 | Q = transpose(Qt) 591 | 592 | end subroutine QRupdate 593 | 594 | pure subroutine applyGivens(A,c2,s2,i2,j2) 595 | ! apply givens transformation with cos, sin, index i and j to matrix A. 596 | ! A <- P * A, P: givens transformation. 597 | ! P(i2,j2) = -s2; P(j2, i2) = s2; P(i2,i2) = P(j2,j2) = c2 598 | 599 | implicit none 600 | real(kind=db), intent(INOUT), dimension(:,:) :: A 601 | real(kind=db), intent(IN) :: c2, s2 602 | real(kind=db), allocatable, dimension(:) :: ai, aj 603 | integer, intent(IN) :: i2, j2 604 | integer :: N 605 | 606 | ! store original input 607 | N = size(A,2) 608 | allocate(ai(N)) 609 | allocate(aj(N)) 610 | 611 | ai = A(i2,:) 612 | aj = A(j2,:) 613 | 614 | ! only row i and row j changes 615 | A(i2,:) = A(i2,:) + (c2-1) * ai 616 | A(i2,:) = A(i2,:) + s2 * aj 617 | 618 | ! change in row j 619 | A(j2,:) = A(j2,:) - s2 * ai 620 | A(j2,:) = A(j2,:) + (c2-1) * aj 621 | 622 | end subroutine applyGivens 623 | 624 | subroutine GetJacobian(Jacobian, fun, x0, xrealEPS,fval) 625 | ! Calculate Jacobian using forward difference 626 | ! Jacobian(i,j) : derivative of fun(i) with respect to x(j) 627 | ! 628 | ! n : number of dimensions of fun 629 | ! m : number of dimensions of x0 630 | ! fun: function to evaluate (actually, subroutine) 631 | ! x0 : position to evaluate 632 | ! xreleps : relative amount of x to change 633 | ! fval : value of fun(x) ( used to save time) 634 | 635 | 636 | implicit none 637 | INTERFACE 638 | subroutine fun(x, fval0) 639 | use myutility; 640 | implicit none 641 | real(kind=db), intent(IN), dimension(:) :: x 642 | real(kind=db), intent(OUT), dimension(:) :: fval0 643 | end subroutine fun 644 | END INTERFACE 645 | 646 | real(kind=db), intent(in), dimension(:) :: x0, fval 647 | real(kind=db), intent(out), & 648 | dimension(size(fval),size(x0) ) :: Jacobian 649 | real(kind=db), intent(in) :: xrealEPS 650 | 651 | real(kind=db), dimension(size(fval)) :: fval0, fval1 652 | real(kind=db) :: xdx 653 | real(kind=db), dimension(size(x0)) :: xtemp 654 | integer :: j , m 655 | 656 | m = size(x0) ! number of variables 657 | 658 | ! main loop (make it forall for speed) 659 | do j = 1,m 660 | ! special treatment if x0 = 0 661 | if(x0(j) == 0) then 662 | xdx = 0.001_db 663 | else 664 | xdx = x0(j) * (one + xrealEPS) 665 | end if 666 | 667 | xtemp = x0 668 | xtemp(j) = xdx 669 | 670 | call fun(xtemp, fval1) ! evaluate function at xtemp 671 | Jacobian(:,j) = (fval1 - fval) / (xdx - x0(j)) 672 | end do 673 | 674 | end subroutine GetJacobian 675 | 676 | 677 | subroutine FsolveHybridTest 678 | ! test subroutine FsolveHybrid 679 | 680 | implicit none 681 | real(kind=db), dimension(2,2) :: jacob, Q, R 682 | real(kind=db), dimension(2) :: xout2, fval 683 | integer ::fsolveinfo 684 | 685 | call FsolveHybrid( & 686 | fun = funstest1, & ! Function to be solved 687 | x0 =(/-1.2_db,1.0_db/), & ! Initial value 688 | xout =xout2, & ! output 689 | xtol =0.00001_db, & ! error torelance 690 | info =fsolveinfo, & ! info for the solution 691 | fvalout =fval, & ! f(xout) 692 | JacobianOut =jacob, & ! Jacobian at x = xout 693 | JacobianStep =0.000001_db, & ! Stepsize for the Jacobian 694 | display =1, & ! Control for the display 695 | MaxFunCall = 1000, & ! Max number of function call 696 | factor =1.0_db, & ! Initial value of delta 697 | NoUpdate = 0) ! control for update of Jacobian 698 | 699 | write(*,*) ' ' 700 | write(*,*) 'Solution:' 701 | call VectorWrite(xout2) 702 | write(*,*) ' ' 703 | write(*,*) 'Function Value at the solution:' 704 | call VectorWrite(fval) 705 | 706 | contains 707 | subroutine funstest1(x, fval0) 708 | ! badly scaled function if we start from (-1.2, 1.0) 709 | ! solution x1 = x2 = 1 710 | implicit none 711 | real(kind=db), intent(IN), dimension(:) :: x 712 | real(kind=db), intent(OUT), dimension(:) :: fval0 713 | 714 | fval0(1) = 10_db*(x(2) - x(1)**2) 715 | fval0(2) = 1 - x(1) 716 | 717 | end subroutine funstest1 718 | 719 | 720 | subroutine funstest2(x, fval0) 721 | ! a little difficult function 722 | ! solution x = [0.50, 1.00. 1.50 ] (+ 2pi*n) 723 | 724 | implicit none 725 | real(kind=db), intent(IN), dimension(:) :: x 726 | real(kind=db), intent(OUT), dimension(:) :: fval0 727 | 728 | fval0(1) = 1.20_db * sin(x(1)) -1.40_db*cos(x(2))+ 0.70_db*sin(x(3)) & 729 | - 0.517133908732486_db 730 | 731 | fval0(2) = 0.80_db * cos(x(1)) -0.50_db*sin(x(2))+ 1.00_db*cos(x(3)) & 732 | - 0.352067758776053_db 733 | 734 | fval0(3) = 3.50_db * sin(x(1)) -4.25_db*cos(x(2))+ 2.80_db*cos(x(3)) & 735 | + 0.4202312501553165_db 736 | 737 | end subroutine funstest2 738 | end subroutine FsolveHybridTest 739 | 740 | end module hybrid 741 | 742 | 743 | 744 | -------------------------------------------------------------------------------- /myutility.f90: -------------------------------------------------------------------------------- 1 | module MyUtility 2 | ! pack of utilities 3 | ! last modified : Feb 10, 2008 4 | ! Written by Yoki Okawa 5 | 6 | 7 | integer, parameter :: db = selected_real_kind(p=13,r=200) 8 | 9 | 10 | real(kind=db), parameter :: two = 2.0_db 11 | real(kind=db), parameter :: one = 1.0_db 12 | real(kind=db), parameter :: p5 = 0.50_db 13 | real(kind=db), parameter :: zero = 0.0_db 14 | real(kind=db), parameter :: p1 = 0.10_db 15 | real(kind=db), parameter :: p01 = 0.01_db 16 | real(kind=db), parameter :: p0001 = 0.0001_db 17 | real(kind=db), parameter :: p00001 = 0.00001_db 18 | 19 | contains 20 | subroutine MyError(str) 21 | ! display error message and stop 22 | implicit none 23 | CHARACTER(LEN=*), INTENT(IN) :: str 24 | write(*,*) 'error ', str 25 | write(*,*) 'press any key to continue' 26 | read(*,*) 27 | 28 | return 29 | end subroutine MyError 30 | 31 | subroutine MatrixWrite(X,str) 32 | ! write matrix as a matrix 33 | ! Input: 34 | ! X: input of matrix 35 | ! 36 | ! Optional Input: 37 | ! str: (1f10.3) type string to specify the format of output. 38 | 39 | implicit none 40 | real(kind=db), intent(IN),dimension(:,:) :: X 41 | character(len=*), intent(IN), optional :: str 42 | integer :: i,j,n,m 43 | character(len=100) :: fmt 44 | 45 | ! set default value of str 46 | if (.not. present(str)) then 47 | fmt = '(1G12.6)' 48 | else 49 | fmt = str 50 | end if 51 | 52 | n = size(x,1) 53 | m = size(x,2) 54 | 55 | do i = 1, n 56 | do j = 1, m 57 | write(*,fmt,advance ='no') X(i,j) 58 | end do 59 | write(*,*) ' ' 60 | end do 61 | 62 | return 63 | end subroutine MatrixWrite 64 | 65 | subroutine VectorWrite(vec,str) 66 | ! write a vector as a horizontal vector 67 | ! Input: 68 | ! X: input of matrix 69 | ! 70 | ! Optional Input: 71 | ! str: (1f10.3) type string to specify the format of output. 72 | 73 | implicit none 74 | real(kind=db), intent(IN),dimension(:) :: vec 75 | character(len=*), intent(IN), optional :: str 76 | integer :: i,j,n,m 77 | character(len=100) :: fmt 78 | 79 | ! set default value of str 80 | if (.not. present(str)) then 81 | fmt = "(' ' , 1F20.10)" 82 | else 83 | fmt = str 84 | end if 85 | 86 | n = size(vec) 87 | 88 | do i = 1, n 89 | write(*,fmt) vec(i) 90 | end do 91 | 92 | 93 | return 94 | end subroutine VectorWrite 95 | 96 | 97 | pure function outer(x,y) 98 | ! caclulate the outer product 99 | ! outer = x* y^t if x is column vector 100 | implicit none 101 | real(kind=db), intent(IN),dimension(:) :: x, y 102 | real(kind=db), dimension(size(x),size(y)) :: outer 103 | outer = spread(x,dim=2,ncopies=size(y)) * & 104 | spread(y,dim=1,ncopies=size(x)) 105 | end function outer 106 | 107 | pure function norm(x) 108 | ! calculate L^2 norm of X 109 | implicit none 110 | real(kind=db),intent(IN), dimension(:) :: x 111 | real(kind=db) :: norm 112 | 113 | norm = ( dot_product(x,x) ) ** (0.50_db) 114 | end function norm 115 | 116 | pure function eye(M) 117 | ! returns identity matrix of dimension M 118 | implicit none 119 | integer,intent(IN) :: m 120 | real(kind=db), dimension(M,M) :: eye 121 | integer :: i, j 122 | 123 | forall (i=1:M, j =1:M) 124 | eye(i,j) = 0 125 | end forall 126 | 127 | forall (i = 1:M) 128 | eye(i,i) = 1 129 | end forall 130 | 131 | end function eye 132 | 133 | pure function diag(M) 134 | ! returns a vector which contains diagonal element of M 135 | implicit none 136 | real(kind=db),intent(IN), dimension(:,:) :: M 137 | real(kind=db), dimension(min(size(M,1),size(M,2))) :: diag 138 | integer :: n, i 139 | 140 | n= min(size(M,1),size(M,2)) 141 | 142 | forall (i=1:n) 143 | diag(i) = M(i,i) 144 | end forall 145 | end function diag 146 | 147 | 148 | 149 | end module MyUtility 150 | --------------------------------------------------------------------------------