File indexing completed on 2018-03-02 18:36:18 UTC
view on githubraw file Latest commit f7e8e52a on 2006-03-12 08:21:47 UTC
4cee17c1be Patr*0001
0002 subroutine lsopt_top( nn, xx, ff, gg, simul, optline
0003 $ , epsx, fmin, epsg
0004 $ , iprint, itmax, nfunc, nupdate
0005 $ , dd, gold, xdiff
0006 $ , loffline
0007 $ , ifail )
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027
0028
0029
0030
0031
0032
0033
0034
0035
0036
0037
0038
0039
0040
0041
0042
0043
0044
0045
0046
0047
0048
0049
0050
0051 implicit none
0052
ae287463fd Patr*0053
4cee17c1be Patr*0054
0055
0056
0057
0058 integer nn, iprint, itmax, nfunc, nupdate, ifail
0059
0060 double precision xx(nn), ff, gg(nn), epsx, fmin, epsg
0061 double precision dd(nn), gold(nn), xdiff(nn)
0062
0063
0064 integer phniter0, phniterold
0065 double precision phff
0066 COMMON /PH_OPTI/ phniter0, phniterold, phff
0067
0068
0069 external simul, optline
0070
0071
0072
0073
0074 logical cold, lphprint, loffline
0075 parameter (lphprint = .true.)
0076
0077 integer mm, mupd, jmin, jmax, indic, isize, REAL_BYTE
0078 integer i, iiter, ifunc
0079
0080 double precision fupd
0081 double precision r1, tmin, tmax, tact, gnorm, gnorm0, eps1
0082 double precision fold, ys
0083 double precision dotdg
0084
ae287463fd Patr*0085 external DDOT, DNRM2, DSCAL
0086 double precision DDOT, DNRM2
4cee17c1be Patr*0087
0088
0089
0090
0091
0092 double precision rmin
0093 parameter( rmin = 1.e-20 )
0094
0095 character*(*) iform
0096 parameter(iform='(i5,2x,1pe8.1,1x,i5,4x,1pe11.4,3(2x,1pe8.1))' )
0097
0098
0099
0100
0101
0102
0103 cold = .true.
0104 fupd = 1.0e+10
0105 indic = 0
0106 tmin = 0.
0107 tmax = 1.0e+10
0108 tact = 1.0
0109
0110 phniterold = 0
0111
0112 iiter = 0
0113 eps1 = 1.0
0114 ifunc = 0
0115 ifail = 0
0116 gnorm0 = 1.
0117
0118
0119
0120
0121
0122 jmin = 1
0123 jmax = 0
0124
0125 mm = nn
0126 mupd = nupdate
0127
f7e8e52ac8 Patr*0128 REAL_BYTE = 4
4cee17c1be Patr*0129 isize = REAL_BYTE
0130
0131
0132
0133
0134 if (iprint .ge. 1) then
0135 print '(2x,a)',
0136 $ '==============================================='
0137 print '(2x,a)',
0138 $ '=== O P T I M I Z A T I O N ==='
0139 print '(2x,a)',
0140 $ '==============================================='
0141 print '(a,i9)'
0142 $ , ' number of control variables.......', nn
0143 print '(a,e9.2)'
0144 $ , ' precision on x....................', epsx
0145 print '(a,e9.2)'
0146 $ , ' precision on g....................', epsg
0147 print '(a,e9.2)'
0148 $ , ' expected optimal function value...', fmin
0149 print '(a,i9)'
0150 $ , ' maximal number of iterations......', itmax
0151 print '(a,i9)'
0152 $ , ' maximal number of simulations.....', nfunc
0153 print '(a,i9)'
0154 $ , ' information level.................', iprint
0155 print '(a,i9)'
0156 $ , ' number of updates.................', nupdate
0157 print '(a,i9)'
0158 $ , ' size of used memory...............', 3*nn
0159 endif
0160
0161
0162
0163
0164
0165 if (nn .le. 0) then
0166 if (iprint.ge.1) then
0167 print '(a,i6)' , ' ERROR : n = ', nn
0168 endif
0169 ifail = 1
0170 goto 999
0171 endif
0172
0173 if (itmax .lt. 0) then
0174 if (iprint.ge.1) then
0175 print '(a,i6)' , ' ERROR : itmax = ', itmax
0176 endif
0177 ifail = 1
0178 goto 999
0179 endif
0180
0181 if (nfunc .le. 0) then
0182 if (iprint.ge.10) then
0183 print '(a,i6)' , ' ERROR : nfunc = ', nfunc
0184 endif
0185 ifail = 1
0186 goto 999
0187 endif
0188
0189 if (epsx .le. 0.) then
0190 if (iprint.ge.1) then
0191 print '(a,e9.2)', ' ERROR : epsx = ', epsx
0192 endif
0193 ifail = 1
0194 goto 999
0195 endif
0196
0197 if (epsg .le. 0.) then
0198 if (iprint.ge.1) then
0199 print '(a,e9.2)', ' ERROR : epsg = ', epsg
0200 endif
0201 ifail = 1
0202 goto 999
0203 endif
0204
0205 if (epsg .gt. 1.) then
0206 if (iprint.ge.1) then
0207 print '(a,e9.2)', ' ERROR : epsg = ', epsg
0208 endif
0209 ifail = 1
0210 goto 999
0211 endif
0212
0213
0214 print *, 'pathei: vor instore '
0215
0216 call instore( mm, fupd, gnorm0, isize, mupd, jmin, jmax, cold,
0217 & ifail )
0218
0219
0220 phff = fupd
0221
0222
0223
0224
0225
0226 if (ifail .ne. 0) then
0227 if (iprint.ge.1) then
0228 print '(a)', ' ERROR : reading restart file'
0229 end if
0230 ifail = 2
0231 goto 999
0232 end if
0233
0234 if (isize .ne. REAL_BYTE) then
0235 if (iprint.ge.1) then
0236 print '(a)', ' ERROR : uncompatible floating point format'
0237 end if
0238 ifail = 2
0239 goto 999
0240 end if
0241
0242 if (mupd .lt. 1) then
0243 if (iprint .ge. 1) then
0244 print '(a)', ' ERROR : m is set too small in instore'
0245 endif
0246 ifail = 2
0247 goto 999
0248 endif
0249
0250
0251
0252
0253
0254 if (cold) then
0255
0256 if (lphprint) then
0257 print '(a)', 'pathei-lsopt: cold start'
0258 end if
0259
60c4531875 Patr*0260 print *, 'pathei-lsopt vor simul', nn
0261 print *, 'pathei-lsopt xx(1), gg(1) ', xx(1), gg(1)
0262
4cee17c1be Patr*0263 call simul( indic, nn, xx, ff, gg )
60c4531875 Patr*0264
4cee17c1be Patr*0265 print *, 'pathei: nach simul: nn, ff = ', nn, ff
60c4531875 Patr*0266 print *, 'pathei: nach simul: xx(1), gg(1) = ', xx(1), gg(1)
4cee17c1be Patr*0267
0268 do i = 1, nn
0269 xdiff(i) = 1.
0270 end do
0271
0272
0273 print *, 'pathei: vor dostore '
0274
0275 call dostore( nn, xx, .true., 1 )
0276 call dostore( nn, gg, .true., 2 )
0277 call dostore( nn, xdiff, .true., 3 )
0278
0279
0280 print *, 'pathei: vor lswri '
0281
f7e8e52ac8 Patr*0282
4cee17c1be Patr*0283
0284
0285 print *, 'pathei: vor gnorm0 '
0286
ae287463fd Patr*0287 gnorm0 = DNRM2( nn, gg, 1 )
4cee17c1be Patr*0288
0289 print *, 'pathei: gnorm0 = ', gnorm0
0290
0291 if (gnorm0 .lt. rmin) then
0292 ifail = 3
0293 goto 1000
0294 endif
0295
0296
0297 phff = ff
0298
0299
0300 if (lphprint)
0301 & print *, 'pathei-lsopt: cold; first call simul: ff = ',
0302 & phff
0303
0304
0305 else
0306
0307 if (mm .ne. nn) then
0308 if (iprint.ge.1) then
0309 print '(a,i6)'
0310 $ , ' ERROR : inconsistent nn = ', mm
0311 endif
0312 ifail = 2
0313 goto 999
0314 endif
0315 if (mupd .ne. nupdate) then
0316 if (iprint.ge.1) then
0317 print '(a,i6)'
0318 $ , ' ERROR : inconsistent nupdate = ', mupd
0319 endif
0320 ifail = 2
0321 goto 999
0322 endif
0323 if (jmin .lt. 1) then
0324 if (iprint.ge.1) then
0325 print '(a,i6)'
0326 $ , ' ERROR : inconsistent jmin = ', jmin
0327 endif
0328 ifail = 2
0329 goto 999
0330 endif
0331 if (jmin .gt. mupd) then
0332 if (iprint.ge.1) then
0333 print '(a,i6)'
0334 $ , ' ERROR : inconsistent jmin = ', jmin
0335 endif
0336 ifail = 2
0337 goto 999
0338 endif
0339 if (jmax .gt. mupd) then
0340 if (iprint.ge.1) then
0341 print '(a,i6)'
0342 $ , ' ERROR : inconsistent jmax = ', jmax
0343 endif
0344 ifail = 2
0345 goto 999
0346 endif
0347
0348 if (lphprint) then
0349 print *, 'pathei-lsopt: warm start; read via dostore'
0350 print *
0351 endif
0352
0353 call dostore( nn, xx, .false., 1 )
0354 call dostore( nn, gg, .false., 2 )
0355 ff = fupd
0356
0357
0358 phff = ff
0359
0360
0361 if (lphprint)
0362 & print *, 'pathei-lsopt: warm; first dostore read: ff = ',
0363 & ff
0364
0365
0366 endif
0367
0368 if (iprint .ge. 1) then
0369 print '(2a)', ' Itn Step Nfun Objective '
0370 $ , 'Norm G Norm X Norm (X(k-1)-X(k))'
0371 end if
0372
0373
0374
0375
0376 if (cold) then
0377 print iform, iiter, tact, ifunc, ff, gnorm0
ae287463fd Patr*0378 $ , DNRM2( nn, xx, 1 ), 0.
4cee17c1be Patr*0379
ad98788efb Mart*0380
0381
0382
4cee17c1be Patr*0383
0384 if ( itmax .EQ. 0 ) then
0385 ifail = 10
0386 goto 1000
0387 end if
0388 end if
0389
0390
0391
0392
0393
0394
0395 do iiter = 1, itmax
0396
0397 if (lphprint) then
0398 print *, 'pathei-lsopt: ++++++++++++++++++++++++'
0399 print *, 'pathei-lsopt: entering iiter =', iiter
0400 end if
0401
0402
0403
0404
0405 do i = 1, nn
0406 gold(i) = gg(i)
0407 end do
0408
0409 fold = ff
0410
0411 phniter0 = iiter
0412 phff = ff
0413
0414
0415
0416
0417
0418
0419 call lsupdxx(
0420 & nn, ifail, lphprint
0421 & , jmin, jmax, nupdate
0422 & , ff, fmin, fold, gnorm0, dotdg
0423 & , gg, dd, xx, xdiff
0424 & , tmin, tmax, tact, epsx
0425 & )
0426
0427
0428
0429
0430 if ( ifail .eq. 4) goto 1000
0431
0432
0433
0434
0435
0436 call optline(
0437 & simul
0438 & , nn, ifail, lphprint
0439 & , ifunc, nfunc
0440 & , ff, dotdg
0441 & , tmin, tmax, tact, epsx
0442 & , dd, gg, xx, xdiff
0443 & )
0444
0445 if (lphprint) print *, 'pathei-lsopt: ',
0446 & 'back from optline; ifail = ', ifail
0447 if (lphprint) print *, 'pathei-lsopt: ',
0448 & 'dostore 1,2 at iiter ', iiter
0449
0450 call dostore( nn, xx, .true., 1 )
0451 call dostore( nn, gg, .true., 2 )
0452
f7e8e52ac8 Patr*0453
4cee17c1be Patr*0454
0455
ae287463fd Patr*0456 gnorm = DNRM2( nn, gg, 1 )
4cee17c1be Patr*0457
0458
0459
0460
0461 print iform, iiter, tact, ifunc, ff, gnorm
ae287463fd Patr*0462 $ , DNRM2( nn, xx, 1 ), tact*DNRM2( nn, dd, 1 )
4cee17c1be Patr*0463
ad98788efb Mart*0464
0465
0466
4cee17c1be Patr*0467
0468
0469
0470
0471 if (ifail .eq. 7
0472 & .or. ifail .eq. 8
0473 & .or. ifail .eq. 9) goto 1000
0474
0475
0476
0477
0478
0479 if (ifail .eq. 6) ifail = 0
0480
0481
0482
0483
0484
0485
0486
0487
0488
0489
0490 do i = 1, nn
0491 xdiff(i) = tact*dd(i)
0492 end do
0493
0494
0495
0496
0497 do i = 1, nn
0498 gold(i) = gg(i)-gold(i)
0499 end do
0500
ae287463fd Patr*0501 ys = DDOT( nn, gold, 1, xdiff, 1 )
4cee17c1be Patr*0502 if (ys .le. 0.) then
0503 ifail = 4
0504 print *, 'pathei-lsopt: ys < 0; ifail = ', ifail
0505 goto 1000
0506 endif
0507
0508
0509
0510
0511
0512
0513
0514
0515
0516
0517
0518 if (nupdate .gt. 0) then
0519
0520 if (jmax .eq. 0) then
0521 jmax = jmax+1
0522 if (lphprint)
0523 & print *, 'pathei-lsopt: ',
0524 & 'first pointer update after cold start; ',
0525 & 'iiter, jmin, jmax = ', iiter, jmin, jmax
0526 else
0527 jmax = jmax+1
0528 if (jmax .gt. nupdate) jmax = jmax-nupdate
0529
0530 if (jmin .eq. jmax) then
0531 if (lphprint)
0532 & print *, 'pathei-lsopt: pointers updated for ',
0533 & ' iiter, jmin, jmax = ', iiter, jmin, jmax
0534 jmin = jmin+1
0535 if (jmin .gt. nupdate) jmin = jmin-nupdate
0536 end if
0537 end if
0538
0539
0540
0541
0542 r1 = sqrt(1./ys)
ae287463fd Patr*0543 call DSCAL( nn, r1, xdiff, 1 )
0544 call DSCAL( nn, r1, gold, 1 )
4cee17c1be Patr*0545
0546 if (lphprint)
0547 & print *, 'pathei-lsopt: dostore at iiter, jmin, jmax ',
0548 & iiter, jmin, jmax
0549
0550 call dostore( nn, gold, .true., 2*jmax+2 )
0551 call dostore( nn, xdiff, .true., 2*jmax+3 )
0552
0553
0554
0555
0556
0557 call dgscale( nn, gold, xdiff, dd, rmin )
0558
0559 endif
0560
0561
0562
0563
0564 eps1 = gnorm / gnorm0
0565
0566 if (eps1 .lt. epsg) then
0567
0568 ifail = 11
0569 goto 1000
0570 endif
0571
0572
0573
0574
0575
0576 end do
0577
0578 iiter = iiter - 1
0579 ifail = 5
0580
0581
0582
0583
0584 1000 continue
0585 nfunc = ifunc
0586 epsg = eps1
0587
0588
0589
0590
0591
0592 call outstore( nn, ff, gnorm0, nupdate, jmin, jmax )
0593
0594
0595
0596
0597
0598
0599 if (loffline) then
0600
0601 call lsupdxx(
0602 & nn, ifail, lphprint
0603 & , jmin, jmax, nupdate
0604 & , ff, fmin, fold, gnorm0, dotdg
0605 & , gg, dd, xx, xdiff
0606 & , tmin, tmax, tact, epsx
0607 & )
0608
0609
0610 call optim_write_control( nn, xdiff )
0611
0612 end if
0613
0614
0615
0616
0617 if (iprint .ge. 5) then
0618 print *
0619 print '(a,i9)'
0620 $ , ' number of iterations..............', iiter
0621 print '(a,i9)'
0622 $ , ' number of simultations............', nfunc
0623 print '(a,e9.2)'
0624 $ , ' relative precision on g...........', epsg
0625 end if
0626
0627 if (iprint.ge.10) then
0628 print *
0629 print '(a,e15.8)'
0630 $ , ' cost function...............', ff
0631 print '(a,e15.8)'
ae287463fd Patr*0632 $ , ' norm of x...................', DNRM2( nn, xx, 1 )
4cee17c1be Patr*0633 print '(a,e15.8)'
ae287463fd Patr*0634 $ , ' norm of g...................', DNRM2( nn, gg, 1 )
4cee17c1be Patr*0635 end if
0636
0637
0638
0639
0640 999 continue
0641
0642 if (ifail .ne. 0) then
0643 if (iprint .ge. 5) then
0644 print *
0645 print '(a)', ' optimization stopped because :'
0646 if (ifail .lt. 0) then
0647 print '(2x,a8,I3,a)', 'ifail = ', ifail
0648 $ , ' user request during simul'
0649 else if (ifail .eq. 0) then
0650 print '(2x,a8,I3,a)', 'ifail = ', ifail
0651 $ , ' optimal solution found'
0652 else if (ifail .eq. 1) then
0653 print '(2x,a8,I3,a)', 'ifail = ', ifail
0654 $ , ' an input argument is wrong'
0655 else if (ifail .eq. 2) then
0656 print '(2x,a8,I3,a)', 'ifail = ', ifail
0657 $ , ' warm start file is corrupted'
0658 else if (ifail .eq. 3) then
0659 print '(2x,a8,I3,a)', 'ifail = ', ifail
0660 $ , ' the initial gradient is too small'
0661 else if (ifail .eq. 4) then
0662 print '(2x,a8,I3,a)', 'ifail = ', ifail
0663 $ , ' the search direction is not a descent one'
0664 else if (ifail .eq. 5) then
0665 print '(2x,a8,I3,a)', 'ifail = ', ifail
0666 $ , ' maximal number of iterations reached'
0667 else if (ifail .eq. 6) then
0668 print '(2x,a8,I3,a)', 'ifail = ', ifail
0669 $ , ' maximal number of simulations reached'
0670 else if (ifail .eq. 7) then
0671 print '(2x,a8,I3,a)', 'ifail = ', ifail
0672 $ , ' the linesearch failed'
0673 else if (ifail .eq. 8) then
0674 print '(2x,a8,I3,a)', 'ifail = ', ifail
0675 $ , ' the function could not be improved'
0676 else if (ifail .eq. 9) then
0677 print '(2x,a8,I3,a)', 'ifail = ', ifail
0678 $ , ' optline parameters wrong'
0679 else if (ifail .eq. 10) then
0680 print '(2x,a8,I3,a)', 'ifail = ', ifail
0681 $ , ' cold start, no optimization done'
0682 else if (ifail .eq. 11) then
0683 print '(2x,a8,I3,a)', 'ifail = ', ifail
0684 $ , ' convergence achieved within precision'
0685 end if
0686 print *
0687 else if (iprint .ge. 1) then
0688 print *
0689 print '(a,i9)'
0690 $ , ' after optimization ifail..........', ifail
0691 print *
0692 end if
0693 end if
0694
0695
0696
0697
0698 return
0699
0700 end