source/maxlik/src_FPy.org/scan.f

   1       subroutine scan(nvar,x,f0,lprn)
   2       implicit none
   3       include "DIMENSIONS"
   4       include "DIMENSIONS.ZSCOPT"
   5       include "COMMON.WEIGHTS"
   6       include "COMMON.NAMES"
   7       include "COMMON.VMCPAR"
   8       include "COMMON.IOUNITS"
   9       include "COMMON.CLASSES"
  10       include "COMMON.OPTIM"
  11       include "COMMON.ENERGIES"
  12       include "COMMON.TIME1"
  13       integer i,ii,ibatch,j,iww,nweight,iter,nf,nvar
  14       integer uiparm(1)
  15       logical lprn
  16       double precision x(max_paropt)
  17       double precision viol,f0,f,tcpu
  18       character*32 nazwa
  19       integer ilen
  20       external ilen
  21       external fdum
  22 c Systematically scan the weights one by one
  23       PREVTIM=tcpu()
  24       write (iout,*) "Enter the SCAN procedure"
  25       write (iout,*) "Initial weights"
  26       write(iout,'(9x,15(2x,a6))')(wname(i),i=1,n_ene)
  27       write(iout,40)(ww(i),i=1,n_ene)
  28       write(iout,*)'-----------------------------------'
  29
  30       call targetfun(nvar,x,nf,f0,uiparm)
  31       write (iout,*) "Initial function value:",f0
  32
  33       ii=0
  34       do i=1,n_ene
  35         if (imask(i).eq.1) then
  36           ii=ii+1
  37           ww0(i)=x(ii)
  38         else
  39           ww0(i)=ww(i)
  40         endif
  41       enddo
  42
  43       do iww=1,n_ene
  44         if (imask(iww).eq.0) goto 1222
  45         if (lprn) then
  46           nazwa='scan.'//wname(iww)(:ilen(wname(iww)))
  47           open(istat,file=nazwa)
  48         endif
  49         do i=1,n_ene
  50           ww(i)=ww0(i)
  51         enddo
  52         print *,"maxstep_scan",maxstep_scan," step_scan",step_scan
  53         do iter=1,maxstep_scan
  54           ww(iww)=iter*step_scan
  55           if (ww(iww).lt.ww_low(iww).or.ww(iww).gt.ww_up(iww)) goto 1221
  56           ii=0
  57           do i=1,n_ene
  58             if (imask(i).eq.1) then
  59               ii=ii+1
  60               x(ii)=ww(i)
  61             endif
  62           enddo
  63 c          write (*,*) iww,iter,ww(iww)
  64           call targetfun(nvar,x,nf,f,uiparm)
  65           if (f.lt.f0) then
  66             write (iout,'(2a,f10.5,2(1pe15.5))')
  67      &       "Lower function value found:",wname(iww),ww(iww),f,f0
  68             f0=f
  69             do i=1,n_ene
  70               ww0(i)=ww(i)
  71             enddo
  72           endif
  73           if (lprn) then
  74             write (istat,'(f8.3,5x,$)') ww(iww)
  75             write (istat,'(1pe15.5)') f
  76           endif
  77  1221     continue
  78         enddo ! iter
  79         close(istat)
  80  1222   continue
  81       enddo ! iww
  82
  83       ii=0
  84       do i=1,n_ene
  85         if (imask(i).eq.1) then
  86           ii=ii+1
  87           x(ii)=ww0(i)
  88         endif
  89       enddo
  90       write (iout,*) "Best function value:",f0
  91       write (iout,*)
  92       if (lprn) call write_params(nvar,nf,x)
  93       return
  94 30    format(a2,i5,1x,14(f5.3,1x),a3,100f7.3)
  95 40    format(13(f7.4,1x))
  96       end