source/maxlik/src-Fmatch/mcm.F

   1       subroutine mcm
   2       implicit none
   3       include "DIMENSIONS"
   4       include "DIMENSIONS.ZSCOPT"
   5 #ifdef MPI
   6       include "mpif.h"
   7 #endif
   8       include "COMMON.NAMES"
   9       include "COMMON.WEIGHTS"
  10       include "COMMON.VMCPAR"
  11       include "COMMON.OPTIM"
  12       include "COMMON.CLASSES"
  13       include "COMMON.ENERGIES"
  14       include "COMMON.IOUNITS"
  15       integer i,j,k,igap,iprot,nf,imcm,ii,inn,n,nn,indn(max_ene)
  16       double precision target_gap0(maxobj),target_gap1(maxobj),delta
  17       logical solved,all_satisfied,not_done
  18       double precision ran_number,f,f0,x(max_paropt),x0(max_paropt),
  19      &  zz(maxobj),viol,obf,obg(max_paropt)
  20       integer iran_num,nvarr
  21       double precision tcpu,t0,t1,t0w,t1w
  22         do imcm=1,nmcm
  23           write (iout,*) "MCM procedure: step",imcm
  24           write (iout,*) "Initial params",(x(i),i=1,nvarr)
  25           write (iout,*) "f0",f0
  26           nn=iran_num(1,nvarr/3)
  27           do i=1,nvarr
  28             indn(i)=0
  29           enddo
  30           inn=0
  31           do while (inn.lt.nn)
  32             ii=iran_num(1,nvarr)
  33             if (indn(ii).eq.0) then
  34               inn=inn+1
  35               indn(ii)=1
  36             endif
  37           enddo
  38           write (iout,*) "nn",nn," indn",(indn(i),i=1,n_ene)
  39           ii=0
  40           not_done=.true.
  41           do while (not_done)
  42           do i=1,n_ene
  43             if (indn(i).eq.1) then
  44               ii=ii+1
  45               x(i)=ran_number(x_low(i),x_up(i))
  46             endif
  47           enddo
  48           call x2w(nvarr,x)
  49           if (i_local_check.gt.0)
  50      &        call viol_secondary(.false.,.false.,.false.,viol)
  51           not_done=(i_local_check.gt.0 .and. viol.gt.1.0d8)
  52           write (iout,*) "imcm",imcm," not_done",not_done
  53           if (not_done) then
  54             do i=1,n_ene
  55               x(i)=x0(i)
  56             enddo
  57           endif
  58           enddo
  59           write (iout,*) "Perturbed parameters"
  60           write (iout,*) (x(i),i=1,nvarr)
  61           call minimize(nvarr,x,f,zz)
  62           write (iout,*) "Parameters after minimization:"
  63           write (iout,*) (x(i),i=1,nvarr)
  64           write (iout,*) "f",f
  65           if (f.lt.f0) then
  66             f0=f
  67             do i=1,nvarr
  68               x0(i)=x(i)
  69               xm(i)=x(i)
  70             enddo
  71           else
  72             do i=1,nvarr
  73               x(i)=x0(i)
  74             enddo
  75           endif
  76         enddo
  77       return
  78       end