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