| 1 |
|
| 2 |
subroutine lsopt_top( nn, xx, ff, gg, simul, optline |
| 3 |
$ , epsx, fmin, epsg |
| 4 |
$ , iprint, itmax, nfunc, nupdate |
| 5 |
$ , dd, gold, xdiff |
| 6 |
$ , loffline |
| 7 |
$ , ifail ) |
| 8 |
|
| 9 |
c ================================================================== |
| 10 |
c SUBROUTINE lsopt_top |
| 11 |
c ================================================================== |
| 12 |
c |
| 13 |
c o uses a set of control variables, their adjoint variables, |
| 14 |
c and a cost function value |
| 15 |
c to compute an improved set of controls with respect to the |
| 16 |
c cost function via a |
| 17 |
c variable-storage Quasi-Newton method |
| 18 |
c |
| 19 |
c o Reference: J.C. Gilbert & C. Lemarechal |
| 20 |
c Some numerical experiments with variable-storage |
| 21 |
c quasi-Newton algorithms |
| 22 |
c Mathematical Programming 45 (1989), pp. 407-435 |
| 23 |
c |
| 24 |
c o started: ??? not reproducible |
| 25 |
c |
| 26 |
c o changed: Patrick Heimbach, MIT/EAPS |
| 27 |
c |
| 28 |
c o Version: 2.0, 24-Feb-2000: |
| 29 |
c (Version 1.0 is considered as version |
| 30 |
c starting from which changes were made). |
| 31 |
c - severe changes in structure including various |
| 32 |
c bug-fixes to enable multi-optimization runs; |
| 33 |
c - routine lsoptw incorporated into lsoptv |
| 34 |
c - optimization iteration loop restructured |
| 35 |
c - complete restructuring of handling |
| 36 |
c cold start cases |
| 37 |
c - number of 3 control flags for error handling |
| 38 |
c (indic, moderl, ifail) reduced to 1 (ifail) |
| 39 |
c and homogenized with routine lsline |
| 40 |
c |
| 41 |
c o Version: 2.1, 29-Feb-2000: |
| 42 |
c - handling of case ifail = 6 changed; |
| 43 |
c leads to stop of optimization |
| 44 |
c (similar to case ifail = 8) |
| 45 |
c - logical lphprint included |
| 46 |
c |
| 47 |
c ================================================================== |
| 48 |
c SUBROUTINE lsopt_top |
| 49 |
c ================================================================== |
| 50 |
|
| 51 |
implicit none |
| 52 |
|
| 53 |
ccc#include <blas1.h> |
| 54 |
include 'mpif.h' ! cheung |
| 55 |
c----------------------------------------- |
| 56 |
c declare arguments |
| 57 |
c----------------------------------------- |
| 58 |
integer nmax |
| 59 |
parameter( nmax = MAX_INDEPEND ) |
| 60 |
|
| 61 |
integer nn, iprint, itmax, nfunc, nupdate, ifail |
| 62 |
|
| 63 |
double precision xx(nn), gg(nn) |
| 64 |
double precision dd(nn), gold(nn), xdiff(nn) |
| 65 |
|
| 66 |
double precision ff, epsx, fmin, epsg |
| 67 |
cph( |
| 68 |
integer phniter0, phniterold |
| 69 |
double precision phff |
| 70 |
COMMON /PH_OPTI/ phniter0, phniterold, phff |
| 71 |
cph) |
| 72 |
|
| 73 |
external simul, optline |
| 74 |
|
| 75 |
c----------------------------------------- |
| 76 |
C declare local variables |
| 77 |
c----------------------------------------- |
| 78 |
logical cold, lphprint, loffline,sflag,tflag,isforward |
| 79 |
parameter (lphprint = .true.) |
| 80 |
|
| 81 |
integer mm, mupd, jmin, jmax, indic, isize, REAL_BYTE |
| 82 |
integer i, iiter, ifunc |
| 83 |
|
| 84 |
double precision fupd |
| 85 |
double precision r1, tmin, tmax, tact, gnorm, gnorm0, eps1 |
| 86 |
double precision fold, ys |
| 87 |
double precision dotdg |
| 88 |
double precision temp,temp1,temp2 |
| 89 |
!cheung |
| 90 |
integer mylen, mystart,myend, pidlen, myindx(2) |
| 91 |
integer ierr,myid,nprocs |
| 92 |
integer status(MPI_STATUS_SIZE), requests(2) |
| 93 |
integer time_array_0(8), time_array_1(8) |
| 94 |
real start_time, finish_time |
| 95 |
common /mpi_parm/ myid,nprocs,mystart,myend |
| 96 |
!cheung |
| 97 |
|
| 98 |
external DDOT, DNRM2, DSCAL |
| 99 |
double precision DDOT, DNRM2 |
| 100 |
|
| 101 |
c----------------------------------------- |
| 102 |
c parameters |
| 103 |
c----------------------------------------- |
| 104 |
|
| 105 |
double precision rmin |
| 106 |
parameter( rmin = 1.e-20 ) |
| 107 |
|
| 108 |
character*(*) iform |
| 109 |
parameter(iform='(i5,2x,1pe8.1,1x,i5,4x,1pe11.4,3(2x,1pe8.1))' ) |
| 110 |
|
| 111 |
c ================================================================== |
| 112 |
c |
| 113 |
c----------------------------------------- |
| 114 |
c initialization |
| 115 |
c----------------------------------------- |
| 116 |
cold = .true. |
| 117 |
fupd = 1.0e+10 |
| 118 |
indic = 0 |
| 119 |
tmin = 0. |
| 120 |
tmax = 1.0e+10 |
| 121 |
tact = 1.0 |
| 122 |
cph( |
| 123 |
phniterold = 0 |
| 124 |
cph) |
| 125 |
iiter = 0 |
| 126 |
eps1 = 1.0 |
| 127 |
ifunc = 0 |
| 128 |
ifail = 0 |
| 129 |
gnorm0 = 1. |
| 130 |
sflag = .false. |
| 131 |
tflag = .false. |
| 132 |
c----------------------------------------- |
| 133 |
c initialization for dd and dds |
| 134 |
c----------------------------------------- |
| 135 |
|
| 136 |
jmin = 1 |
| 137 |
jmax = 0 |
| 138 |
|
| 139 |
mm = nmax |
| 140 |
mupd = nupdate |
| 141 |
|
| 142 |
REAL_BYTE = 4 |
| 143 |
isize = REAL_BYTE |
| 144 |
|
| 145 |
c----------------------------------------- |
| 146 |
c print information |
| 147 |
c----------------------------------------- |
| 148 |
if (myid .eq. 0) then |
| 149 |
if (iprint .ge. 1) then |
| 150 |
|
| 151 |
print '(2x,a)', |
| 152 |
$ '===============================================' |
| 153 |
print '(2x,a)', |
| 154 |
$ '=== O P T I M I Z A T I O N ===' |
| 155 |
print '(2x,a)', |
| 156 |
$ '===============================================' |
| 157 |
print '(a,i11)' |
| 158 |
$ , ' number of control variables.......', nmax |
| 159 |
print '(a,e9.2)' |
| 160 |
$ , ' precision on x....................', epsx |
| 161 |
print '(a,e9.2)' |
| 162 |
$ , ' precision on g....................', epsg |
| 163 |
print '(a,e9.2)' |
| 164 |
$ , ' expected optimal function value...', fmin |
| 165 |
print '(a,i9)' |
| 166 |
$ , ' maximal number of iterations......', itmax |
| 167 |
print '(a,i9)' |
| 168 |
$ , ' maximal number of simulations.....', nfunc |
| 169 |
print '(a,i9)' |
| 170 |
$ , ' information level.................', iprint |
| 171 |
print '(a,i9)' |
| 172 |
$ , ' number of updates.................', nupdate |
| 173 |
print '(a,i9)' |
| 174 |
$ , ' size of used memory...............', 3*nn |
| 175 |
endif |
| 176 |
|
| 177 |
c----------------------------------------- |
| 178 |
c check arguments |
| 179 |
c----------------------------------------- |
| 180 |
|
| 181 |
if (nn .le. 0) then |
| 182 |
if (iprint.ge.1) then |
| 183 |
print '(a,i6)' , ' ERROR : n = ', nn |
| 184 |
endif |
| 185 |
ifail = 1 |
| 186 |
goto 999 |
| 187 |
endif |
| 188 |
|
| 189 |
if (itmax .lt. 0) then |
| 190 |
if (iprint.ge.1) then |
| 191 |
print '(a,i6)' , ' ERROR : itmax = ', itmax |
| 192 |
endif |
| 193 |
ifail = 1 |
| 194 |
goto 999 |
| 195 |
endif |
| 196 |
|
| 197 |
if (nfunc .le. 0) then |
| 198 |
if (iprint.ge.10) then |
| 199 |
print '(a,i6)' , ' ERROR : nfunc = ', nfunc |
| 200 |
endif |
| 201 |
ifail = 1 |
| 202 |
goto 999 |
| 203 |
endif |
| 204 |
|
| 205 |
if (epsx .le. 0.) then |
| 206 |
if (iprint.ge.1) then |
| 207 |
print '(a,e9.2)', ' ERROR : epsx = ', epsx |
| 208 |
endif |
| 209 |
ifail = 1 |
| 210 |
goto 999 |
| 211 |
endif |
| 212 |
|
| 213 |
if (epsg .le. 0.) then |
| 214 |
if (iprint.ge.1) then |
| 215 |
print '(a,e9.2)', ' ERROR : epsg = ', epsg |
| 216 |
endif |
| 217 |
ifail = 1 |
| 218 |
goto 999 |
| 219 |
endif |
| 220 |
|
| 221 |
if (epsg .gt. 1.) then |
| 222 |
if (iprint.ge.1) then |
| 223 |
print '(a,e9.2)', ' ERROR : epsg = ', epsg |
| 224 |
endif |
| 225 |
ifail = 1 |
| 226 |
goto 999 |
| 227 |
endif |
| 228 |
|
| 229 |
cph( |
| 230 |
print *, 'pathei: vor instore ' |
| 231 |
cph) |
| 232 |
endif |
| 233 |
|
| 234 |
if (myid .eq. 0 ) print *,'bnc: cold start before instore is ',cold,sflag |
| 235 |
call instore( nn, fupd, gnorm0, isize, mupd, jmin, jmax, cold, |
| 236 |
& sflag, tflag, ifunc, tact ) |
| 237 |
if (myid .eq. 0 ) print *,'bnc: cold start after instore is ',cold,sflag |
| 238 |
|
| 239 |
|
| 240 |
cph( |
| 241 |
phff = fupd |
| 242 |
cph) |
| 243 |
|
| 244 |
c----------------------------------------- |
| 245 |
c check warm start parameters |
| 246 |
c----------------------------------------- |
| 247 |
if (myid .eq. 0 ) then |
| 248 |
|
| 249 |
if (ifail .ne. 0) then |
| 250 |
if (iprint.ge.1) then |
| 251 |
print '(a)', ' ERROR : reading restart file' |
| 252 |
end if |
| 253 |
ifail = 2 |
| 254 |
goto 999 |
| 255 |
end if |
| 256 |
|
| 257 |
if (isize .ne. REAL_BYTE) then |
| 258 |
if (iprint.ge.1) then |
| 259 |
print '(a)', ' ERROR : uncompatible floating point format' |
| 260 |
end if |
| 261 |
ifail = 2 |
| 262 |
goto 999 |
| 263 |
end if |
| 264 |
|
| 265 |
if (mupd .lt. 1) then |
| 266 |
if (iprint .ge. 1) then |
| 267 |
print '(a)', ' ERROR : m is set too small in instore' |
| 268 |
endif |
| 269 |
ifail = 2 |
| 270 |
goto 999 |
| 271 |
endif |
| 272 |
|
| 273 |
endif |
| 274 |
c----------------------------------------- |
| 275 |
c cold start or warm restart ? |
| 276 |
c----------------------------------------- |
| 277 |
|
| 278 |
if (cold) then |
| 279 |
c--- start if cold start --- |
| 280 |
if (myid .eq. 0) then |
| 281 |
|
| 282 |
if (lphprint) then |
| 283 |
print '(a)', 'pathei-lsopt: cold start' |
| 284 |
end if |
| 285 |
|
| 286 |
print *, 'pathei-lsopt vor simul', nmax |
| 287 |
print *, 'pathei-lsopt xx(1), gg(1) ',xx(1), gg(1) |
| 288 |
end if |
| 289 |
|
| 290 |
isforward = .false. |
| 291 |
call simul( indic, isforward, nn, xx, ff, gg ) |
| 292 |
|
| 293 |
if (myid .eq. 0) then |
| 294 |
print *, 'pathei: nach simul: nn, ff = ', nmax, ff |
| 295 |
print *, 'pathei: nach simul: xx(1), xx(2) = ', xx(1), xx(2) |
| 296 |
print *, 'pathei: nach simul: gg(1), gg(2) = ', gg(1), gg(2) |
| 297 |
endif |
| 298 |
|
| 299 |
do i = 1, nn |
| 300 |
xdiff(i) = 1. |
| 301 |
end do |
| 302 |
|
| 303 |
cph( |
| 304 |
if (myid .eq. 0) then |
| 305 |
print *, 'pathei: vor dostore ' |
| 306 |
cph) |
| 307 |
endif |
| 308 |
|
| 309 |
call dostore( nn, xx, .true., 1 ) |
| 310 |
call dostore( nn, gg, .true., 2 ) |
| 311 |
call dostore( nn, xdiff, .true., 3 ) |
| 312 |
|
| 313 |
if (myid .eq. 0) then |
| 314 |
cph( |
| 315 |
print *, 'pathei: vor gnorm0 ' |
| 316 |
cph) |
| 317 |
endif |
| 318 |
|
| 319 |
temp = DNRM2(nn,gg,1) |
| 320 |
call MPI_ALLREDUCE(temp*temp,gnorm0,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr) |
| 321 |
gnorm0 = dsqrt(gnorm0) |
| 322 |
|
| 323 |
if (myid .eq. 0) then |
| 324 |
cph |
| 325 |
print *, 'pathei: gnorm0 = ', gnorm0 |
| 326 |
cph) |
| 327 |
endif |
| 328 |
|
| 329 |
if (gnorm0 .lt. rmin) then |
| 330 |
ifail = 3 |
| 331 |
goto 1000 |
| 332 |
endif |
| 333 |
|
| 334 |
cph( |
| 335 |
phff = ff |
| 336 |
cph) |
| 337 |
|
| 338 |
if (lphprint .and. myid .eq. 0) |
| 339 |
& print *, 'pathei-lsopt: cold; first call simul: ff = ', |
| 340 |
& phff |
| 341 |
|
| 342 |
c--- end if cold start --- |
| 343 |
else |
| 344 |
c--- start if warm start --- |
| 345 |
if (mm .ne. nmax) then |
| 346 |
if (iprint.ge.1) then |
| 347 |
print '(a,i6)' |
| 348 |
$ , ' ERROR : inconsistent nn = ', mm |
| 349 |
endif |
| 350 |
ifail = 2 |
| 351 |
goto 999 |
| 352 |
endif |
| 353 |
if (mupd .ne. nupdate) then |
| 354 |
if (iprint.ge.1) then |
| 355 |
print '(a,i6)' |
| 356 |
$ , ' ERROR : inconsistent nupdate = ', mupd |
| 357 |
endif |
| 358 |
ifail = 2 |
| 359 |
goto 999 |
| 360 |
endif |
| 361 |
if (jmin .lt. 1) then |
| 362 |
if (iprint.ge.1) then |
| 363 |
print '(a,i6)' |
| 364 |
$ , ' ERROR : inconsistent jmin = ', jmin |
| 365 |
endif |
| 366 |
ifail = 2 |
| 367 |
goto 999 |
| 368 |
endif |
| 369 |
if (jmin .gt. mupd) then |
| 370 |
if (iprint.ge.1) then |
| 371 |
print '(a,i6)' |
| 372 |
$ , ' ERROR : inconsistent jmin = ', jmin |
| 373 |
endif |
| 374 |
ifail = 2 |
| 375 |
goto 999 |
| 376 |
endif |
| 377 |
if (jmax .gt. mupd) then |
| 378 |
if (iprint.ge.1) then |
| 379 |
print '(a,i6)' |
| 380 |
$ , ' ERROR : inconsistent jmax = ', jmax |
| 381 |
endif |
| 382 |
ifail = 2 |
| 383 |
goto 999 |
| 384 |
endif |
| 385 |
|
| 386 |
if (lphprint .and. myid .eq. 0) then |
| 387 |
print *, 'pathei-lsopt: warm start; read via dostore' |
| 388 |
print * |
| 389 |
endif |
| 390 |
|
| 391 |
call dostore( nn, xx, .false., 1 ) |
| 392 |
call dostore( nn, gg, .false., 2 ) |
| 393 |
ff = fupd |
| 394 |
|
| 395 |
cph( |
| 396 |
phff = ff |
| 397 |
cph) |
| 398 |
|
| 399 |
if (lphprint .and. myid .eq. 0) then |
| 400 |
print *, 'pathei-lsopt: warm; first dostore read: ff = ', |
| 401 |
& ff |
| 402 |
print *, ' bnc-lsopt: xx = ', |
| 403 |
& xx(1),xx(2) |
| 404 |
print *, ' bnc-lsopt: gg = ', |
| 405 |
& gg(1),gg(2) |
| 406 |
endif |
| 407 |
|
| 408 |
c--- end if warm start --- |
| 409 |
endif |
| 410 |
|
| 411 |
c----------------------------------------- |
| 412 |
c print information line |
| 413 |
c----------------------------------------- |
| 414 |
if (cold) then |
| 415 |
|
| 416 |
temp = DNRM2(nn,xx,1) |
| 417 |
call MPI_REDUCE(temp*temp,temp1,1,MPI_DOUBLE_PRECISION, |
| 418 |
& MPI_SUM,0,MPI_COMM_WORLD,ierr) |
| 419 |
|
| 420 |
if(myid .eq. 0) then |
| 421 |
if (iprint .ge. 1) then |
| 422 |
print '(2a)', ' Itn Step Nfun Objective ' |
| 423 |
$ , 'Norm G Norm X Norm (X(k-1)-X(k))' |
| 424 |
end if |
| 425 |
print iform, iiter, tact, ifunc, ff, gnorm0 |
| 426 |
$ , dsqrt(temp1), 0. |
| 427 |
endif |
| 428 |
|
| 429 |
if ( itmax .EQ. 0 ) then |
| 430 |
ifail = 10 |
| 431 |
goto 1000 |
| 432 |
end if |
| 433 |
end if |
| 434 |
|
| 435 |
c======================================================================= |
| 436 |
c begin of loop |
| 437 |
c compute x(k+1) out of x(k) + t*d, where t > 0. |
| 438 |
c======================================================================= |
| 439 |
|
| 440 |
do iiter = 1, itmax |
| 441 |
|
| 442 |
if (lphprint .and. myid .eq. 0) then |
| 443 |
print *, 'pathei-lsopt: ++++++++++++++++++++++++' |
| 444 |
print *, 'pathei-lsopt: entering iiter =', iiter |
| 445 |
endif |
| 446 |
c----------------------------------------- |
| 447 |
c store old values |
| 448 |
c----------------------------------------- |
| 449 |
do i = 1, nn |
| 450 |
gold(i) = gg(i) |
| 451 |
end do |
| 452 |
|
| 453 |
fold = ff |
| 454 |
cph( |
| 455 |
phniter0 = iiter |
| 456 |
phff = ff |
| 457 |
cph) |
| 458 |
|
| 459 |
c----------------------------------------- |
| 460 |
c compute new dd and xx |
| 461 |
c----------------------------------------- |
| 462 |
c |
| 463 |
|
| 464 |
!cheung |
| 465 |
|
| 466 |
! if (myid.eq.0) then |
| 467 |
! CALL date_and_time(values=time_array_0) |
| 468 |
! start_time = time_array_0 (5) * 3600 + time_array_0 (6) * 60 |
| 469 |
! & + time_array_0 (7) + 0.001 * time_array_0 (8) |
| 470 |
! endif ! myid = 0 |
| 471 |
|
| 472 |
if (cold) then |
| 473 |
!get steepest descent controls |
| 474 |
call lsupdxx( |
| 475 |
& nn, ifail, lphprint |
| 476 |
& , jmin, jmax, nupdate |
| 477 |
& , ff, fmin, fold, gnorm0, dotdg |
| 478 |
& , gg, dd, xx, xdiff |
| 479 |
& , tmin, tmax, tact, epsx |
| 480 |
& ) |
| 481 |
|
| 482 |
endif |
| 483 |
|
| 484 |
! if(myid.eq.0) then |
| 485 |
! CALL date_and_time(values=time_array_1) |
| 486 |
! finish_time = time_array_1 (5) * 3600 + time_array_1 (6) * 60 |
| 487 |
! & + time_array_1 (7) + 0.001 * time_array_1 (8) |
| 488 |
|
| 489 |
! write (*, '(8x, 1a, 1f16.6)') 'Clock (sec.) for lsupdxx :', |
| 490 |
! & finish_time - start_time |
| 491 |
! endif |
| 492 |
|
| 493 |
c----------------------------------------- |
| 494 |
c check whether new direction is a descent one |
| 495 |
c----------------------------------------- |
| 496 |
! if ( ifail .eq. 4) goto 1000 |
| 497 |
|
| 498 |
c----------------------------------------- |
| 499 |
c optline returns new values of x, f, and g |
| 500 |
c----------------------------------------- |
| 501 |
|
| 502 |
c |
| 503 |
if (.not. cold ) then |
| 504 |
call optline( |
| 505 |
& simul |
| 506 |
& , nn, ifail, lphprint |
| 507 |
& , ifunc, nfunc |
| 508 |
& , ff, dotdg |
| 509 |
& , sflag, tflag, tact, epsx |
| 510 |
& , dd, gg, xx, xdiff |
| 511 |
& ) |
| 512 |
|
| 513 |
if (lphprint .and. myid .eq. 0 ) then |
| 514 |
print *, 'pathei-lsopt: ', |
| 515 |
& 'back from optline; ifail = ', ifail |
| 516 |
print *, ' bnc-lsopt: ', |
| 517 |
& ' sflag = ',sflag |
| 518 |
print *, ' bnc-lsopt: ', |
| 519 |
& ' tflag = ',tflag |
| 520 |
endif |
| 521 |
endif |
| 522 |
|
| 523 |
if (.not. sflag .and. ifunc .eq. 0 ) then |
| 524 |
|
| 525 |
if (lphprint .and. myid .eq. 0 ) then |
| 526 |
print *, 'pathei-lsopt: ', |
| 527 |
& 'dostore 1,2 at iiter ', iiter |
| 528 |
print *,'bnc-lsopt: dostore xx',xx(1),xx(2) |
| 529 |
print *,'bnc-lsopt: dostore gg',gg(1),gg(2) |
| 530 |
endif |
| 531 |
|
| 532 |
call dostore( nn, xx, .true., 1 ) |
| 533 |
call dostore( nn, gg, .true., 2 ) |
| 534 |
|
| 535 |
temp = DNRM2( nn, gg, 1 ) |
| 536 |
call MPI_ALLREDUCE(temp*temp,gnorm,1,MPI_DOUBLE_PRECISION,MPI_SUM, |
| 537 |
& MPI_COMM_WORLD,ierr) |
| 538 |
gnorm = dsqrt(gnorm) |
| 539 |
|
| 540 |
c----------------------------------------- |
| 541 |
c print information line |
| 542 |
c----------------------------------------- |
| 543 |
temp = DNRM2(nn,xx,1) |
| 544 |
call MPI_REDUCE(temp*temp,temp1,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, |
| 545 |
& MPI_COMM_WORLD,ierr) |
| 546 |
temp = DNRM2(nn,dd,1) |
| 547 |
call MPI_REDUCE(temp*temp,temp2,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, |
| 548 |
& MPI_COMM_WORLD,ierr) |
| 549 |
|
| 550 |
if (myid .eq. 0) then |
| 551 |
if (iprint .ge. 1) then |
| 552 |
print '(2a)', ' Itn Step Nfun Objective ' |
| 553 |
$ , 'Norm G Norm X Norm (X(k-1)-X(k))' |
| 554 |
end if |
| 555 |
print iform, iiter, tact, ifunc, ff, gnorm |
| 556 |
$ , dsqrt(temp1), tact*dsqrt(temp2) |
| 557 |
endif |
| 558 |
|
| 559 |
c----------------------------------------- |
| 560 |
c check output mode of ifail |
| 561 |
c----------------------------------------- |
| 562 |
if ( ifail .eq. 8 |
| 563 |
& .or. ifail .eq. 9) goto 1000 |
| 564 |
|
| 565 |
c----------------------------------------- |
| 566 |
c maximal number of simulation reached |
| 567 |
c no goto in order to update Hessian |
| 568 |
c----------------------------------------- |
| 569 |
if (ifail .eq. 6) ifail = 0 |
| 570 |
|
| 571 |
c----------------------------------------- |
| 572 |
c NOTE: stopping tests are now done |
| 573 |
c after having updated the matrix, |
| 574 |
c so that update information can be stored |
| 575 |
c in case of a later warm restart |
| 576 |
c----------------------------------------- |
| 577 |
c----------------------------------------- |
| 578 |
c compute new s, y |
| 579 |
c----------------------------------------- |
| 580 |
do i = 1, nn |
| 581 |
xdiff(i) = tact*dd(i) |
| 582 |
end do |
| 583 |
|
| 584 |
c----------------------------------------- |
| 585 |
c compute ys |
| 586 |
c----------------------------------------- |
| 587 |
do i = 1, nn |
| 588 |
gold(i) = gg(i)-gold(i) |
| 589 |
end do |
| 590 |
|
| 591 |
temp = DDOT( nn, gold, 1, xdiff, 1 ) |
| 592 |
call MPI_ALLREDUCE(temp,ys,1,MPI_DOUBLE_PRECISION,MPI_SUM, |
| 593 |
& MPI_COMM_WORLD,ierr) |
| 594 |
|
| 595 |
if (ys .le. 0.) then |
| 596 |
ifail = 4 |
| 597 |
if (myid .eq. 0 ) then |
| 598 |
print *, 'bnc: max value of abs(gold) = ',maxval(abs(gold)) |
| 599 |
print *, 'pathei-lsopt: ys < 0; ifail = ', ifail |
| 600 |
endif |
| 601 |
goto 1000 |
| 602 |
endif |
| 603 |
|
| 604 |
cph( |
| 605 |
cph----------------------------------------- |
| 606 |
cph at this point it is clear that xdiff |
| 607 |
cph provides a true optimized solution; |
| 608 |
cph i.e. take new gradient gg to compute new dd |
| 609 |
cph----------------------------------------- |
| 610 |
cph) |
| 611 |
|
| 612 |
c----------------------------------------- |
| 613 |
c update pointers for hessupd |
| 614 |
c----------------------------------------- |
| 615 |
if (nupdate .gt. 0) then |
| 616 |
|
| 617 |
if (jmax .eq. 0) then |
| 618 |
jmax = jmax+1 |
| 619 |
if (lphprint .and. myid .eq. 0) |
| 620 |
& print *, 'pathei-lsopt: ', |
| 621 |
& 'first pointer update after cold start; ', |
| 622 |
& 'iiter, jmin, jmax = ', iiter, jmin, jmax |
| 623 |
else |
| 624 |
jmax = jmax+1 |
| 625 |
if (jmax .gt. nupdate) jmax = jmax-nupdate |
| 626 |
|
| 627 |
if (jmin .eq. jmax) then |
| 628 |
if (lphprint .and. myid .eq. 0) |
| 629 |
& print *, 'pathei-lsopt: pointers updated for ', |
| 630 |
& ' iiter, jmin, jmax = ', iiter, jmin, jmax |
| 631 |
jmin = jmin+1 |
| 632 |
if (jmin .gt. nupdate) jmin = jmin-nupdate |
| 633 |
end if |
| 634 |
end if |
| 635 |
|
| 636 |
c----------------------------------------- |
| 637 |
c compute sbar, ybar store rec = min 4,5 |
| 638 |
c----------------------------------------- |
| 639 |
r1 = sqrt(1./ys) |
| 640 |
call DSCAL( nn, r1, xdiff, 1 ) |
| 641 |
call DSCAL( nn, r1, gold, 1 ) |
| 642 |
|
| 643 |
if (lphprint .and. myid .eq. 0) |
| 644 |
& print *, 'pathei-lsopt: dostore at iiter, jmin, jmax ', |
| 645 |
& iiter, jmin, jmax |
| 646 |
|
| 647 |
call dostore( nn, gold, .true., 2*jmax+2 ) |
| 648 |
call dostore( nn, xdiff, .true., 2*jmax+3 ) |
| 649 |
|
| 650 |
c----------------------------------------- |
| 651 |
c compute the diagonal preconditioner |
| 652 |
c use dd as temporary array |
| 653 |
c----------------------------------------- |
| 654 |
call dgscale( nn, gold, xdiff, dd, rmin ) |
| 655 |
|
| 656 |
endif |
| 657 |
|
| 658 |
c----------------------------------------- |
| 659 |
c test convergence and stopping criteria |
| 660 |
c----------------------------------------- |
| 661 |
eps1 = gnorm / gnorm0 |
| 662 |
gnorm0 = gnorm |
| 663 |
if (eps1 .lt. epsg) then |
| 664 |
ifail = 11 |
| 665 |
goto 1000 |
| 666 |
endif |
| 667 |
|
| 668 |
c======================================================================= |
| 669 |
c return of loop |
| 670 |
c======================================================================= |
| 671 |
|
| 672 |
endif !end sflag check |
| 673 |
|
| 674 |
end do |
| 675 |
|
| 676 |
iiter = iiter - 1 |
| 677 |
ifail = 5 |
| 678 |
|
| 679 |
c----------------------------------------- |
| 680 |
c loop exit |
| 681 |
c----------------------------------------- |
| 682 |
1000 continue |
| 683 |
! nfunc = ifunc |
| 684 |
epsg = eps1 |
| 685 |
|
| 686 |
c----------------------------------------------------------------------- |
| 687 |
c compute dd(i+1), xx(i+1) based on latest available gg(i), xx(i) |
| 688 |
c for offline version |
| 689 |
c----------------------------------------------------------------------- |
| 690 |
|
| 691 |
if (.not. sflag .and. ifunc .eq. 0 ) then |
| 692 |
call lsupdxx( |
| 693 |
& nn, ifail, lphprint |
| 694 |
& , jmin, jmax, nupdate |
| 695 |
& , ff, fmin, fold, gnorm0, dotdg |
| 696 |
& , gg, dd, xx, xdiff |
| 697 |
& , tmin, tmax, tact, epsx |
| 698 |
& ) |
| 699 |
|
| 700 |
endif |
| 701 |
c Save xx(i+1) to file for offline version. |
| 702 |
if (myid .eq. 0) then |
| 703 |
print *, ' bnc-lsopt: write control ', |
| 704 |
& xdiff(1),xdiff(2) |
| 705 |
endif |
| 706 |
|
| 707 |
call optim_write_control( nn, xdiff ) |
| 708 |
|
| 709 |
c----------------------------------------------------------------------- |
| 710 |
c save data for warm start |
| 711 |
c----------------------------------------------------------------------- |
| 712 |
|
| 713 |
if ( ifunc .eq. 0 ) sflag = .not. sflag |
| 714 |
if (cold) sflag = .false. |
| 715 |
call outstore( nn, ff, gnorm0, nupdate, jmin, jmax, sflag, tflag, ifunc, tact ) |
| 716 |
|
| 717 |
|
| 718 |
c----------------------------------------- |
| 719 |
c print final information |
| 720 |
c----------------------------------------- |
| 721 |
if (iprint .ge. 5 .and. myid .eq. 0 ) then |
| 722 |
print * |
| 723 |
print '(a,i9)' |
| 724 |
$ , ' number of iterations..............', iiter |
| 725 |
print '(a,i9)' |
| 726 |
$ , ' number of simulations.............', ifunc |
| 727 |
print '(a,e9.2)' |
| 728 |
$ , ' relative precision on g...........', epsg |
| 729 |
end if |
| 730 |
|
| 731 |
|
| 732 |
temp = DNRM2(nn,xx,1) |
| 733 |
call MPI_REDUCE(temp*temp,temp1,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, |
| 734 |
& MPI_COMM_WORLD,ierr) |
| 735 |
temp = DNRM2(nn,gg,1) |
| 736 |
call MPI_REDUCE(temp*temp,temp2,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, |
| 737 |
& MPI_COMM_WORLD,ierr) |
| 738 |
|
| 739 |
if (iprint.ge.10 .and. myid .eq. 0 ) then |
| 740 |
print * |
| 741 |
print '(a,e15.8)' |
| 742 |
$ , ' cost function...............', ff |
| 743 |
print '(a,e15.8)' |
| 744 |
$ , ' norm of x...................', dsqrt(temp1) |
| 745 |
print '(a,e15.8)' |
| 746 |
$ , ' norm of g...................', dsqrt(temp2) |
| 747 |
end if |
| 748 |
|
| 749 |
c----------------------------------------- |
| 750 |
c print error message |
| 751 |
c----------------------------------------- |
| 752 |
999 continue |
| 753 |
|
| 754 |
if (myid .eq. 0 ) then |
| 755 |
|
| 756 |
if (ifail .ne. 0) then |
| 757 |
if (iprint .ge. 5) then |
| 758 |
print * |
| 759 |
print '(a)', ' optimization stopped because :' |
| 760 |
if (ifail .lt. 0) then |
| 761 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 762 |
$ , ' user request during simul' |
| 763 |
else if (ifail .eq. 0) then |
| 764 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 765 |
$ , ' optimal solution found' |
| 766 |
else if (ifail .eq. 1) then |
| 767 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 768 |
$ , ' an input argument is wrong' |
| 769 |
else if (ifail .eq. 2) then |
| 770 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 771 |
$ , ' warm start file is corrupted' |
| 772 |
else if (ifail .eq. 3) then |
| 773 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 774 |
$ , ' the initial gradient is too small' |
| 775 |
else if (ifail .eq. 4) then |
| 776 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 777 |
$ , ' the search direction is not a descent one' |
| 778 |
else if (ifail .eq. 5) then |
| 779 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 780 |
$ , ' maximal number of iterations reached' |
| 781 |
else if (ifail .eq. 6) then |
| 782 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 783 |
$ , ' maximal number of simulations reached' |
| 784 |
else if (ifail .eq. 7) then |
| 785 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 786 |
$ , ' the linesearch failed' |
| 787 |
else if (ifail .eq. 8) then |
| 788 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 789 |
$ , ' the function could not be improved' |
| 790 |
else if (ifail .eq. 9) then |
| 791 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 792 |
$ , ' optline parameters wrong' |
| 793 |
else if (ifail .eq. 10) then |
| 794 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 795 |
$ , ' cold start, no optimization done' |
| 796 |
else if (ifail .eq. 11) then |
| 797 |
print '(2x,a8,I3,a)', 'ifail = ', ifail |
| 798 |
$ , ' convergence achieved within precision' |
| 799 |
end if |
| 800 |
print * |
| 801 |
else if (iprint .ge. 1) then |
| 802 |
print * |
| 803 |
print '(a,i9)' |
| 804 |
$ , ' after optimization ifail..........', ifail |
| 805 |
print * |
| 806 |
end if |
| 807 |
end if |
| 808 |
|
| 809 |
end if |
| 810 |
c----------------------------------------- |
| 811 |
c end of subroutine |
| 812 |
c----------------------------------------- |
| 813 |
return |
| 814 |
|
| 815 |
end |
Parent Directory
| 
Revision Log
| 
Revision Graph