X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=blobdiff_plain;f=source%2Fwham%2Fsrc-NEWSC%2Fwham_multparm.F;fp=source%2Fwham%2Fsrc-NEWSC%2Fwham_multparm.F;h=003b6b4c2d1234e8d43ad6724e6534a4a94fee14;hb=7308760ff07636ef6b1ee28d8c3a67a23c14b34b;hp=0000000000000000000000000000000000000000;hpb=9a54ab407f6d0d9d564d52763b3e2136450b9ffc;p=unres.git

diff --git a/source/wham/src-NEWSC/wham_multparm.F b/source/wham/src-NEWSC/wham_multparm.F
new file mode 100755
index 0000000..003b6b4
--- /dev/null
+++ b/source/wham/src-NEWSC/wham_multparm.F
@@ -0,0 +1,277 @@
+      program WHAM_multparm
+c Creation/update of the database of conformations
+      implicit none
+#ifndef ISNAN
+      external proc_proc
+#endif
+#ifdef WINPGI
+cMS$ATTRIBUTES C ::  proc_proc
+#endif
+      include "DIMENSIONS"
+      include "DIMENSIONS.ZSCOPT"
+      include "DIMENSIONS.FREE"
+#ifdef MPI
+      include "mpif.h"
+      integer IERROR,ERRCODE
+      include "COMMON.MPI"
+#endif
+      include "COMMON.IOUNITS"
+      include "COMMON.FREE"
+      include "COMMON.CONTROL"
+      include "COMMON.ALLPARM"
+      include "COMMON.PROT"
+      double precision rr,x(max_paropt)
+      integer idumm
+      integer i,ipar,islice
+#ifdef MPI
+      call MPI_Init( IERROR )
+      call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR )
+      call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR )
+      Master = 0
+      if (ierror.gt.0) then
+        write(iout,*) "SEVERE ERROR - Can't initialize MPI."
+        call mpi_finalize(ierror)
+        stop
+      endif
+      if (nprocs.gt.MaxProcs+1) then
+        write (2,*) "Error - too many processors",
+     &   nprocs,MaxProcs+1
+        write (2,*) "Increase MaxProcs and recompile"
+        call MPI_Finalize(IERROR)
+        stop
+      endif
+#endif
+c NaNQ initialization
+#ifndef ISNAN
+      i=-1
+      rr=dacos(100.0d0)
+#ifdef WINPGI
+      idumm=proc_proc(rr,i)
+#else
+      call proc_proc(rr,i)
+#endif
+#endif
+      call initialize
+      call openunits
+      call cinfo
+      call read_general_data(*10)
+      call flush(iout)
+      call molread(*10)
+      call flush(iout)
+#ifdef MPI 
+      write (iout,*) "Calling proc_groups"
+      call proc_groups
+      write (iout,*) "proc_groups exited"
+      call flush(iout)
+#endif
+#ifdef SCALREP
+      write (iout,*) "1,4 SCSC repulsive interactions sacled down by 10"
+#endif
+      do ipar=1,nParmSet
+        write (iout,*) "Calling parmread",ipar
+        call parmread(ipar,*10)
+        if (.not.separate_parset) then
+          call store_parm(ipar)
+          write (iout,*) "Finished storing parameters",ipar
+        else if (ipar.eq.myparm) then
+          call store_parm(1)
+          write (iout,*) "Finished storing parameters",ipar
+        endif
+        call flush(iout)
+      enddo
+      call read_efree(*10)
+      write (iout,*) "Finished READ_EFREE"
+      call flush(iout)
+      call read_protein_data(*10)
+      write (iout,*) "Finished READ_PROTEIN_DATA"
+      call flush(iout)
+      if (indpdb.gt.0) then
+        call promienie
+        call read_compar
+        call read_ref_structure(*10)
+        call proc_cont
+        call fragment_list
+      endif
+      write (iout,*) "Begin read_database"
+      call flush(iout)
+      call read_database(*10)
+      write (iout,*) "Finished read_database"
+      call flush(iout)
+      if (separate_parset) nparmset=1
+      do islice=1,nslice
+        if (ntot(islice).gt.0) then
+#ifdef MPI 
+          call work_partition(islice,.true.)
+          write (iout,*) "work_partition OK"
+          call flush(iout)
+#endif
+          call enecalc(islice,*10)
+          write (iout,*) "enecalc OK"
+          call flush(iout)
+          write (iout,*) "Calling WHAM_calc"
+          call flush(iout)
+          call WHAM_CALC(islice,*10)
+          write (iout,*) "wham_calc OK"
+          call flush(iout)
+          call write_dbase(islice,*10)
+          write (iout,*) "write_dbase OK"
+          call flush(iout)
+          if (ensembles.gt.0) then
+            call make_ensembles(islice,*10)
+            write (iout,*) "make_ensembles OK"
+            call flush(iout)
+          endif
+        endif
+      enddo
+#ifdef MPI
+      call MPI_Finalize( IERROR )
+#endif
+      stop
+   10 write (iout,*) "Error termination of the program"
+      call MPI_Finalize( IERROR )
+      stop
+      end
+c------------------------------------------------------------------------------
+#ifdef MPI
+      subroutine proc_groups
+C Split the processors into the Master and Workers group, if needed.
+      implicit none
+      include "DIMENSIONS"
+      include "DIMENSIONS.ZSCOPT"
+      include "DIMENSIONS.FREE"
+      include "mpif.h"
+      include "COMMON.IOUNITS"
+      include "COMMON.MPI"
+      include "COMMON.FREE"
+      integer n,chunk,i,j,ii,remainder
+      integer kolor,key,ierror,errcode
+      logical lprint
+      lprint=.true.
+C 
+C Split the communicator if independent runs for different parameter
+C sets will be performed.
+C
+      if (nparmset.eq.1 .or. .not.separate_parset) then
+        WHAM_COMM = MPI_COMM_WORLD
+      else if (separate_parset) then
+        if (nprocs.lt.nparmset) then
+          write (iout,*) 
+     & "*** Cannot split parameter sets for fewer processors than sets",
+     &  nprocs,nparmset
+          call MPI_Finalize(ierror)
+          stop
+        endif 
+        write (iout,*) "nparmset",nparmset
+        nprocs = nprocs/nparmset
+        kolor = me/nprocs
+        key = mod(me,nprocs)
+        write (iout,*) "My old rank",me," kolor",kolor," key",key
+        call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,WHAM_COMM,ierror)
+        call MPI_Comm_size(WHAM_COMM,nprocs,ierror)
+        call MPI_Comm_rank(WHAM_COMM,me,ierror)
+        write (iout,*) "My new rank",me," comm size",nprocs
+        write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,
+     &   " WHAM_COMM",WHAM_COMM
+        myparm=kolor+1
+        write (iout,*) "My parameter set is",myparm
+        call flush(iout)
+      else
+        myparm=nparmset
+      endif
+      Me1 = Me
+      Nprocs1 = Nprocs
+      return
+      end
+c------------------------------------------------------------------------------
+      subroutine work_partition(islice,lprint)
+c Split the conformations between processors
+      implicit none
+      include "DIMENSIONS"
+      include "DIMENSIONS.ZSCOPT"
+      include "DIMENSIONS.FREE"
+      include "mpif.h"
+      include "COMMON.IOUNITS"
+      include "COMMON.MPI"
+      include "COMMON.PROT"
+      integer islice
+      integer n,chunk,i,j,ii,remainder
+      integer kolor,key,ierror,errcode
+      logical lprint
+C
+C Divide conformations between processors; the first and
+C the last conformation to handle by ith processor is stored in 
+C indstart(i) and indend(i), respectively.
+C
+C First try to assign equal number of conformations to each processor.
+C
+        n=ntot(islice)
+        write (iout,*) "n=",n
+        indstart(0)=1
+        chunk = N/nprocs1
+        scount(0) = chunk
+c        print *,"i",0," indstart",indstart(0)," scount",
+c     &     scount(0)
+        do i=1,nprocs1-1
+          indstart(i)=chunk+indstart(i-1) 
+          scount(i)=scount(i-1)
+c          print *,"i",i," indstart",indstart(i)," scount",
+c     &     scount(i)
+        enddo 
+C
+C Determine how many conformations remained yet unassigned.
+C
+        remainder=N-(indstart(nprocs1-1)
+     &    +scount(nprocs1-1)-1)
+c        print *,"remainder",remainder
+C
+C Assign the remainder conformations to consecutive processors, starting
+C from the lowest rank; this continues until the list is exhausted.
+C
+        if (remainder .gt. 0) then 
+          do i=1,remainder
+            scount(i-1) = scount(i-1) + 1
+            indstart(i) = indstart(i) + i
+          enddo
+          do i=remainder+1,nprocs1-1
+            indstart(i) = indstart(i) + remainder
+          enddo
+        endif
+
+        indstart(nprocs1)=N+1
+        scount(nprocs1)=0
+
+        do i=0,NProcs1
+          indend(i)=indstart(i)+scount(i)-1
+          idispl(i)=indstart(i)-1
+        enddo
+
+        N=0
+        do i=0,Nprocs1-1
+          N=N+indend(i)-indstart(i)+1
+        enddo
+
+c        print *,"N",n," NTOT",ntot(islice)
+        if (N.ne.ntot(islice)) then
+          write (iout,*) "!!! Checksum error on processor",me,
+     &     " slice",islice
+          call flush(iout)
+          call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode )
+        endif
+
+      if (lprint) then
+        write (iout,*) "Partition of work between processors"
+          do i=0,nprocs1-1
+            write (iout,'(a,i5,a,i7,a,i7,a,i7)')
+     &        "Processor",i," indstart",indstart(i),
+     &        " indend",indend(i)," count",scount(i)
+          enddo
+      endif
+      return
+      end
+#endif
+#ifdef AIX
+      subroutine flush(iu)
+      call flush_(iu)
+      return
+      end
+#endif