| 1 | subroutine ssqjac(m,n,x,fjac,ldfjac,nprob)
|
|---|
| 2 | integer m,n,ldfjac,nprob
|
|---|
| 3 | double precision x(n),fjac(ldfjac,n)
|
|---|
| 4 | c **********
|
|---|
| 5 | c
|
|---|
| 6 | c subroutine ssqjac
|
|---|
| 7 | c
|
|---|
| 8 | c this subroutine defines the jacobian matrices of eighteen
|
|---|
| 9 | c nonlinear least squares problems. the problem dimensions are
|
|---|
| 10 | c as described in the prologue comments of ssqfcn.
|
|---|
| 11 | c
|
|---|
| 12 | c the subroutine statement is
|
|---|
| 13 | c
|
|---|
| 14 | c subroutine ssqjac(m,n,x,fjac,ldfjac,nprob)
|
|---|
| 15 | c
|
|---|
| 16 | c where
|
|---|
| 17 | c
|
|---|
| 18 | c m and n are positive integer input variables. n must not
|
|---|
| 19 | c exceed m.
|
|---|
| 20 | c
|
|---|
| 21 | c x is an input array of length n.
|
|---|
| 22 | c
|
|---|
| 23 | c fjac is an m by n output array which contains the jacobian
|
|---|
| 24 | c matrix of the nprob function evaluated at x.
|
|---|
| 25 | c
|
|---|
| 26 | c ldfjac is a positive integer input variable not less than m
|
|---|
| 27 | c which specifies the leading dimension of the array fjac.
|
|---|
| 28 | c
|
|---|
| 29 | c nprob is a positive integer variable which defines the
|
|---|
| 30 | c number of the problem. nprob must not exceed 18.
|
|---|
| 31 | c
|
|---|
| 32 | c subprograms called
|
|---|
| 33 | c
|
|---|
| 34 | c fortran-supplied ... datan,dcos,dexp,dsin,dsqrt
|
|---|
| 35 | c
|
|---|
| 36 | c argonne national laboratory. minpack project. march 1980.
|
|---|
| 37 | c burton s. garbow, kenneth e. hillstrom, jorge j. more
|
|---|
| 38 | c
|
|---|
| 39 | c **********
|
|---|
| 40 | integer i,ivar,j,k,mm1,nm1
|
|---|
| 41 | double precision c14,c20,c29,c45,c100,div,dx,eight,five,four,
|
|---|
| 42 | * one,prod,s2,temp,ten,three,ti,tmp1,tmp2,tmp3,
|
|---|
| 43 | * tmp4,tpi,two,zero
|
|---|
| 44 | double precision v(11)
|
|---|
| 45 | double precision dfloat
|
|---|
| 46 | data zero,one,two,three,four,five,eight,ten,c14,c20,c29,c45,c100
|
|---|
| 47 | * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,1.4d1,
|
|---|
| 48 | * 2.0d1,2.9d1,4.5d1,1.0d2/
|
|---|
| 49 | data v(1),v(2),v(3),v(4),v(5),v(6),v(7),v(8),v(9),v(10),v(11)
|
|---|
| 50 | * /4.0d0,2.0d0,1.0d0,5.0d-1,2.5d-1,1.67d-1,1.25d-1,1.0d-1,
|
|---|
| 51 | * 8.33d-2,7.14d-2,6.25d-2/
|
|---|
| 52 | dfloat(ivar) = ivar
|
|---|
| 53 | c
|
|---|
| 54 | c jacobian routine selector.
|
|---|
| 55 | c
|
|---|
| 56 | go to (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370,
|
|---|
| 57 | * 400,460,480), nprob
|
|---|
| 58 | c
|
|---|
| 59 | c linear function - full rank.
|
|---|
| 60 | c
|
|---|
| 61 | 10 continue
|
|---|
| 62 | temp = two/dfloat(m)
|
|---|
| 63 | do 30 j = 1, n
|
|---|
| 64 | do 20 i = 1, m
|
|---|
| 65 | fjac(i,j) = -temp
|
|---|
| 66 | 20 continue
|
|---|
| 67 | fjac(j,j) = fjac(j,j) + one
|
|---|
| 68 | 30 continue
|
|---|
| 69 | go to 500
|
|---|
| 70 | c
|
|---|
| 71 | c linear function - rank 1.
|
|---|
| 72 | c
|
|---|
| 73 | 40 continue
|
|---|
| 74 | do 60 j = 1, n
|
|---|
| 75 | do 50 i = 1, m
|
|---|
| 76 | fjac(i,j) = dfloat(i)*dfloat(j)
|
|---|
| 77 | 50 continue
|
|---|
| 78 | 60 continue
|
|---|
| 79 | go to 500
|
|---|
| 80 | c
|
|---|
| 81 | c linear function - rank 1 with zero columns and rows.
|
|---|
| 82 | c
|
|---|
| 83 | 70 continue
|
|---|
| 84 | do 90 j = 1, n
|
|---|
| 85 | do 80 i = 1, m
|
|---|
| 86 | fjac(i,j) = zero
|
|---|
| 87 | 80 continue
|
|---|
| 88 | 90 continue
|
|---|
| 89 | nm1 = n - 1
|
|---|
| 90 | mm1 = m - 1
|
|---|
| 91 | if (nm1 .lt. 2) go to 120
|
|---|
| 92 | do 110 j = 2, nm1
|
|---|
| 93 | do 100 i = 2, mm1
|
|---|
| 94 | fjac(i,j) = dfloat(i-1)*dfloat(j)
|
|---|
| 95 | 100 continue
|
|---|
| 96 | 110 continue
|
|---|
| 97 | 120 continue
|
|---|
| 98 | go to 500
|
|---|
| 99 | c
|
|---|
| 100 | c rosenbrock function.
|
|---|
| 101 | c
|
|---|
| 102 | 130 continue
|
|---|
| 103 | fjac(1,1) = -c20*x(1)
|
|---|
| 104 | fjac(1,2) = ten
|
|---|
| 105 | fjac(2,1) = -one
|
|---|
| 106 | fjac(2,2) = zero
|
|---|
| 107 | go to 500
|
|---|
| 108 | c
|
|---|
| 109 | c helical valley function.
|
|---|
| 110 | c
|
|---|
| 111 | 140 continue
|
|---|
| 112 | tpi = eight*datan(one)
|
|---|
| 113 | temp = x(1)**2 + x(2)**2
|
|---|
| 114 | tmp1 = tpi*temp
|
|---|
| 115 | tmp2 = dsqrt(temp)
|
|---|
| 116 | fjac(1,1) = c100*x(2)/tmp1
|
|---|
| 117 | fjac(1,2) = -c100*x(1)/tmp1
|
|---|
| 118 | fjac(1,3) = ten
|
|---|
| 119 | fjac(2,1) = ten*x(1)/tmp2
|
|---|
| 120 | fjac(2,2) = ten*x(2)/tmp2
|
|---|
| 121 | fjac(2,3) = zero
|
|---|
| 122 | fjac(3,1) = zero
|
|---|
| 123 | fjac(3,2) = zero
|
|---|
| 124 | fjac(3,3) = one
|
|---|
| 125 | go to 500
|
|---|
| 126 | c
|
|---|
| 127 | c powell singular function.
|
|---|
| 128 | c
|
|---|
| 129 | 150 continue
|
|---|
| 130 | do 170 j = 1, 4
|
|---|
| 131 | do 160 i = 1, 4
|
|---|
| 132 | fjac(i,j) = zero
|
|---|
| 133 | 160 continue
|
|---|
| 134 | 170 continue
|
|---|
| 135 | fjac(1,1) = one
|
|---|
| 136 | fjac(1,2) = ten
|
|---|
| 137 | fjac(2,3) = dsqrt(five)
|
|---|
| 138 | fjac(2,4) = -fjac(2,3)
|
|---|
| 139 | fjac(3,2) = two*(x(2) - two*x(3))
|
|---|
| 140 | fjac(3,3) = -two*fjac(3,2)
|
|---|
| 141 | fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4))
|
|---|
| 142 | fjac(4,4) = -fjac(4,1)
|
|---|
| 143 | go to 500
|
|---|
| 144 | c
|
|---|
| 145 | c freudenstein and roth function.
|
|---|
| 146 | c
|
|---|
| 147 | 180 continue
|
|---|
| 148 | fjac(1,1) = one
|
|---|
| 149 | fjac(1,2) = x(2)*(ten - three*x(2)) - two
|
|---|
| 150 | fjac(2,1) = one
|
|---|
| 151 | fjac(2,2) = x(2)*(two + three*x(2)) - c14
|
|---|
| 152 | go to 500
|
|---|
| 153 | c
|
|---|
| 154 | c bard function.
|
|---|
| 155 | c
|
|---|
| 156 | 190 continue
|
|---|
| 157 | do 200 i = 1, 15
|
|---|
| 158 | tmp1 = dfloat(i)
|
|---|
| 159 | tmp2 = dfloat(16-i)
|
|---|
| 160 | tmp3 = tmp1
|
|---|
| 161 | if (i .gt. 8) tmp3 = tmp2
|
|---|
| 162 | tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
|
|---|
| 163 | fjac(i,1) = -one
|
|---|
| 164 | fjac(i,2) = tmp1*tmp2/tmp4
|
|---|
| 165 | fjac(i,3) = tmp1*tmp3/tmp4
|
|---|
| 166 | 200 continue
|
|---|
| 167 | go to 500
|
|---|
| 168 | c
|
|---|
| 169 | c kowalik and osborne function.
|
|---|
| 170 | c
|
|---|
| 171 | 210 continue
|
|---|
| 172 | do 220 i = 1, 11
|
|---|
| 173 | tmp1 = v(i)*(v(i) + x(2))
|
|---|
| 174 | tmp2 = v(i)*(v(i) + x(3)) + x(4)
|
|---|
| 175 | fjac(i,1) = -tmp1/tmp2
|
|---|
| 176 | fjac(i,2) = -v(i)*x(1)/tmp2
|
|---|
| 177 | fjac(i,3) = fjac(i,1)*fjac(i,2)
|
|---|
| 178 | fjac(i,4) = fjac(i,3)/v(i)
|
|---|
| 179 | 220 continue
|
|---|
| 180 | go to 500
|
|---|
| 181 | c
|
|---|
| 182 | c meyer function.
|
|---|
| 183 | c
|
|---|
| 184 | 230 continue
|
|---|
| 185 | do 240 i = 1, 16
|
|---|
| 186 | temp = five*dfloat(i) + c45 + x(3)
|
|---|
| 187 | tmp1 = x(2)/temp
|
|---|
| 188 | tmp2 = dexp(tmp1)
|
|---|
| 189 | fjac(i,1) = tmp2
|
|---|
| 190 | fjac(i,2) = x(1)*tmp2/temp
|
|---|
| 191 | fjac(i,3) = -tmp1*fjac(i,2)
|
|---|
| 192 | 240 continue
|
|---|
| 193 | go to 500
|
|---|
| 194 | c
|
|---|
| 195 | c watson function.
|
|---|
| 196 | c
|
|---|
| 197 | 250 continue
|
|---|
| 198 | do 280 i = 1, 29
|
|---|
| 199 | div = dfloat(i)/c29
|
|---|
| 200 | s2 = zero
|
|---|
| 201 | dx = one
|
|---|
| 202 | do 260 j = 1, n
|
|---|
| 203 | s2 = s2 + dx*x(j)
|
|---|
| 204 | dx = div*dx
|
|---|
| 205 | 260 continue
|
|---|
| 206 | temp = two*div*s2
|
|---|
| 207 | dx = one/div
|
|---|
| 208 | do 270 j = 1, n
|
|---|
| 209 | fjac(i,j) = dx*(dfloat(j-1) - temp)
|
|---|
| 210 | dx = div*dx
|
|---|
| 211 | 270 continue
|
|---|
| 212 | 280 continue
|
|---|
| 213 | do 300 j = 1, n
|
|---|
| 214 | do 290 i = 30, 31
|
|---|
| 215 | fjac(i,j) = zero
|
|---|
| 216 | 290 continue
|
|---|
| 217 | 300 continue
|
|---|
| 218 | fjac(30,1) = one
|
|---|
| 219 | fjac(31,1) = -two*x(1)
|
|---|
| 220 | fjac(31,2) = one
|
|---|
| 221 | go to 500
|
|---|
| 222 | c
|
|---|
| 223 | c box 3-dimensional function.
|
|---|
| 224 | c
|
|---|
| 225 | 310 continue
|
|---|
| 226 | do 320 i = 1, m
|
|---|
| 227 | temp = dfloat(i)
|
|---|
| 228 | tmp1 = temp/ten
|
|---|
| 229 | fjac(i,1) = -tmp1*dexp(-tmp1*x(1))
|
|---|
| 230 | fjac(i,2) = tmp1*dexp(-tmp1*x(2))
|
|---|
| 231 | fjac(i,3) = dexp(-temp) - dexp(-tmp1)
|
|---|
| 232 | 320 continue
|
|---|
| 233 | go to 500
|
|---|
| 234 | c
|
|---|
| 235 | c jennrich and sampson function.
|
|---|
| 236 | c
|
|---|
| 237 | 330 continue
|
|---|
| 238 | do 340 i = 1, m
|
|---|
| 239 | temp = dfloat(i)
|
|---|
| 240 | fjac(i,1) = -temp*dexp(temp*x(1))
|
|---|
| 241 | fjac(i,2) = -temp*dexp(temp*x(2))
|
|---|
| 242 | 340 continue
|
|---|
| 243 | go to 500
|
|---|
| 244 | c
|
|---|
| 245 | c brown and dennis function.
|
|---|
| 246 | c
|
|---|
| 247 | 350 continue
|
|---|
| 248 | do 360 i = 1, m
|
|---|
| 249 | temp = dfloat(i)/five
|
|---|
| 250 | ti = dsin(temp)
|
|---|
| 251 | tmp1 = x(1) + temp*x(2) - dexp(temp)
|
|---|
| 252 | tmp2 = x(3) + ti*x(4) - dcos(temp)
|
|---|
| 253 | fjac(i,1) = two*tmp1
|
|---|
| 254 | fjac(i,2) = temp*fjac(i,1)
|
|---|
| 255 | fjac(i,3) = two*tmp2
|
|---|
| 256 | fjac(i,4) = ti*fjac(i,3)
|
|---|
| 257 | 360 continue
|
|---|
| 258 | go to 500
|
|---|
| 259 | c
|
|---|
| 260 | c chebyquad function.
|
|---|
| 261 | c
|
|---|
| 262 | 370 continue
|
|---|
| 263 | dx = one/dfloat(n)
|
|---|
| 264 | do 390 j = 1, n
|
|---|
| 265 | tmp1 = one
|
|---|
| 266 | tmp2 = two*x(j) - one
|
|---|
| 267 | temp = two*tmp2
|
|---|
| 268 | tmp3 = zero
|
|---|
| 269 | tmp4 = two
|
|---|
| 270 | do 380 i = 1, m
|
|---|
| 271 | fjac(i,j) = dx*tmp4
|
|---|
| 272 | ti = four*tmp2 + temp*tmp4 - tmp3
|
|---|
| 273 | tmp3 = tmp4
|
|---|
| 274 | tmp4 = ti
|
|---|
| 275 | ti = temp*tmp2 - tmp1
|
|---|
| 276 | tmp1 = tmp2
|
|---|
| 277 | tmp2 = ti
|
|---|
| 278 | 380 continue
|
|---|
| 279 | 390 continue
|
|---|
| 280 | go to 500
|
|---|
| 281 | c
|
|---|
| 282 | c brown almost-linear function.
|
|---|
| 283 | c
|
|---|
| 284 | 400 continue
|
|---|
| 285 | prod = one
|
|---|
| 286 | do 420 j = 1, n
|
|---|
| 287 | prod = x(j)*prod
|
|---|
| 288 | do 410 i = 1, n
|
|---|
| 289 | fjac(i,j) = one
|
|---|
| 290 | 410 continue
|
|---|
| 291 | fjac(j,j) = two
|
|---|
| 292 | 420 continue
|
|---|
| 293 | do 450 j = 1, n
|
|---|
| 294 | temp = x(j)
|
|---|
| 295 | if (temp .ne. zero) go to 440
|
|---|
| 296 | temp = one
|
|---|
| 297 | prod = one
|
|---|
| 298 | do 430 k = 1, n
|
|---|
| 299 | if (k .ne. j) prod = x(k)*prod
|
|---|
| 300 | 430 continue
|
|---|
| 301 | 440 continue
|
|---|
| 302 | fjac(n,j) = prod/temp
|
|---|
| 303 | 450 continue
|
|---|
| 304 | go to 500
|
|---|
| 305 | c
|
|---|
| 306 | c osborne 1 function.
|
|---|
| 307 | c
|
|---|
| 308 | 460 continue
|
|---|
| 309 | do 470 i = 1, 33
|
|---|
| 310 | temp = ten*dfloat(i-1)
|
|---|
| 311 | tmp1 = dexp(-x(4)*temp)
|
|---|
| 312 | tmp2 = dexp(-x(5)*temp)
|
|---|
| 313 | fjac(i,1) = -one
|
|---|
| 314 | fjac(i,2) = -tmp1
|
|---|
| 315 | fjac(i,3) = -tmp2
|
|---|
| 316 | fjac(i,4) = temp*x(2)*tmp1
|
|---|
| 317 | fjac(i,5) = temp*x(3)*tmp2
|
|---|
| 318 | 470 continue
|
|---|
| 319 | go to 500
|
|---|
| 320 | c
|
|---|
| 321 | c osborne 2 function.
|
|---|
| 322 | c
|
|---|
| 323 | 480 continue
|
|---|
| 324 | do 490 i = 1, 65
|
|---|
| 325 | temp = dfloat(i-1)/ten
|
|---|
| 326 | tmp1 = dexp(-x(5)*temp)
|
|---|
| 327 | tmp2 = dexp(-x(6)*(temp-x(9))**2)
|
|---|
| 328 | tmp3 = dexp(-x(7)*(temp-x(10))**2)
|
|---|
| 329 | tmp4 = dexp(-x(8)*(temp-x(11))**2)
|
|---|
| 330 | fjac(i,1) = -tmp1
|
|---|
| 331 | fjac(i,2) = -tmp2
|
|---|
| 332 | fjac(i,3) = -tmp3
|
|---|
| 333 | fjac(i,4) = -tmp4
|
|---|
| 334 | fjac(i,5) = temp*x(1)*tmp1
|
|---|
| 335 | fjac(i,6) = x(2)*(temp - x(9))**2*tmp2
|
|---|
| 336 | fjac(i,7) = x(3)*(temp - x(10))**2*tmp3
|
|---|
| 337 | fjac(i,8) = x(4)*(temp - x(11))**2*tmp4
|
|---|
| 338 | fjac(i,9) = -two*x(2)*x(6)*(temp - x(9))*tmp2
|
|---|
| 339 | fjac(i,10) = -two*x(3)*x(7)*(temp - x(10))*tmp3
|
|---|
| 340 | fjac(i,11) = -two*x(4)*x(8)*(temp - x(11))*tmp4
|
|---|
| 341 | 490 continue
|
|---|
| 342 | 500 continue
|
|---|
| 343 | return
|
|---|
| 344 | c
|
|---|
| 345 | c last card of subroutine ssqjac.
|
|---|
| 346 | c
|
|---|
| 347 | end |
|---|
