source/maxlik/src_FPy/zscorez.F.safe

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