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