source/maxlik/src-Fmatch_safe/zscorez.F

   1       program ENE_OPT
   2 c Optimize the UNRES energy function by minimization of a quartic target
   3 c function or by the VMC method.
   4       implicit none
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11       include "DIMENSIONS.ZSCOPT"
  12 #ifdef MPI
  13       include "mpif.h"
  14       integer IERROR,ERRCODE,kolor,key
  15       include "COMMON.MPI"
  16 #endif
  17       include "COMMON.IOUNITS"
  18       include "COMMON.OPTIM"
  19       integer nvarr,iparm
  20       double precision rr,x(max_paropt)
  21       integer idumm
  22       integer i
  23 c      print *,"Starting..."
  24 #ifdef MPI
  25 c      print *,"Initializing MPI..."
  26       call MPI_Init( IERROR )
  27       call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR )
  28       call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR )
  29 c      print *,"Finished initializing MPI..."
  30       Master = 0
  31       Master1 = 1
  32 c      print *,"Me",me," Master",master," Ierror",ierror
  33       if (ierror.gt.0) then
  34         write(iout,*) "SEVERE ERROR - Can't initialize MPI."
  35         call mpi_finalize(ierror)
  36         stop
  37       endif
  38 #endif
  39 #ifndef ISNAN
  40 c NaNQ initialization
  41       i=-1
  42       rr=dacos(100.0d0)
  43 #ifdef WINPGI
  44       idumm=proc_proc(rr,i)
  45 #else
  46       call proc_proc(rr,i)
  47 #endif
  48 #endif
  49       call initialize
  50 c      print *,"calling openunits"
  51       call openunits
  52 c      print *,"openunits called"
  53       call read_general_data(*10)
  54       write (iout,'(80(1h-)/10x,
  55      & "Maximum likelihood optimization of UNRES energy function",
  56      & " v. 05/10/16"/80(1h-))')
  57       call flush(iout)
  58       call cinfo
  59 c      call promienie(*10)
  60       write (iout,*) "Finished READ_GENERAL_DATA"
  61       call flush(iout)
  62       do iparm=1,nparmset
  63         call parmread(iparm,*10)
  64       enddo
  65       call read_pmf_data(*10)
  66       write (iout,*) "Finished parmread"
  67       call flush(iout)
  68       call read_optim_parm(*10)
  69       call print_general_data(*10)
  70       call read_protein_data(*10)
  71       write (iout,*) "Finished READ_PROTEIN_DATA"
  72       call flush(iout)
  73       call read_database(*10)
  74       write (iout,*) "Finished READ_DATABASE"
  75       call flush(iout)
  76 #ifdef MPI
  77 c      write (iout,*) Me,' calling PROC_GROUPS'
  78       call proc_groups
  79 c      write (iout,*) Me,' calling WORK_PARTITION_MAP'
  80 c      call work_partition_map(nvarr)
  81 #endif
  82 #ifdef NEWCORR
  83       call pmfread(*10)
  84       write (iout,*) "Exit pmfread"
  85       call flush(iout)
  86 #endif
  87 c      write (iout,*) "calling proc_data"
  88 c      call flush(iout)
  89       call proc_data(nvarr,x,*10)
  90 c      write (iout,*) "exit proc_data"
  91 c      call flush(iout)
  92       call read_thermal
  93 #ifdef MPI
  94       if (me.eq.Master) then
  95 #endif
  96       call maxlikopt(nvarr,x)
  97 #ifdef MPI
  98       call jebadelko(nvarr)
  99       else
 100         call jebadelko(nvarr)
 101       endif
 102       call bilans
 103       call MPI_Finalize( IERROR )
 104 #else
 105       call bilans
 106 #endif
 107       stop
 108    10 write (iout,*) "Error termination of the program"
 109       call MPI_Finalize( IERROR )
 110       stop
 111       end
 112 c------------------------------------------------------------------------------
 113       subroutine bilans
 114       implicit none
 115       integer ntasks
 116       parameter (ntasks=11)
 117       include "DIMENSIONS.ZSCOPT"
 118 #ifdef MPI
 119       include "mpif.h"
 120       include "COMMON.MPI"
 121       integer IERROR
 122       double precision ttask_all(ntasks)
 123       integer nctask_all(ntasks)
 124 #endif
 125       include "COMMON.IOUNITS"
 126       integer i
 127       double precision ttask
 128       integer nctask
 129       common /timing/ ttask(ntasks),nctask(ntasks)
 130       character*16 tname(ntasks) /"function","gradient",9*''/
 131
 132       write (iout,*)
 133       write (iout,'(80(1h-))')
 134 #ifdef MPI
 135       write (iout,*) "Routine call info from the processor ",me," ..."
 136 #else
 137       write (iout,*) "Routine call info ..."
 138 #endif
 139       write (iout,*)
 140       write (iout,'(65(1h-))')
 141       write (iout,100) "task","   # calls","     total time",
 142      &  "  ave.time/call"
 143       write (iout,'(65(1h-))')
 144       do i=1,ntasks
 145         write (iout,200) tname(i),nctask(i),ttask(i),
 146      &  ttask(i)/(nctask(i)+1.0d-10)
 147       enddo
 148       write (iout,*)
 149 #ifdef MPI
 150       call MPI_Reduce(ttask(1),ttask_all(1),ntasks,
 151      &  MPI_DOUBLE_PRECISION, MPI_SUM, Master, WHAM_COMM,IERROR)
 152       call MPI_Reduce(nctask(1),nctask_all(1),ntasks,
 153      &  MPI_INTEGER, MPI_SUM, Master, WHAM_COMM,IERROR)
 154       if (Me.eq.Master) then
 155       write (iout,'(80(1h-))')
 156       write (iout,*) "Routine call info from all processors ..."
 157       write (iout,*)
 158       write (iout,'(65(1h-))')
 159       write (iout,100) "task","   # calls","     total time",
 160      &  "  ave.time/call"
 161       write (iout,'(65(1h-))')
 162       do i=1,ntasks
 163         write (iout,200) tname(i),nctask_all(i),ttask_all(i),
 164      &    ttask_all(i)/(nctask_all(i)+1.0d-10)
 165       enddo
 166       write (iout,*)
 167       endif
 168 #endif
 169       return
 170   100 format(a,t21,a,t31,a,t46,a)
 171   200 format(a,t21,i10,f15.2,f15.8)
 172       end
 173 c------------------------------------------------------------------------------
 174 #ifdef MPI
 175       subroutine proc_groups
 176 C Split the processors into the Master and Workers group, if needed.
 177       implicit none
 178       include "DIMENSIONS"
 179       include "DIMENSIONS.ZSCOPT"
 180       include "mpif.h"
 181       include "COMMON.IOUNITS"
 182       include "COMMON.MPI"
 183       include "COMMON.VMCPAR"
 184       integer n,chunk,iprot,i,j,ii,remainder
 185       integer kolor,key,ierror,errcode
 186       logical lprint
 187       lprint=.true.
 188 C No secondary structure constraints.
 189       Comm1 = WHAM_COMM
 190       Me1 = Me
 191       Nprocs1 = Nprocs
 192       return
 193       end
 194 c-------------------------------------------------------------------------------
 195       subroutine work_partition(lprint)
 196 c Split the conformations between processors
 197       implicit none
 198       include "DIMENSIONS"
 199       include "DIMENSIONS.ZSCOPT"
 200       include "mpif.h"
 201       include "COMMON.CLASSES"
 202       include "COMMON.IOUNITS"
 203       include "COMMON.MPI"
 204       include "COMMON.VMCPAR"
 205       integer n,chunk,iprot,i,j,ii,remainder
 206       integer kolor,key,ierror,errcode
 207       logical lprint
 208 C
 209 C Divide conformations between processors; for each proteins the first and
 210 C the last conformation to handle by ith processor is stored in
 211 C indstart(i,iprot) and indend(i,iprot), respectively.
 212 C
 213 C First try to assign equal number of conformations to each processor.
 214 C
 215       do iprot=1,nprot
 216         n=ntot_work(iprot)
 217         write (iout,*) "Protein",iprot," n=",n
 218         indstart(0,iprot)=1
 219         chunk = N/nprocs1
 220         scount(0,iprot) = chunk
 221 c        print *,"i",0," indstart",indstart(0,iprot)," scount",
 222 c     &     scount(0,iprot)
 223         do i=1,nprocs1-1
 224           indstart(i,iprot)=chunk+indstart(i-1,iprot)
 225           scount(i,iprot)=scount(i-1,iprot)
 226 c          print *,"i",i," indstart",indstart(i,iprot)," scount",
 227 c     &     scount(i,iprot)
 228         enddo
 229 C
 230 C Determine how many conformations remained yet unassigned.
 231 C
 232         remainder=N-(indstart(nprocs1-1,iprot)
 233      &    +scount(nprocs1-1,iprot)-1)
 234 c        print *,"remainder",remainder
 235 C
 236 C Assign the remainder conformations to consecutive processors, starting
 237 C from the lowest rank; this continues until the list is exhausted.
 238 C
 239         if (remainder .gt. 0) then
 240           do i=1,remainder
 241             scount(i-1,iprot) = scount(i-1,iprot) + 1
 242             indstart(i,iprot) = indstart(i,iprot) + i
 243           enddo
 244           do i=remainder+1,nprocs1-1
 245             indstart(i,iprot) = indstart(i,iprot) + remainder
 246           enddo
 247         endif
 248
 249         indstart(nprocs1,iprot)=N+1
 250         scount(nprocs1,iprot)=0
 251
 252         do i=0,NProcs1
 253           indend(i,iprot)=indstart(i,iprot)+scount(i,iprot)-1
 254           idispl(i,iprot)=indstart(i,iprot)-1
 255         enddo
 256
 257         N=0
 258         do i=0,Nprocs1-1
 259           N=N+indend(i,iprot)-indstart(i,iprot)+1
 260         enddo
 261
 262 c        print *,"N",n," NTOT",ntot_work(iprot)
 263         if (N.ne.ntot_work(iprot)) then
 264           write (iout,*) "!!! Checksum error on processor",me
 265           call flush(iout)
 266           call MPI_Abort( WHAM_COMM, Ierror, Errcode )
 267         endif
 268
 269         ii=0
 270         do i=1,ntot_work(iprot)
 271           if (i.ge.indstart(me1,iprot) .and. i.le.indend(me1,iprot))
 272      &    then
 273             ii=ii+1
 274             i2ii(i,iprot)=ii
 275           else
 276             i2ii(i,iprot)=0
 277           endif
 278 c          write (iout,*) "i",i," iprot",iprot," i2ii",i2ii(i,iprot)
 279         enddo
 280
 281       enddo ! iprot
 282       if (lprint) then
 283         write (iout,*) "Partition of work between processors"
 284         do iprot=1,nprot
 285           write (iout,*) "Protein",iprot
 286 #ifdef DEBUG
 287           write (iout,*) "The i2ii array"
 288           do j=1,ntot_work(iprot)
 289             write (iout,*) j,i2ii(j,iprot)
 290           enddo
 291 #endif
 292           do i=0,nprocs1-1
 293             write (iout,'(a,i5,a,i7,a,i7,a,i7)')
 294      &        "Processor",i," indstart",indstart(i,iprot),
 295      &        " indend",indend(i,iprot)," count",scount(i,iprot)
 296           enddo
 297         enddo
 298       endif
 299       return
 300       end
 301 c------------------------------------------------------------------------------
 302       subroutine jebadelko(nvarr)
 303       implicit none
 304       include "DIMENSIONS"
 305       include "DIMENSIONS.ZSCOPT"
 306       include "mpif.h"
 307       include "COMMON.IOUNITS"
 308       include "COMMON.MPI"
 309       include "COMMON.VMCPAR"
 310       include "COMMON.CLASSES"
 311       include "COMMON.OPTIM"
 312       include "COMMON.WEIGHTS"
 313       include "COMMON.WEIGHTDER"
 314       include "COMMON.ENERGIES"
 315       include "COMMON.TIME1"
 316       include "COMMON.PROTNAME"
 317       include "COMMON.PROTFILES"
 318       include "COMMON.TORSION"
 319       include "COMMON.COMPAR"
 320       integer What, TAG, IERROR, status(MPI_STATUS_SIZE), istop, iprot,
 321      &  nvarr, nf, errcode, ider
 322       integer count
 323       double precision x(max_paropt), g(max_paropt), viol
 324       integer uiparm,i,j
 325       integer ibatch,ib
 326       external fdum
 327       double precision rdum,rdif,chisquare_force
 328       double precision tcpu,t1,t1w,t1_ini,t1w_ini
 329       logical lprn,op,lder
 330       integer iun
 331       lprn=.false.
 332       ider=1
 333       write(iout,*) "Processor",me,me1," called JEBADELKO"
 334       call flush(iout)
 335       if (me.eq.Master) then
 336         istop=0
 337         call func1(nvarr,istop,x)
 338       else
 339 #ifdef DEBUG
 340       write (iout,*) "ELOWEST at slave  starting JEBADELKO"
 341       do iprot=1,nprot
 342         do ibatch=1,natlike(iprot)+2
 343           do ib=1,nbeta(ibatch,iprot)
 344             write (iout,*) "iprot",iprot," ibatch",ibatch," ib",ib,
 345      &         " elowest",elowest(ib,ibatch,iprot)
 346           enddo
 347         enddo
 348       enddo
 349 #endif
 350         istop=1
 351         t1w_ini = MPI_WTIME()
 352         t1_ini = tcpu()
 353         do while (istop.ne.0)
 354 #ifdef DEBUG
 355       write (iout,*) "ELOWEST at slave  calling FUNC1 from JBADELKO"
 356       do iprot=1,nprot
 357         do ibatch=1,natlike(iprot)+2
 358           do ib=1,nbeta(ibatch,iprot)
 359             write (iout,*) "iprot",iprot," ibatch",ibatch," ib",ib,
 360      &         " elowest",elowest(ib,ibatch,iprot)
 361           enddo
 362         enddo
 363       enddo
 364 #endif
 365           call func1(nvarr,istop,x)
 366 c          write (iout,*) "slave: after func1"
 367 c          call flush(iout)
 368 #ifdef NEWCORR
 369           if (istop.eq.1 .and. mod_fourier(nloctyp).gt.0) then
 370             rdum = rdif(nvarr,x,g,ider)
 371 c            write (iout,*) "slave: after rdif"
 372 c            call flush(iout)
 373           endif
 374 #endif
 375         if (istop.eq.1 .or. istop.eq.2 .or. istop.eq.3) then
 376 c          write (iout,*) "slave: calling chisquare_force"
 377           rdum = chisquare_force(nvarr,x,g,ider)
 378 c          write (iout,*) "slave: after chisquare_force"
 379 c          call flush(iout)
 380         endif
 381
 382         enddo
 383         t1w = mpi_wtime() - t1w_ini
 384         t1 = tcpu() - t1_ini
 385         write (iout,*)
 386         write (iout,*) "CPU time",t1," wall clock time",t1w
 387         call flush(iout)
 388       endif
 389 #ifdef DEBUG
 390       write (iout,*)
 391       write (iout,*) "Energies of processor",me
 392       do j=1,nprot
 393         write (iout,*)
 394         write (iout,*) "Protein ",protname(iprot)
 395         do i=1,ntot_work(j)
 396           if (i.ge.indstart(me1,j).and.i.le.indend(me1,j)) then
 397             write(iout,*)i,e_total(i,j),rmstb(i,j),iscore(i,0,j)
 398           endif
 399         enddo
 400       enddo
 401 #endif
 402       do iprot=1,nprot
 403         if (maxlik(iprot)) then
 404         write (iout,*) "Deleting scratchfile",bprotfiles(iprot)
 405         inquire (file=bprotfiles(iprot),number=iun,opened=op)
 406         write (iout,*) "unit",iun," icbase",icbase
 407         if (.not. op) then
 408           open (icbase,file=bprotfiles(iprot),status="old",
 409      &    form="unformatted",access="direct",recl=lenrec(iprot))
 410           close(icbase,status="delete")
 411         else
 412           close(iun,status="delete")
 413         endif
 414         call flush(iout)
 415         if (.not.mod_other_params) then
 416         write (iout,*) "Deleting scratchfile",benefiles(iprot)
 417         inquire (file=benefiles(iprot),number=iun,opened=op)
 418         write (iout,*) "unit",iun," ientout",icbase
 419         if (.not.op) then
 420           open (ientout,file=benefiles(iprot),status="old",
 421      &    form="unformatted",access="direct",recl=lenrec_ene(iprot))
 422           close(ientout,status="delete")
 423         else
 424           close (iun,status="delete")
 425         endif
 426         endif
 427         call flush(iout)
 428         endif
 429         if (fmatch(iprot)) then
 430         write (iout,*) "Deleting scratchfile",bprotfiles_MD(iprot)
 431         inquire (file=bprotfiles_MD(iprot),number=iun,opened=op)
 432         write (iout,*) "unit",iun," icbase",icbase
 433         if (.not. op) then
 434           open (icbase,file=bprotfiles_MD(iprot),status="old",
 435      &    form="unformatted",access="direct",recl=lenrec_MD(iprot))
 436           close(icbase,status="delete")
 437         else
 438           close(iun,status="delete")
 439         endif
 440         call flush(iout)
 441         if (.not.mod_other_params) then
 442         write (iout,*) "Deleting scratchfile",bforcefiles(iprot)
 443         inquire (file=bforcefiles(iprot),number=iun,opened=op)
 444         write (iout,*) "unit",iun," ientout",icbase
 445         if (.not.op) then
 446           open (ientout,file=bforcefiles(iprot),status="old",
 447      &    form="unformatted",access="direct",recl=lenrec_forces(iprot))
 448           close(ientout,status="delete")
 449         else
 450           close (iun,status="delete")
 451         endif
 452         endif
 453         call flush(iout)
 454         endif
 455       enddo
 456       write (iout,*) "Processor",me,"leaves JEBADELKO"
 457       call flush(iout)
 458       return
 459       end
 460 #endif