source/unres/MD.F90

   1       module MDyn
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use md_calc
   7       use geometry_data
   8       use io_base
   9       use geometry
  10       use energy
  11       use MD_data
  12       use REMD
  13
  14       implicit none
  15 !-----------------------------------------------------------------------------
  16 ! common.MD
  17 !      common /mdgrad/ in module.energy
  18 !      common /back_constr/ in module.energy
  19 !      common /qmeas/ in module.energy
  20 !      common /mdpar/
  21 !      common /MDcalc/
  22 !      common /lagrange/
  23       real(kind=8),dimension(:),allocatable :: d_t_work,&
  24        d_t_work_new,d_af_work,d_as_work,kinetic_force !(MAXRES6)
  25       real(kind=8),dimension(:,:),allocatable :: d_t_new,&
  26        d_a_old,d_a_short!,d_a !(3,0:MAXRES2)
  27 !      real(kind=8),dimension(:),allocatable :: d_a_work !(6*MAXRES)
  28 !      real(kind=8),dimension(:,:),allocatable :: Gmat,Ginv,A,&
  29 !       Gsqrp,Gsqrm,Gvec !(maxres2,maxres2)
  30 !      real(kind=8),dimension(:),allocatable :: Geigen !(maxres2)
  31 !      integer :: dimen,dimen1,dimen3
  32 !      integer :: lang,count_reset_moment,count_reset_vel
  33 !      logical :: reset_moment,reset_vel,rattle,RESPA
  34 !      common /inertia/
  35 !      common /langevin/
  36 !      real(kind=8) :: rwat,etawat,stdfp,cPoise
  37 !      real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1)
  38 !      real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp)
  39       real(kind=8),dimension(:),allocatable :: stdforcp,stdforcsc !(MAXRES)
  40 !-----------------------------------------------------------------------------
  41 ! 'sizes.i'
  42 !
  43 !
  44 !     ###################################################
  45 !     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
  46 !     ##              All Rights Reserved              ##
  47 !     ###################################################
  48 !
  49 !     #############################################################
  50 !     ##                                                         ##
  51 !     ##  sizes.i  --  parameter values to set array dimensions  ##
  52 !     ##                                                         ##
  53 !     #############################################################
  54 !
  55 !
  56 !     "sizes.i" sets values for critical array dimensions used
  57 !     throughout the software; these parameters will fix the size
  58 !     of the largest systems that can be handled; values too large
  59 !     for the computer's memory and/or swap space to accomodate
  60 !     will result in poor performance or outright failure
  61 !
  62 !     parameter:      maximum allowed number of:
  63 !
  64 !     maxatm          atoms in the molecular system
  65 !     maxval          atoms directly bonded to an atom
  66 !     maxgrp       !  user-defined groups of atoms
  67 !     maxtyp          force field atom type definitions
  68 !     maxclass        force field atom class definitions
  69 !     maxkey          lines in the keyword file
  70 !     maxrot          bonds for torsional rotation
  71 !     maxvar          optimization variables (vector storage)
  72 !     maxopt          optimization variables (matrix storage)
  73 !     maxhess         off-diagonal Hessian elements
  74 !     maxlight        sites for method of lights neighbors
  75 !     maxvib          vibrational frequencies
  76 !     maxgeo          distance geometry points
  77 !     maxcell         unit cells in replicated crystal
  78 !     maxring         3-, 4-, or 5-membered rings
  79 !     maxfix          geometric restraints
  80 !     maxbio          biopolymer atom definitions
  81 !     maxres          residues in the macromolecule
  82 !     maxamino        amino acid residue types
  83 !     maxnuc          nucleic acid residue types
  84 !     maxbnd          covalent bonds in molecular system
  85 !     maxang          bond angles in molecular system
  86 !     maxtors         torsional angles in molecular system
  87 !     maxpi           atoms in conjugated pisystem
  88 !     maxpib          covalent bonds involving pisystem
  89 !     maxpit          torsional angles involving pisystem
  90 !
  91 !
  92 !el      integer maxatm,maxval,maxgrp
  93 !el      integer maxtyp,maxclass,maxkey
  94 !el      integer maxrot,maxopt
  95 !el      integer maxhess,maxlight,maxvib
  96 !el      integer maxgeo,maxcell,maxring
  97 !el      integer maxfix,maxbio
  98 !el      integer maxamino,maxnuc,maxbnd
  99 !el      integer maxang,maxtors,maxpi
 100 !el      integer maxpib,maxpit
 101 !      integer :: maxatm        !=2*nres        !maxres2 maxres2=2*maxres
 102 !      integer,parameter :: maxval=8
 103 !      integer,parameter :: maxgrp=1000
 104 !      integer,parameter :: maxtyp=3000
 105 !      integer,parameter :: maxclass=500
 106 !      integer,parameter :: maxkey=10000
 107 !      integer,parameter :: maxrot=1000
 108 !      integer,parameter :: maxopt=1000
 109 !      integer,parameter :: maxhess=1000000
 110 !      integer :: maxlight      !=8*maxatm
 111 !      integer,parameter :: maxvib=1000
 112 !      integer,parameter :: maxgeo=1000
 113 !      integer,parameter :: maxcell=10000
 114 !      integer,parameter :: maxring=10000
 115 !      integer,parameter :: maxfix=10000
 116 !      integer,parameter :: maxbio=10000
 117 !      integer,parameter :: maxamino=31
 118 !      integer,parameter :: maxnuc=12
 119 !      integer :: maxbnd                !=2*maxatm
 120 !      integer :: maxang                !=3*maxatm
 121 !      integer :: maxtors       !=4*maxatm
 122 !      integer,parameter :: maxpi=100
 123 !      integer,parameter :: maxpib=2*maxpi
 124 !      integer,parameter :: maxpit=4*maxpi
 125 !-----------------------------------------------------------------------------
 126 ! Maximum number of seed
 127 !      integer,parameter :: max_seed=1
 128 !-----------------------------------------------------------------------------
 129       real(kind=8),dimension(:),allocatable :: stochforcvec !(MAXRES6) maxres6=6*maxres
 130 !      common /stochcalc/ stochforcvec
 131 !-----------------------------------------------------------------------------
 132 !      common /przechowalnia/ subroutines: rattle1,rattle2,rattle_brown
 133       real(kind=8),dimension(:,:),allocatable :: GGinv !(2*nres,2*nres) maxres2=2*maxres
 134       real(kind=8),dimension(:,:,:),allocatable :: gdc !(3,2*nres,2*nres) maxres2=2*maxres
 135       real(kind=8),dimension(:,:),allocatable :: Cmat !(2*nres,2*nres) maxres2=2*maxres
 136 !-----------------------------------------------------------------------------
 137 !      common /syfek/ subroutines: friction_force,setup_fricmat
 138 !el      real(kind=8),dimension(:),allocatable :: gamvec        !(MAXRES6) or (MAXRES2)
 139 !-----------------------------------------------------------------------------
 140 !      common /przechowalnia/ subroutines: friction_force,setup_fricmat
 141       real(kind=8),dimension(:,:),allocatable :: ginvfric !(2*nres,2*nres) !maxres2=2*maxres
 142 !-----------------------------------------------------------------------------
 143 !      common /przechowalnia/ subroutine: setup_fricmat
 144 #ifndef LBFGS
 145       real(kind=8),dimension(:,:),allocatable :: fcopy !(2*nres,2*nres)
 146 #endif
 147 !-----------------------------------------------------------------------------
 148 !
 149 !
 150 !-----------------------------------------------------------------------------
 151       contains
 152 !-----------------------------------------------------------------------------
 153 ! brown_step.f
 154 !-----------------------------------------------------------------------------
 155       subroutine brown_step(itime)
 156 !------------------------------------------------
 157 !  Perform a single Euler integration step of Brownian dynamics
 158 !------------------------------------------------
 159 !      implicit real*8 (a-h,o-z)
 160       use comm_gucio
 161       use control, only: tcpu
 162       use control_data
 163       use energy_data
 164 !      use io_conf, only:cartprint
 165 !      include 'DIMENSIONS'
 166 #ifdef MPI
 167       include 'mpif.h'
 168 #endif
 169 !      include 'COMMON.CONTROL'
 170 !      include 'COMMON.VAR'
 171 !      include 'COMMON.MD'
 172 !#ifndef LANG0
 173 !      include 'COMMON.LANGEVIN'
 174 !#else
 175 !      include 'COMMON.LANGEVIN.lang0'
 176 !#endif
 177 !      include 'COMMON.CHAIN'
 178 !      include 'COMMON.DERIV'
 179 !      include 'COMMON.GEO'
 180 !      include 'COMMON.LOCAL'
 181 !      include 'COMMON.INTERACT'
 182 !      include 'COMMON.IOUNITS'
 183 !      include 'COMMON.NAMES'
 184 !      include 'COMMON.TIME1'
 185       real(kind=8),dimension(6*nres) :: zapas   !(MAXRES6) maxres6=6*maxres
 186       integer :: rstcount       !ilen,
 187 !el      external ilen
 188 !el      real(kind=8),dimension(6*nres) :: stochforcvec  !(MAXRES6) maxres6=6*maxres
 189       real(kind=8),dimension(6*nres,2*nres) :: Bmat,GBmat,Tmat  !(MAXRES6,MAXRES2) (maxres2=2*maxres,maxres6=6*maxres)
 190       real(kind=8),dimension(2*nres,2*nres) :: Cmat_,Cinv       !(maxres2,maxres2) maxres2=2*maxres
 191       real(kind=8),dimension(6*nres,6*nres) :: Pmat     !(maxres6,maxres6) maxres6=6*maxres
 192 !      real(kind=8),dimension(:,:),allocatable :: Bmat,GBmat,Tmat       !(MAXRES6,MAXRES2) (maxres2=2*maxres,maxres6=6*maxres)
 193 !      real(kind=8),dimension(:,:),allocatable :: Cmat_,Cinv    !(maxres2,maxres2) maxres2=2*maxres
 194 !      real(kind=8),dimension(:,:),allocatable :: Pmat  !(maxres6,maxres6) maxres6=6*maxres
 195       real(kind=8),dimension(6*nres) :: Td      !(maxres6) maxres6=6*maxres
 196       real(kind=8),dimension(2*nres) :: ppvec   !(maxres2) maxres2=2*maxres
 197 !el      common /stochcalc/ stochforcvec
 198 !el      real(kind=8),dimension(3) :: cm        !el
 199 !el      common /gucio/ cm
 200       integer :: itime
 201       logical :: lprn = .false.,lprn1 = .false.
 202       integer :: maxiter = 5
 203       real(kind=8) :: difftol = 1.0d-5
 204       real(kind=8) :: xx,diffmax,blen2,diffbond,tt0
 205       integer :: i,j,nbond,k,ind,ind1,iter
 206       integer :: nres2,nres6
 207       logical :: osob
 208       nres2=2*nres
 209       nres6=6*nres
 210 !      if (.not.allocated(Bmat)) allocate(Bmat(nres6,nres2))
 211 !      if (.not.allocated(GBmat)) allocate (GBmat(nres6,nres2))
 212 !      if (.not.allocated(Tmat)) allocate (Tmat(nres6,nres2))
 213 !      if (.not.allocated(Cmat_)) allocate(Cmat_(nres2,nres2))
 214 !      if (.not.allocated(Cinv)) allocate (Cinv(nres2,nres2))
 215 !      if (.not.allocated(Pmat)) allocate(Pmat(6*nres,6*nres))
 216
 217       if (.not.allocated(stochforcvec)) allocate(stochforcvec(nres6))   !(MAXRES6) maxres6=6*maxres
 218
 219       nbond=nct-nnt
 220       do i=nnt,nct
 221         if (itype(i,1).ne.10) nbond=nbond+1
 222       enddo
 223 !
 224       if (lprn1) then
 225         write (iout,*) "Generalized inverse of fricmat"
 226         call matout(dimen,dimen,nres6,nres6,fricmat)
 227       endif
 228       do i=1,dimen
 229         do j=1,nbond
 230           Bmat(i,j)=0.0d0
 231         enddo
 232       enddo
 233       ind=3
 234       ind1=0
 235       do i=nnt,nct-1
 236         ind1=ind1+1
 237         do j=1,3
 238           Bmat(ind+j,ind1)=dC_norm(j,i)
 239         enddo
 240         ind=ind+3
 241       enddo
 242       do i=nnt,nct
 243         if (itype(i,1).ne.10) then
 244           ind1=ind1+1
 245           do j=1,3
 246             Bmat(ind+j,ind1)=dC_norm(j,i+nres)
 247           enddo
 248           ind=ind+3
 249         endif
 250       enddo
 251       if (lprn1) then
 252         write (iout,*) "Matrix Bmat"
 253         call MATOUT(nbond,dimen,nres6,nres6,Bmat)
 254       endif
 255       do i=1,dimen
 256         do j=1,nbond
 257           GBmat(i,j)=0.0d0
 258           do k=1,dimen
 259             GBmat(i,j)=GBmat(i,j)+fricmat(i,k)*Bmat(k,j)
 260           enddo
 261         enddo
 262       enddo
 263       if (lprn1) then
 264         write (iout,*) "Matrix GBmat"
 265         call MATOUT(nbond,dimen,nres6,nres2,Gbmat)
 266       endif
 267       do i=1,nbond
 268         do j=1,nbond
 269           Cmat_(i,j)=0.0d0
 270           do k=1,dimen
 271             Cmat_(i,j)=Cmat_(i,j)+Bmat(k,i)*GBmat(k,j)
 272           enddo
 273         enddo
 274       enddo
 275       if (lprn1) then
 276         write (iout,*) "Matrix Cmat"
 277         call MATOUT(nbond,nbond,nres2,nres2,Cmat_)
 278       endif
 279       call matinvert(nbond,nres2,Cmat_,Cinv,osob)
 280       if (lprn1) then
 281         write (iout,*) "Matrix Cinv"
 282         call MATOUT(nbond,nbond,nres2,nres2,Cinv)
 283       endif
 284       do i=1,dimen
 285         do j=1,nbond
 286           Tmat(i,j)=0.0d0
 287           do k=1,nbond
 288             Tmat(i,j)=Tmat(i,j)+GBmat(i,k)*Cinv(k,j)
 289           enddo
 290         enddo
 291       enddo
 292       if (lprn1) then
 293         write (iout,*) "Matrix Tmat"
 294         call MATOUT(nbond,dimen,nres6,nres2,Tmat)
 295       endif
 296       do i=1,dimen
 297         do j=1,dimen
 298           if (i.eq.j) then
 299             Pmat(i,j)=1.0d0
 300           else
 301             Pmat(i,j)=0.0d0
 302           endif
 303           do k=1,nbond
 304             Pmat(i,j)=Pmat(i,j)-Tmat(i,k)*Bmat(j,k)
 305           enddo
 306         enddo
 307       enddo
 308       if (lprn1) then
 309         write (iout,*) "Matrix Pmat"
 310         call MATOUT(dimen,dimen,nres6,nres6,Pmat)
 311       endif
 312       do i=1,dimen
 313         Td(i)=0.0d0
 314         ind=0
 315         do k=nnt,nct-1
 316           ind=ind+1
 317           Td(i)=Td(i)+vbl*Tmat(i,ind)
 318         enddo
 319         do k=nnt,nct
 320           if (itype(k,1).ne.10) then
 321             ind=ind+1
 322             Td(i)=Td(i)+vbldsc0(1,itype(k,1))*Tmat(i,ind)
 323           endif
 324         enddo
 325       enddo
 326       if (lprn1) then
 327         write (iout,*) "Vector Td"
 328         do i=1,dimen
 329           write (iout,'(i5,f10.5)') i,Td(i)
 330         enddo
 331       endif
 332       call stochastic_force(stochforcvec)
 333       if (lprn) then
 334         write (iout,*) "stochforcvec"
 335         do i=1,dimen
 336           write (iout,*) i,stochforcvec(i)
 337         enddo
 338       endif
 339       do j=1,3
 340         zapas(j)=-gcart(j,0)+stochforcvec(j)
 341         d_t_work(j)=d_t(j,0)
 342         dC_work(j)=dC_old(j,0)
 343       enddo
 344       ind=3
 345       do i=nnt,nct-1
 346         do j=1,3
 347           ind=ind+1
 348           zapas(ind)=-gcart(j,i)+stochforcvec(ind)
 349           dC_work(ind)=dC_old(j,i)
 350         enddo
 351       enddo
 352       do i=nnt,nct
 353         if (itype(i,1).ne.10) then
 354           do j=1,3
 355             ind=ind+1
 356             zapas(ind)=-gxcart(j,i)+stochforcvec(ind)
 357             dC_work(ind)=dC_old(j,i+nres)
 358           enddo
 359         endif
 360       enddo
 361
 362       if (lprn) then
 363         write (iout,*) "Initial d_t_work"
 364         do i=1,dimen
 365           write (iout,*) i,d_t_work(i)
 366         enddo
 367       endif
 368
 369       do i=1,dimen
 370         d_t_work(i)=0.0d0
 371         do j=1,dimen
 372           d_t_work(i)=d_t_work(i)+fricmat(i,j)*zapas(j)
 373         enddo
 374       enddo
 375
 376       do i=1,dimen
 377         zapas(i)=Td(i)
 378         do j=1,dimen
 379           zapas(i)=zapas(i)+Pmat(i,j)*(dC_work(j)+d_t_work(j)*d_time)
 380         enddo
 381       enddo
 382       if (lprn1) then
 383         write (iout,*) "Final d_t_work and zapas"
 384         do i=1,dimen
 385           write (iout,*) i,d_t_work(i),zapas(i)
 386         enddo
 387       endif
 388
 389       do j=1,3
 390         d_t(j,0)=d_t_work(j)
 391         dc(j,0)=zapas(j)
 392         dc_work(j)=dc(j,0)
 393       enddo
 394       ind=3
 395       do i=nnt,nct-1
 396         do j=1,3
 397           d_t(j,i)=d_t_work(i)
 398           dc(j,i)=zapas(ind+j)
 399           dc_work(ind+j)=dc(j,i)
 400         enddo
 401         ind=ind+3
 402       enddo
 403       do i=nnt,nct
 404         do j=1,3
 405           d_t(j,i+nres)=d_t_work(ind+j)
 406           dc(j,i+nres)=zapas(ind+j)
 407           dc_work(ind+j)=dc(j,i+nres)
 408         enddo
 409         ind=ind+3
 410       enddo
 411       if (lprn) then
 412         call chainbuild_cart
 413         write (iout,*) "Before correction for rotational lengthening"
 414         write (iout,*) "New coordinates",&
 415         " and differences between actual and standard bond lengths"
 416         ind=0
 417         do i=nnt,nct-1
 418           ind=ind+1
 419           xx=vbld(i+1)-vbl
 420           write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
 421               i,(dC(j,i),j=1,3),xx
 422         enddo
 423         do i=nnt,nct
 424           if (itype(i,1).ne.10) then
 425             ind=ind+1
 426             xx=vbld(i+nres)-vbldsc0(1,itype(i,1))
 427             write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
 428              i,(dC(j,i+nres),j=1,3),xx
 429           endif
 430         enddo
 431       endif
 432 ! Second correction (rotational lengthening)
 433 !      do iter=1,maxiter
 434       diffmax=0.0d0
 435       ind=0
 436       do i=nnt,nct-1
 437         ind=ind+1
 438         blen2 = scalar(dc(1,i),dc(1,i))
 439         ppvec(ind)=2*vbl**2-blen2
 440         diffbond=dabs(vbl-dsqrt(blen2))
 441         if (diffbond.gt.diffmax) diffmax=diffbond
 442         if (ppvec(ind).gt.0.0d0) then
 443           ppvec(ind)=dsqrt(ppvec(ind))
 444         else
 445           ppvec(ind)=0.0d0
 446         endif
 447         if (lprn) then
 448           write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind)
 449         endif
 450       enddo
 451       do i=nnt,nct
 452         if (itype(i,1).ne.10) then
 453           ind=ind+1
 454           blen2 = scalar(dc(1,i+nres),dc(1,i+nres))
 455           ppvec(ind)=2*vbldsc0(1,itype(i,1))**2-blen2
 456           diffbond=dabs(vbldsc0(1,itype(i,1))-dsqrt(blen2))
 457           if (diffbond.gt.diffmax) diffmax=diffbond
 458           if (ppvec(ind).gt.0.0d0) then
 459             ppvec(ind)=dsqrt(ppvec(ind))
 460           else
 461             ppvec(ind)=0.0d0
 462           endif
 463           if (lprn) then
 464             write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind)
 465           endif
 466         endif
 467       enddo
 468       if (lprn) write (iout,*) "iter",iter," diffmax",diffmax
 469       if (diffmax.lt.difftol) goto 10
 470       do i=1,dimen
 471         Td(i)=0.0d0
 472         do j=1,nbond
 473           Td(i)=Td(i)+ppvec(j)*Tmat(i,j)
 474         enddo
 475       enddo
 476       do i=1,dimen
 477         zapas(i)=Td(i)
 478         do j=1,dimen
 479           zapas(i)=zapas(i)+Pmat(i,j)*dc_work(j)
 480         enddo
 481       enddo
 482       do j=1,3
 483         dc(j,0)=zapas(j)
 484         dc_work(j)=zapas(j)
 485       enddo
 486       ind=3
 487       do i=nnt,nct-1
 488         do j=1,3
 489           dc(j,i)=zapas(ind+j)
 490           dc_work(ind+j)=zapas(ind+j)
 491         enddo
 492         ind=ind+3
 493       enddo
 494       do i=nnt,nct
 495         if (itype(i,1).ne.10) then
 496           do j=1,3
 497             dc(j,i+nres)=zapas(ind+j)
 498             dc_work(ind+j)=zapas(ind+j)
 499           enddo
 500           ind=ind+3
 501         endif
 502       enddo
 503 !   Building the chain from the newly calculated coordinates
 504       call chainbuild_cart
 505       if(ntwe.ne.0) then
 506       if (large.and. mod(itime,ntwe).eq.0) then
 507         write (iout,*) "Cartesian and internal coordinates: step 1"
 508         call cartprint
 509         call intout
 510         write (iout,'(a)') "Potential forces"
 511         do i=0,nres
 512           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(-gcart(j,i),j=1,3),&
 513           (-gxcart(j,i),j=1,3)
 514         enddo
 515         write (iout,'(a)') "Stochastic forces"
 516         do i=0,nres
 517           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(stochforc(j,i),j=1,3),&
 518           (stochforc(j,i+nres),j=1,3)
 519         enddo
 520         write (iout,'(a)') "Velocities"
 521         do i=0,nres
 522           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
 523           (d_t(j,i+nres),j=1,3)
 524         enddo
 525       endif
 526       endif
 527       if (lprn) then
 528         write (iout,*) "After correction for rotational lengthening"
 529         write (iout,*) "New coordinates",&
 530         " and differences between actual and standard bond lengths"
 531         ind=0
 532         do i=nnt,nct-1
 533           ind=ind+1
 534           xx=vbld(i+1)-vbl
 535           write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
 536               i,(dC(j,i),j=1,3),xx
 537         enddo
 538         do i=nnt,nct
 539           if (itype(i,1).ne.10) then
 540             ind=ind+1
 541             xx=vbld(i+nres)-vbldsc0(1,itype(i,1))
 542             write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
 543              i,(dC(j,i+nres),j=1,3),xx
 544           endif
 545         enddo
 546       endif
 547 !      ENDDO
 548 !      write (iout,*) "Too many attempts at correcting the bonds"
 549 !      stop
 550    10 continue
 551 #ifdef MPI
 552       tt0 =MPI_Wtime()
 553 #else
 554       tt0 = tcpu()
 555 #endif
 556 ! Calculate energy and forces
 557       call zerograd
 558       call etotal(potEcomp)
 559       potE=potEcomp(0)-potEcomp(51)
 560       call cartgrad
 561       totT=totT+d_time
 562       totTafm=totT
 563 !  Calculate the kinetic and total energy and the kinetic temperature
 564       call kinetic(EK)
 565 #ifdef MPI
 566       t_enegrad=t_enegrad+MPI_Wtime()-tt0
 567 #else
 568       t_enegrad=t_enegrad+tcpu()-tt0
 569 #endif
 570       totE=EK+potE
 571       kinetic_T=2.0d0/(dimen*Rb)*EK
 572       return
 573       end subroutine brown_step
 574 !-----------------------------------------------------------------------------
 575 ! gauss.f
 576 !-----------------------------------------------------------------------------
 577       subroutine gauss(RO,AP,MT,M,N,*)
 578 !
 579 ! CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION
 580 ! RO IS A SQUARE MATRIX
 581 ! THE CALCULATED PRODUCT IS STORED IN AP
 582 ! ABNORMAL EXIT IF RO IS SINGULAR
 583 !
 584       integer :: MT, M, N, M1,I,J,IM,&
 585                  I1,MI,MI1
 586       real(kind=8) :: RO(MT,M),AP(MT,N),X,RM,PR,Y
 587       integer :: k
 588 !      real(kind=8) ::
 589
 590       if(M.ne.1)goto 10
 591       X=RO(1,1)
 592       if(dabs(X).le.1.0D-13) return 1
 593       X=1.0/X
 594       do 16 I=1,N
 595 16     AP(1,I)=AP(1,I)*X
 596        return
 597 10     continue
 598         M1=M-1
 599         DO 1 I=1,M1
 600         IM=I
 601         RM=DABS(RO(I,I))
 602         I1=I+1
 603         do 2 J=I1,M
 604         if(DABS(RO(J,I)).LE.RM) goto 2
 605         RM=DABS(RO(J,I))
 606         IM=J
 607 2       continue
 608         If(IM.eq.I)goto 17
 609         do 3 J=1,N
 610         PR=AP(I,J)
 611         AP(I,J)=AP(IM,J)
 612 3       AP(IM,J)=PR
 613         do 4 J=I,M
 614         PR=RO(I,J)
 615         RO(I,J)=RO(IM,J)
 616 4       RO(IM,J)=PR
 617 17      X=RO(I,I)
 618         if(dabs(X).le.1.0E-13) return 1
 619         X=1.0/X
 620         do 5 J=1,N
 621 5       AP(I,J)=X*AP(I,J)
 622         do 6 J=I1,M
 623 6       RO(I,J)=X*RO(I,J)
 624         do 7 J=I1,M
 625         Y=RO(J,I)
 626         do 8 K=1,N
 627 8       AP(J,K)=AP(J,K)-Y*AP(I,K)
 628         do 9 K=I1,M
 629 9       RO(J,K)=RO(J,K)-Y*RO(I,K)
 630 7       continue
 631 1       continue
 632         X=RO(M,M)
 633         if(dabs(X).le.1.0E-13) return 1
 634         X=1.0/X
 635         do 11 J=1,N
 636 11      AP(M,J)=X*AP(M,J)
 637         do 12 I=1,M1
 638         MI=M-I
 639         MI1=MI+1
 640         do 14 J=1,N
 641         X=AP(MI,J)
 642         do 15 K=MI1,M
 643 15      X=X-AP(K,J)*RO(MI,K)
 644 14      AP(MI,J)=X
 645 12      continue
 646       return
 647       end subroutine gauss
 648 !-----------------------------------------------------------------------------
 649 ! kinetic_lesyng.f
 650 #ifdef FIVEDIAG
 651        subroutine kinetic(KE_total)
 652 !c----------------------------------------------------------------
 653 !c   This subroutine calculates the total kinetic energy of the chain
 654 !c-----------------------------------------------------------------
 655 !c 3/5/2020 AL Corrected for multichain systems, no fake peptide groups
 656 !c   inside, implemented with five-diagonal inertia matrix
 657       use energy_data
 658       implicit none
 659       real(kind=8):: KE_total,KEt_p,KEt_sc,KEr_p,KEr_sc,mag1,mag2
 660       integer i,j,k,iti,mnum
 661       real(kind=8),dimension(3) :: incr,v
 662
 663       KEt_p=0.0d0
 664       KEt_sc=0.0d0
 665       KEr_p=0.0D0
 666       KEr_sc=0.0D0
 667 !c      write (iout,*) "ISC",(isc(itype(i)),i=1,nres)
 668 !c   The translational part for peptide virtual bonds
 669       do j=1,3
 670         incr(j)=d_t(j,0)
 671       enddo
 672       do i=nnt,nct-1 !czy na pewno nct-1??
 673        mnum=molnum(i)
 674 !c        write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3
 675 !c Skip dummy peptide groups
 676         if (itype(i,mnum).ne.ntyp1_molec(mnum)&
 677          .and. itype(i+1,mnum).ne.ntyp1_molec(mnum)) then
 678           do j=1,3
 679             v(j)=incr(j)+0.5d0*d_t(j,i)
 680           enddo
 681           if (mnum.eq.5) mp(mnum)=0.0d0
 682 !          if (mnum.eq.5) mp(mnum)=msc(itype(i,mnum),mnum)
 683 !c          write (iout,*) "Kinetic trp:",i,(v(j),j=1,3)
 684           vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
 685           KEt_p=KEt_p+mp(mnum)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 686         endif
 687         do j=1,3
 688           incr(j)=incr(j)+d_t(j,i)
 689         enddo
 690       enddo
 691 !c      write(iout,*) 'KEt_p', KEt_p
 692 !c The translational part for the side chain virtual bond
 693 !c Only now we can initialize incr with zeros. It must be equal
 694 !c to the velocities of the first Calpha.
 695       do j=1,3
 696         incr(j)=d_t(j,0)
 697       enddo
 698       do i=nnt,nct
 699        mnum=molnum(i)
 700         iti=iabs(itype(i,mnum))
 701         if (mnum.eq.5) iti=itype(i,mnum)
 702         if (itype(i,1).eq.10 .or. itype(i,mnum).eq.ntyp1_molec(mnum)&
 703            .or.mnum.ge.3) then
 704           do j=1,3
 705             v(j)=incr(j)
 706          enddo
 707         else
 708           do j=1,3
 709             v(j)=incr(j)+d_t(j,nres+i)
 710          enddo
 711         endif
 712 !        if (mnum.ne.5) then
 713 !        write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3)
 714 !        write (iout,*) "i",i," msc",msc(iti,mnum)," v",(v(j),j=1,3)
 715         KEt_sc=KEt_sc+msc(iti,mnum)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 716         vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
 717 !        endif
 718         do j=1,3
 719           incr(j)=incr(j)+d_t(j,i)
 720         enddo
 721       enddo
 722 !      goto 111
 723 !      write(iout,*) 'KEt_sc', KEt_sc
 724 !  The part due to stretching and rotation of the peptide groups
 725        do i=nnt,nct-1
 726          mnum=molnum(i)
 727          if (itype(i,mnum).ne.ntyp1_molec(mnum)&
 728          .and.itype(i+1,mnum).ne.ntyp1_molec(mnum)) then
 729          if (mnum.eq.5) Ip(mnum)=Isc(itype(i,mnum),mnum)
 730 !        write (iout,*) "i",i
 731 !        write (iout,*) "i",i," mag1",mag1," mag2",mag2
 732          do j=1,3
 733            incr(j)=d_t(j,i)
 734          enddo
 735 !c         write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3)
 736          KEr_p=KEr_p+Ip(mnum)*(incr(1)*incr(1)+incr(2)*incr(2) &
 737         +incr(3)*incr(3))
 738          endif
 739        enddo
 740 !c      goto 111
 741 !c       write(iout,*) 'KEr_p', KEr_p
 742 !c  The rotational part of the side chain virtual bond
 743        do i=nnt,nct
 744          mnum=molnum(i)
 745         iti=iabs(itype(i,mnum))
 746         if (itype(i,1).ne.10.and.itype(i,mnum).ne.ntyp1_molec(mnum)&
 747          .and.mnum.lt.3) then
 748         do j=1,3
 749           incr(j)=d_t(j,nres+i)
 750         enddo
 751 !        write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3)
 752         KEr_sc=KEr_sc+Isc(iti,mnum)*(incr(1)*incr(1)+incr(2)*incr(2)+&
 753           incr(3)*incr(3))
 754         endif
 755        enddo
 756 !c The total kinetic energy
 757   111  continue
 758 !       write(iout,*) ' KEt_p',KEt_p,' KEt_sc',KEt_sc,' KEr_p',KEr_p, &
 759 !       ' KEr_sc', KEr_sc
 760        KE_total=0.5d0*(KEt_p+KEt_sc+0.25d0*KEr_p+KEr_sc)
 761 !c       write (iout,*) "KE_total",KE_total
 762        return
 763        end subroutine kinetic
 764 #else
 765
 766 !-----------------------------------------------------------------------------
 767       subroutine kinetic(KE_total)
 768 !----------------------------------------------------------------
 769 !   This subroutine calculates the total kinetic energy of the chain
 770 !-----------------------------------------------------------------
 771       use energy_data
 772 !      implicit real*8 (a-h,o-z)
 773 !      include 'DIMENSIONS'
 774 !      include 'COMMON.VAR'
 775 !      include 'COMMON.CHAIN'
 776 !      include 'COMMON.DERIV'
 777 !      include 'COMMON.GEO'
 778 !      include 'COMMON.LOCAL'
 779 !      include 'COMMON.INTERACT'
 780 !      include 'COMMON.MD'
 781 !      include 'COMMON.IOUNITS'
 782       real(kind=8) :: KE_total,mscab
 783
 784       integer :: i,j,k,iti,mnum,term
 785       real(kind=8) :: KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3),&
 786        mag1,mag2,v(3)
 787 #ifdef DEBUG
 788         write (iout,*) "Velocities, kietic"
 789         do i=0,nres
 790           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
 791             (d_t(j,i+nres),j=1,3)
 792         enddo
 793 #endif
 794       KEt_p=0.0d0
 795       KEt_sc=0.0d0
 796 !      write (iout,*) "ISC",(isc(itype(i,1)),i=1,nres)
 797 !   The translational part for peptide virtual bonds
 798       do j=1,3
 799         incr(j)=d_t(j,0)
 800       enddo
 801       term=nct-1
 802 !      if (molnum(nct).gt.3) term=nct
 803       do i=nnt,term
 804        mnum=molnum(i)
 805        if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
 806 !        write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3),mp(mnum)
 807         if (mnum.gt.4) then
 808         do j=1,3
 809           v(j)=incr(j)+0.5d0*d_t(j,i)
 810         enddo
 811         else
 812         do j=1,3
 813           v(j)=incr(j)+0.5d0*d_t(j,i)
 814         enddo
 815         endif
 816         vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
 817         KEt_p=KEt_p+mp(mnum)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 818         do j=1,3
 819           incr(j)=incr(j)+d_t(j,i)
 820         enddo
 821       enddo
 822 !      write(iout,*) 'KEt_p', KEt_p
 823 ! The translational part for the side chain virtual bond
 824 ! Only now we can initialize incr with zeros. It must be equal
 825 ! to the velocities of the first Calpha.
 826       do j=1,3
 827         incr(j)=d_t(j,0)
 828       enddo
 829       do i=nnt,nct
 830          mnum=molnum(i)
 831         iti=iabs(itype(i,mnum))
 832 !        if (mnum.ge.4) then
 833 !         mscab=0.0d0
 834 !        else
 835          mscab=msc(iti,mnum)
 836 !        endif
 837 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
 838          if (itype(i,1).eq.10 .or. itype(i,mnum).eq.ntyp1_molec(mnum)&
 839           .or.(mnum.ge.4)) then
 840           do j=1,3
 841             v(j)=incr(j)
 842           enddo
 843         else
 844           do j=1,3
 845             v(j)=incr(j)+d_t(j,nres+i)
 846           enddo
 847         endif
 848 !        write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3)
 849 !        write (iout,*) "i",i," msc",msc(iti,mnum)," v",(v(j),j=1,3)
 850         KEt_sc=KEt_sc+mscab*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 851         vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
 852         do j=1,3
 853           incr(j)=incr(j)+d_t(j,i)
 854         enddo
 855       enddo
 856 !      goto 111
 857 !      write(iout,*) 'KEt_sc', KEt_sc
 858 !  The part due to stretching and rotation of the peptide groups
 859        KEr_p=0.0D0
 860        do i=nnt,nct-1
 861        mnum=molnum(i)
 862 !        write (iout,*) "i",i
 863 !        write (iout,*) "i",i," mag1",mag1," mag2",mag2
 864         do j=1,3
 865           incr(j)=d_t(j,i)
 866         enddo
 867 !        write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3)
 868           KEr_p=KEr_p+Ip(mnum)*(incr(1)*incr(1)+incr(2)*incr(2) &
 869           +incr(3)*incr(3))
 870        enddo
 871 !      goto 111
 872 !       write(iout,*) 'KEr_p', KEr_p
 873 !  The rotational part of the side chain virtual bond
 874        KEr_sc=0.0D0
 875        do i=nnt,nct
 876        mnum=molnum(i)
 877         iti=iabs(itype(i,mnum))
 878 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
 879          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
 880           .and.(mnum.lt.4)) then
 881         do j=1,3
 882           incr(j)=d_t(j,nres+i)
 883         enddo
 884 !        write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3)
 885         KEr_sc=KEr_sc+Isc(iti,mnum)*(incr(1)*incr(1)+incr(2)*incr(2)+ &
 886           incr(3)*incr(3))
 887         endif
 888        enddo
 889 ! The total kinetic energy
 890   111  continue
 891 !       write(iout,*) 'KEr_sc', KEr_sc
 892        KE_total=0.5d0*(KEt_p+KEt_sc+0.25d0*KEr_p+KEr_sc)
 893 !       write (iout,*) "KE_total",KE_total
 894       return
 895       end subroutine kinetic
 896 !-----------------------------------------------------------------------------
 897 #endif
 898        subroutine kinetic_CASC(KE_total)
 899 !c----------------------------------------------------------------
 900 !c   Compute the kinetic energy of the system using the Calpha-SC
 901 !c   coordinate system
 902 !c-----------------------------------------------------------------
 903       implicit none
 904       double precision KE_total
 905
 906       integer i,j,k,iti,ichain,innt,inct,mnum
 907       double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3),&
 908       mag1,mag2,v(3)
 909 #ifdef FIVEDIAG
 910       KEt_p=0.0d0
 911       KEt_sc=0.0d0
 912       KEr_p=0.0D0
 913       KEr_sc=0.0D0
 914 !c      write (iout,*) "ISC",(isc(itype(i)),i=1,nres)
 915 !c   The translational part for peptide virtual bonds
 916       do ichain=1,nchain
 917
 918       innt=chain_border(1,ichain)
 919       inct=chain_border(2,ichain)
 920 !c      write (iout,*) "Kinetic_CASC chain",ichain," innt",innt,
 921 !c     &  " inct",inct
 922
 923       do i=innt,inct-1
 924       mnum=molnum(i)
 925       if (mnum.eq.5) mp(mnum)=msc(itype(i,mnum),mnum)
 926       if (mnum.eq.5) mp(mnum)=msc(itype(i,mnum),mnum)
 927 !c        write (iout,*) i,(d_t(j,i),j=1,3),(d_t(j,i+1),j=1,3)
 928         do j=1,3
 929           v(j)=0.5d0*(d_t(j,i)+d_t(j,i+1))
 930         enddo
 931 !c        write (iout,*) "Kinetic trp i",i," v",(v(j),j=1,3)
 932         KEt_p=KEt_p+mp(mnum)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 933       enddo
 934 !c      write(iout,*) 'KEt_p', KEt_p
 935 !c The translational part for the side chain virtual bond
 936 !c Only now we can initialize incr with zeros. It must be equal
 937 !c to the velocities of the first Calpha.
 938       do i=innt,inct
 939         mnum=molnum(i)
 940         iti=iabs(itype(i,mnum))
 941         if (itype(i,1).eq.10.or.mnum.ge.3.or. itype(i,mnum).eq.ntyp1_molec(mnum)) then
 942 !c          write (iout,*) i,iti,(d_t(j,i),j=1,3)
 943           do j=1,3
 944             v(j)=d_t(j,i)
 945           enddo
 946         else
 947 !c          write (iout,*) i,iti,(d_t(j,nres+i),j=1,3)
 948           do j=1,3
 949             v(j)=d_t(j,nres+i)
 950           enddo
 951         endif
 952 !c        write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3)
 953 !c        write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3)
 954         KEt_sc=KEt_sc+msc(iti,mnum)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
 955       enddo
 956 !c      goto 111
 957 !c      write(iout,*) 'KEt_sc', KEt_sc
 958 !c  The part due to stretching and rotation of the peptide groups
 959        do i=innt,inct-1
 960          mnum=molnum(i)
 961          do j=1,3
 962            incr(j)=d_t(j,i+1)-d_t(j,i)
 963          enddo
 964          if (mnum.eq.5) Ip(mnum)=Isc(itype(i,mnum),mnum)
 965 !c         write (iout,*) i,(incr(j),j=1,3)
 966 !c         write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3)
 967          KEr_p=KEr_p+Ip(mnum)*(incr(1)*incr(1)+incr(2)*incr(2)&
 968           +incr(3)*incr(3))
 969        enddo
 970 !c      goto 111
 971 !c       write(iout,*) 'KEr_p', KEr_p
 972 !c  The rotational part of the side chain virtual bond
 973        do i=innt,inct
 974          mnum=molnum(i)
 975          iti=iabs(itype(i,mnum))
 976 !         if (iti.ne.10.and.mnum.lt.3) then
 977         if (itype(i,1).ne.10.and.mnum.lt.3.and. itype(i,mnum).ne.ntyp1_molec(mnum)) then
 978            do j=1,3
 979              incr(j)=d_t(j,nres+i)-d_t(j,i)
 980            enddo
 981 !c           write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3)
 982            KEr_sc=KEr_sc+Isc(iti,mnum)*(incr(1)*incr(1)+incr(2)*incr(2)+&
 983             incr(3)*incr(3))
 984          endif
 985        enddo
 986
 987        enddo ! ichain
 988 !c The total kinetic energy
 989   111  continue
 990 !c       write(iout,*) ' KEt_p',KEt_p,' KEt_sc',KEt_sc,' KEr_p',KEr_p,
 991 !c     &  ' KEr_sc', KEr_sc
 992        KE_total=0.5d0*(KEt_p+KEt_sc+0.25d0*KEr_p+KEr_sc)
 993 !c       write (iout,*) "KE_total",KE_tota
 994 #else
 995        write (iout,*) "Need to compile with -DFIVEDIAG to use this sub!"
 996        stop
 997 #endif
 998        return
 999        end subroutine kinetic_CASC
1000
1001 ! MD_A-MTS.F
1002 !-----------------------------------------------------------------------------
1003       subroutine MD
1004 !------------------------------------------------
1005 !  The driver for molecular dynamics subroutines
1006 !------------------------------------------------
1007       use comm_gucio
1008 !     use MPI
1009       use control, only:tcpu,ovrtim
1010 !      use io_comm, only:ilen
1011       use control_data
1012       use compare, only:secondary2,hairpin
1013       use io, only:cartout,statout
1014 !      implicit real*8 (a-h,o-z)
1015 !      include 'DIMENSIONS'
1016 #ifdef MPI
1017       include "mpif.h"
1018       integer :: IERROR,ERRCODE
1019 #endif
1020 !      include 'COMMON.SETUP'
1021 !      include 'COMMON.CONTROL'
1022 !      include 'COMMON.VAR'
1023 !      include 'COMMON.MD'
1024 !#ifndef LANG0
1025 !      include 'COMMON.LANGEVIN'
1026 !#else
1027 !      include 'COMMON.LANGEVIN.lang0'
1028 !#endif
1029 !      include 'COMMON.CHAIN'
1030 !      include 'COMMON.DERIV'
1031 !      include 'COMMON.GEO'
1032 !      include 'COMMON.LOCAL'
1033 !      include 'COMMON.INTERACT'
1034 !      include 'COMMON.IOUNITS'
1035 !      include 'COMMON.NAMES'
1036 !      include 'COMMON.TIME1'
1037 !      include 'COMMON.HAIRPIN'
1038       real(kind=8),dimension(3) :: L,vcm,boxx
1039 #ifdef VOUT
1040       real(kind=8),dimension(6*nres) :: v_work,v_transf !(maxres6) maxres6=6*maxres
1041 #endif
1042       integer :: rstcount       !ilen,
1043 !el      external ilen
1044       character(len=50) :: tytul
1045 !el      common /gucio/ cm
1046       integer :: i,j,nharp
1047       integer,dimension(4,nres) :: iharp        !(4,nres/3)(4,maxres/3)
1048
1049 !      logical :: ovrtim
1050       real(kind=8) :: tt0,scalfac
1051       integer :: nres2,itime
1052       nres2=2*nres
1053       print *, "ENTER MD"
1054       boxx(1)=boxxsize
1055       boxx(2)=boxysize
1056       boxx(3)=boxzsize
1057
1058 !
1059 #ifdef MPI
1060       print *,"MY tmpdir",tmpdir,ilen(tmpdir)
1061       if (ilen(tmpdir).gt.0) &
1062         call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" &
1063               //liczba(:ilen(liczba))//'.rst')
1064 #else
1065       if (ilen(tmpdir).gt.0) &
1066         call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst')
1067 #endif
1068       t_MDsetup=0.0d0
1069       t_langsetup=0.0d0
1070       t_MD=0.0d0
1071       t_enegrad=0.0d0
1072       t_sdsetup=0.0d0
1073       write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started"
1074 #ifdef MPI
1075       tt0=MPI_Wtime()
1076 #else
1077       tt0 = tcpu()
1078 #endif
1079        print *,"just befor setup matix",nres
1080 ! Determine the inverse of the inertia matrix.
1081       call setup_MD_matrices
1082 ! Initialize MD
1083       print *,"AFTER SETUP MATRICES"
1084       call init_MD
1085       print *,"AFTER INIT MD"
1086
1087 #ifdef MPI
1088       t_MDsetup = MPI_Wtime()-tt0
1089 #else
1090       t_MDsetup = tcpu()-tt0
1091 #endif
1092       rstcount=0
1093 !   Entering the MD loop
1094 #ifdef MPI
1095       tt0 = MPI_Wtime()
1096 #else
1097       tt0 = tcpu()
1098 #endif
1099       if (lang.eq.2 .or. lang.eq.3) then
1100 #ifndef   LANG0
1101         call setup_fricmat
1102         if (lang.eq.2) then
1103           call sd_verlet_p_setup
1104         else
1105           call sd_verlet_ciccotti_setup
1106         endif
1107         do i=1,dimen
1108           do j=1,dimen
1109             pfric0_mat(i,j,0)=pfric_mat(i,j)
1110             afric0_mat(i,j,0)=afric_mat(i,j)
1111             vfric0_mat(i,j,0)=vfric_mat(i,j)
1112             prand0_mat(i,j,0)=prand_mat(i,j)
1113             vrand0_mat1(i,j,0)=vrand_mat1(i,j)
1114             vrand0_mat2(i,j,0)=vrand_mat2(i,j)
1115           enddo
1116         enddo
1117         flag_stoch(0)=.true.
1118         do i=1,maxflag_stoch
1119           flag_stoch(i)=.false.
1120         enddo
1121 #else
1122         write (iout,*) &
1123          "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
1124 #ifdef MPI
1125         call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
1126 #endif
1127         stop
1128 #endif
1129       else if (lang.eq.1 .or. lang.eq.4) then
1130         print *,"before setup_fricmat"
1131         call setup_fricmat
1132         print *,"after setup_fricmat"
1133       endif
1134 #ifdef MPI
1135       t_langsetup=MPI_Wtime()-tt0
1136       tt0=MPI_Wtime()
1137 #else
1138       t_langsetup=tcpu()-tt0
1139       tt0=tcpu()
1140 #endif
1141       do itime=1,n_timestep
1142         if (large) print *,itime,ntwe
1143         if (ovrtim()) exit
1144         if (large.and. mod(itime,ntwe).eq.0) &
1145           write (iout,*) "itime",itime
1146         rstcount=rstcount+1
1147         if (lang.gt.0 .and. surfarea .and. &
1148             mod(itime,reset_fricmat).eq.0) then
1149           if (lang.eq.2 .or. lang.eq.3) then
1150 #ifndef LANG0
1151             call setup_fricmat
1152             if (lang.eq.2) then
1153               call sd_verlet_p_setup
1154             else
1155               call sd_verlet_ciccotti_setup
1156             endif
1157             do i=1,dimen
1158               do j=1,dimen
1159                 pfric0_mat(i,j,0)=pfric_mat(i,j)
1160                 afric0_mat(i,j,0)=afric_mat(i,j)
1161                 vfric0_mat(i,j,0)=vfric_mat(i,j)
1162                 prand0_mat(i,j,0)=prand_mat(i,j)
1163                 vrand0_mat1(i,j,0)=vrand_mat1(i,j)
1164                 vrand0_mat2(i,j,0)=vrand_mat2(i,j)
1165               enddo
1166             enddo
1167             flag_stoch(0)=.true.
1168             do i=1,maxflag_stoch
1169               flag_stoch(i)=.false.
1170             enddo
1171 #endif
1172           else if (lang.eq.1 .or. lang.eq.4) then
1173            print *,"before setup_fricmat"
1174             call setup_fricmat
1175            print *,"after setup_fricmat"
1176           endif
1177           write (iout,'(a,i10)') &
1178             "Friction matrix reset based on surface area, itime",itime
1179         endif
1180         if (reset_vel .and. tbf .and. lang.eq.0 &
1181             .and. mod(itime,count_reset_vel).eq.0) then
1182           !WARP WATER
1183           do i=1,nres
1184            if (molnum(i).eq.5) then
1185              call to_box(c(1,i),c(2,i),c(3,i))
1186              do j=1,3
1187              if (c(j,i).le.0) c(j,i)=c(j,i)+boxx(j)
1188              enddo
1189            endif
1190 !           write(iout,*) "COORD",c(1,i),c(2,i),c(3,i)
1191           enddo
1192           call random_vel
1193
1194           write(iout,'(a,f20.2)') &
1195            "Velocities reset to random values, time",totT
1196           do i=0,2*nres
1197             do j=1,3
1198               d_t_old(j,i)=d_t(j,i)
1199             enddo
1200           enddo
1201         endif
1202         if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then
1203           call inertia_tensor
1204           call vcm_vel(vcm)
1205           do j=1,3
1206              d_t(j,0)=d_t(j,0)-vcm(j)
1207           enddo
1208           call kinetic(EK)
1209           kinetic_T=2.0d0/(dimen3*Rb)*EK
1210           scalfac=dsqrt(T_bath/kinetic_T)
1211           write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT
1212           do i=0,2*nres
1213             do j=1,3
1214               d_t_old(j,i)=scalfac*d_t(j,i)
1215             enddo
1216           enddo
1217         endif
1218         if (lang.ne.4) then
1219           if (RESPA) then
1220 ! Time-reversible RESPA algorithm
1221 ! (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992)
1222             call RESPA_step(itime)
1223           else
1224 ! Variable time step algorithm.
1225            if (large) print *,"before verlet_step"
1226             call velverlet_step(itime)
1227            if (large) print *,"after verlet_step"
1228           endif
1229         else
1230 #ifdef BROWN
1231           call brown_step(itime)
1232 #else
1233           print *,"Brown dynamics not here!"
1234 #ifdef MPI
1235           call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
1236 #endif
1237           stop
1238 #endif
1239         endif
1240         itime_mat=itime
1241         if (ntwe.ne.0) then
1242          if (mod(itime,ntwe).eq.0) then
1243 !           call returnbox
1244             call statout(itime)
1245 !            call returnbox
1246 !            call  check_ecartint
1247          endif
1248 #ifdef VOUT
1249         do j=1,3
1250           v_work(j)=d_t(j,0)
1251         enddo
1252         ind=3
1253         do i=nnt,nct-1
1254           do j=1,3
1255             ind=ind+1
1256             v_work(ind)=d_t(j,i)
1257           enddo
1258         enddo
1259         do i=nnt,nct
1260           mnum=molnum(i)
1261           if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum).and.mnum.lt.4) then
1262             do j=1,3
1263               ind=ind+1
1264               v_work(ind)=d_t(j,i+nres)
1265             enddo
1266           endif
1267         enddo
1268
1269         write (66,'(80f10.5)') &
1270           ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres)
1271         do i=1,ind
1272           v_transf(i)=0.0d0
1273           do j=1,ind
1274             v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j)
1275           enddo
1276            v_transf(i)= v_transf(i)*dsqrt(geigen(i))
1277         enddo
1278         write (67,'(80f10.5)') (v_transf(i),i=1,ind)
1279 #endif
1280         endif
1281         if (mod(itime,ntwx).eq.0) then
1282           call returnbox
1283           call enerprint(potEcomp)
1284
1285           write (tytul,'("time",f8.2)') totT
1286           if(mdpdb) then
1287              call hairpin(.true.,nharp,iharp)
1288              call secondary2(.true.)
1289              call pdbout(potE,tytul,ipdb)
1290 !             call enerprint(potEcomp)
1291           else
1292              call cartout(totT)
1293           endif
1294            if (fodson) then
1295             write(iout,*) "starting fodstep"
1296             call fodstep(nfodstep)
1297             write(iout,*) "after fodstep"
1298             call statout(itime)
1299            if(mdpdb) then
1300               call hairpin(.true.,nharp,iharp)
1301               call secondary2(.true.)
1302               call pdbout(potE,tytul,ipdb)
1303            else
1304               call cartout(totT)
1305            endif
1306           endif
1307
1308         endif
1309         if (rstcount.eq.1000.or.itime.eq.n_timestep) then
1310            open(irest2,file=rest2name,status='unknown')
1311            write(irest2,*) totT,EK,potE,totE,t_bath
1312         totTafm=totT
1313 ! AL 4/17/17: Now writing d_t(0,:) too
1314            do i=0,2*nres
1315             write (irest2,'(3e15.5)') (d_t(j,i),j=1,3)
1316            enddo
1317 ! AL 4/17/17: Now writing d_c(0,:) too
1318            do i=0,2*nres
1319             write (irest2,'(3e15.5)') (dc(j,i),j=1,3)
1320            enddo
1321           close(irest2)
1322           rstcount=0
1323         endif
1324       enddo
1325
1326 #ifdef MPI
1327       t_MD=MPI_Wtime()-tt0
1328 #else
1329       t_MD=tcpu()-tt0
1330 #endif
1331       write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') &
1332         '  Timing  ',&
1333        'MD calculations setup:',t_MDsetup,&
1334        'Energy & gradient evaluation:',t_enegrad,&
1335        'Stochastic MD setup:',t_langsetup,&
1336        'Stochastic MD step setup:',t_sdsetup,&
1337        'MD steps:',t_MD
1338       write (iout,'(/28(1h=),a25,27(1h=))') &
1339        '  End of MD calculation  '
1340 #ifdef TIMING_ENE
1341       write (iout,*) "time for etotal",t_etotal," elong",t_elong,&
1342         " eshort",t_eshort
1343       write (iout,*) "time_fric",time_fric," time_stoch",time_stoch,&
1344        " time_fricmatmult",time_fricmatmult," time_fsample ",&
1345        time_fsample
1346 #endif
1347       return
1348       end subroutine MD
1349 !-----------------------------------------------------------------------------
1350       subroutine velverlet_step(itime)
1351 !-------------------------------------------------------------------------------
1352 !  Perform a single velocity Verlet step; the time step can be rescaled if
1353 !  increments in accelerations exceed the threshold
1354 !-------------------------------------------------------------------------------
1355 !      implicit real*8 (a-h,o-z)
1356 !      include 'DIMENSIONS'
1357       use comm_gucio
1358       use control, only:tcpu
1359       use control_data
1360       use minimm, only:minim_dc
1361 #ifdef MPI
1362       include 'mpif.h'
1363       integer :: ierror,ierrcode
1364       real(kind=8) :: errcode
1365 #endif
1366 !      include 'COMMON.SETUP'
1367 !      include 'COMMON.VAR'
1368 !      include 'COMMON.MD'
1369 !#ifndef LANG0
1370 !      include 'COMMON.LANGEVIN'
1371 !#else
1372 !      include 'COMMON.LANGEVIN.lang0'
1373 !#endif
1374 !      include 'COMMON.CHAIN'
1375 !      include 'COMMON.DERIV'
1376 !      include 'COMMON.GEO'
1377 !      include 'COMMON.LOCAL'
1378 !      include 'COMMON.INTERACT'
1379 !      include 'COMMON.IOUNITS'
1380 !      include 'COMMON.NAMES'
1381 !      include 'COMMON.TIME1'
1382 !      include 'COMMON.MUCA'
1383       real(kind=8),dimension(3) :: vcm,incr
1384       real(kind=8),dimension(3) :: L
1385       integer :: count,rstcount !ilen,
1386 !el      external ilen
1387       character(len=50) :: tytul
1388       integer :: maxcount_scale = 30
1389 !el      common /gucio/ cm
1390 !el      real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres
1391 !el      common /stochcalc/ stochforcvec
1392       integer :: icount_scale,itime_scal,i,j,ifac_time,iretcode,itime
1393       logical :: scalel
1394       real(kind=8) :: epdrift,tt0,fac_time
1395 !
1396       if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres))  !(MAXRES6) maxres6=6*maxres
1397
1398       scalel=.true.
1399       icount_scale=0
1400       if (lang.eq.1) then
1401         call sddir_precalc
1402         if (large) print *,"after sddir_precalc"
1403       else if (lang.eq.2 .or. lang.eq.3) then
1404 #ifndef LANG0
1405         call stochastic_force(stochforcvec)
1406 #else
1407         write (iout,*) &
1408          "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
1409 #ifdef MPI
1410         call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
1411 #endif
1412         stop
1413 #endif
1414       endif
1415       itime_scal=0
1416       do while (scalel)
1417         icount_scale=icount_scale+1
1418 !        write(iout,*) "icount_scale",icount_scale,scalel
1419         if (icount_scale.gt.maxcount_scale) then
1420           write (iout,*) &
1421             "ERROR: too many attempts at scaling down the time step. ",&
1422             "amax=",amax,"epdrift=",epdrift,&
1423             "damax=",damax,"edriftmax=",edriftmax,&
1424             "d_time=",d_time
1425           call flush(iout)
1426 #ifdef MPI
1427           call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE)
1428 #endif
1429           stop
1430         endif
1431 ! First step of the velocity Verlet algorithm
1432         if (lang.eq.2) then
1433 #ifndef LANG0
1434           call sd_verlet1
1435 #endif
1436         else if (lang.eq.3) then
1437 #ifndef LANG0
1438           call sd_verlet1_ciccotti
1439 #endif
1440         else if (lang.eq.1) then
1441           call sddir_verlet1
1442         else
1443           call verlet1
1444         endif
1445 ! Build the chain from the newly calculated coordinates
1446         call chainbuild_cart
1447         if (rattle) call rattle1
1448         if (ntwe.ne.0) then
1449         if (large) then !.and. mod(itime,ntwe).eq.0) then
1450           write (iout,*) "Cartesian and internal coordinates: step 1"
1451           call cartprint
1452           call intout
1453           write (iout,*) "dC"
1454           do i=0,nres
1455             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),&
1456             (dc(j,i+nres),j=1,3)
1457           enddo
1458           write (iout,*) "Accelerations"
1459           do i=0,nres
1460             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
1461             (d_a(j,i+nres),j=1,3)
1462           enddo
1463           write (iout,*) "Velocities, step 1"
1464           do i=0,nres
1465             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
1466             (d_t(j,i+nres),j=1,3)
1467           enddo
1468         endif
1469         endif
1470 #ifdef MPI
1471         tt0 = MPI_Wtime()
1472 #else
1473         tt0 = tcpu()
1474 #endif
1475 ! Calculate energy and forces
1476         call zerograd
1477         call etotal(potEcomp)
1478 ! AL 4/17/17: Reduce the steps if NaNs occurred.
1479         if (potEcomp(0).gt.0.99e18 .or. isnan(potEcomp(0)).gt.0) then
1480           call enerprint(potEcomp)
1481           d_time=d_time/10.0
1482           if (icount_scale.gt.15) then
1483           write (iout,*) "Tu jest problem",potEcomp(0),d_time
1484 !          call gen_rand_conf(1,*335)
1485 !          call minim_dc(potEcomp(0),iretcode,100)
1486
1487 !          call zerograd
1488 !          call etotal(potEcomp)
1489 !          write(iout,*) "needed to repara,",potEcomp
1490           endif
1491           cycle
1492 !  335     write(iout,*) "Failed genrand"
1493 !          cycle
1494         endif
1495 ! end change
1496         if (large.and. mod(itime,ntwe).eq.0) &
1497           call enerprint(potEcomp)
1498 #ifdef TIMING_ENE
1499 #ifdef MPI
1500         t_etotal=t_etotal+MPI_Wtime()-tt0
1501 #else
1502         t_etotal=t_etotal+tcpu()-tt0
1503 #endif
1504 #endif
1505         potE=potEcomp(0)-potEcomp(51)
1506         call cartgrad
1507 ! Get the new accelerations
1508         call lagrangian
1509 #ifdef MPI
1510         t_enegrad=t_enegrad+MPI_Wtime()-tt0
1511 #else
1512         t_enegrad=t_enegrad+tcpu()-tt0
1513 #endif
1514 ! Determine maximum acceleration and scale down the timestep if needed
1515         call max_accel
1516         amax=amax/(itime_scal+1)**2
1517         call predict_edrift(epdrift)
1518 !        write(iout,*) "amax=",amax,damax,epdrift,edriftmax,amax/(itime_scal+1)
1519         scalel=.false.
1520 !        write (iout,*) "before enter if",scalel,icount_scale
1521         if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then
1522 !          write(iout,*) "I enter if"
1523 ! Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step
1524           scalel=.true.
1525           ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) &
1526             /dlog(2.0d0)+1
1527           itime_scal=itime_scal+ifac_time
1528 !          fac_time=dmin1(damax/amax,0.5d0)
1529           fac_time=0.5d0**ifac_time
1530           d_time=d_time*fac_time
1531           if (lang.eq.2 .or. lang.eq.3) then
1532 #ifndef LANG0
1533 !            write (iout,*) "Calling sd_verlet_setup: 1"
1534 ! Rescale the stochastic forces and recalculate or restore
1535 ! the matrices of tinker integrator
1536             if (itime_scal.gt.maxflag_stoch) then
1537               if (large) write (iout,'(a,i5,a)') &
1538                "Calculate matrices for stochastic step;",&
1539                " itime_scal ",itime_scal
1540               if (lang.eq.2) then
1541                 call sd_verlet_p_setup
1542               else
1543                 call sd_verlet_ciccotti_setup
1544               endif
1545               write (iout,'(2a,i3,a,i3,1h.)') &
1546                "Warning: cannot store matrices for stochastic",&
1547                " integration because the index",itime_scal,&
1548                " is greater than",maxflag_stoch
1549               write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct",&
1550                " integration Langevin algorithm for better efficiency."
1551             else if (flag_stoch(itime_scal)) then
1552               if (large) write (iout,'(a,i5,a,l1)') &
1553                "Restore matrices for stochastic step; itime_scal ",&
1554                itime_scal," flag ",flag_stoch(itime_scal)
1555               do i=1,dimen
1556                 do j=1,dimen
1557                   pfric_mat(i,j)=pfric0_mat(i,j,itime_scal)
1558                   afric_mat(i,j)=afric0_mat(i,j,itime_scal)
1559                   vfric_mat(i,j)=vfric0_mat(i,j,itime_scal)
1560                   prand_mat(i,j)=prand0_mat(i,j,itime_scal)
1561                   vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal)
1562                   vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal)
1563                 enddo
1564               enddo
1565             else
1566               if (large) write (iout,'(2a,i5,a,l1)') &
1567                "Calculate & store matrices for stochastic step;",&
1568                " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal)
1569               if (lang.eq.2) then
1570                 call sd_verlet_p_setup
1571               else
1572                 call sd_verlet_ciccotti_setup
1573               endif
1574               flag_stoch(ifac_time)=.true.
1575               do i=1,dimen
1576                 do j=1,dimen
1577                   pfric0_mat(i,j,itime_scal)=pfric_mat(i,j)
1578                   afric0_mat(i,j,itime_scal)=afric_mat(i,j)
1579                   vfric0_mat(i,j,itime_scal)=vfric_mat(i,j)
1580                   prand0_mat(i,j,itime_scal)=prand_mat(i,j)
1581                   vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j)
1582                   vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j)
1583                 enddo
1584               enddo
1585             endif
1586             fac_time=1.0d0/dsqrt(fac_time)
1587             do i=1,dimen
1588               stochforcvec(i)=fac_time*stochforcvec(i)
1589             enddo
1590 #endif
1591           else if (lang.eq.1) then
1592 ! Rescale the accelerations due to stochastic forces
1593             fac_time=1.0d0/dsqrt(fac_time)
1594             do i=1,dimen
1595               d_as_work(i)=d_as_work(i)*fac_time
1596             enddo
1597           endif
1598           if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') &
1599             "itime",itime," Timestep scaled down to ",&
1600             d_time," ifac_time",ifac_time," itime_scal",itime_scal
1601         else
1602 ! Second step of the velocity Verlet algorithm
1603           if (lang.eq.2) then
1604 #ifndef LANG0
1605             call sd_verlet2
1606 #endif
1607           else if (lang.eq.3) then
1608 #ifndef LANG0
1609             call sd_verlet2_ciccotti
1610 #endif
1611           else if (lang.eq.1) then
1612             call sddir_verlet2
1613           else
1614             call verlet2
1615           endif
1616           if (rattle) call rattle2
1617           totT=totT+d_time
1618         totTafm=totT
1619           if (d_time.ne.d_time0) then
1620             d_time=d_time0
1621 #ifndef   LANG0
1622             if (lang.eq.2 .or. lang.eq.3) then
1623               if (large) write (iout,'(a)') &
1624                "Restore original matrices for stochastic step"
1625 !              write (iout,*) "Calling sd_verlet_setup: 2"
1626 ! Restore the matrices of tinker integrator if the time step has been restored
1627               do i=1,dimen
1628                 do j=1,dimen
1629                   pfric_mat(i,j)=pfric0_mat(i,j,0)
1630                   afric_mat(i,j)=afric0_mat(i,j,0)
1631                   vfric_mat(i,j)=vfric0_mat(i,j,0)
1632                   prand_mat(i,j)=prand0_mat(i,j,0)
1633                   vrand_mat1(i,j)=vrand0_mat1(i,j,0)
1634                   vrand_mat2(i,j)=vrand0_mat2(i,j,0)
1635                 enddo
1636               enddo
1637             endif
1638 #endif
1639           endif
1640         endif
1641       enddo
1642 ! Calculate the kinetic and the total energy and the kinetic temperature
1643       call kinetic(EK)
1644       totE=EK+potE
1645 ! diagnostics
1646 !      call kinetic1(EK1)
1647 !      write (iout,*) "step",itime," EK",EK," EK1",EK1
1648 ! end diagnostics
1649 ! Couple the system to Berendsen bath if needed
1650       if (tbf .and. lang.eq.0) then
1651         call verlet_bath
1652       endif
1653       kinetic_T=2.0d0/(dimen3*Rb)*EK
1654 ! Backup the coordinates, velocities, and accelerations
1655       do i=0,2*nres
1656         do j=1,3
1657           dc_old(j,i)=dc(j,i)
1658           d_t_old(j,i)=d_t(j,i)
1659           d_a_old(j,i)=d_a(j,i)
1660         enddo
1661       enddo
1662       if (ntwe.ne.0) then
1663       if (mod(itime,ntwe).eq.0 .and. large) then
1664         write (iout,*) "Velocities, step 2"
1665         do i=0,nres
1666           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
1667             (d_t(j,i+nres),j=1,3)
1668         enddo
1669       endif
1670       endif
1671       return
1672       end subroutine velverlet_step
1673 !-----------------------------------------------------------------------------
1674       subroutine RESPA_step(itime)
1675 !-------------------------------------------------------------------------------
1676 !  Perform a single RESPA step.
1677 !-------------------------------------------------------------------------------
1678 !      implicit real*8 (a-h,o-z)
1679 !      include 'DIMENSIONS'
1680       use comm_gucio
1681       use comm_cipiszcze
1682 !     use MPI
1683       use control, only:tcpu
1684       use control_data
1685 !      use io_conf, only:cartprint
1686 #ifdef MPI
1687       include 'mpif.h'
1688       integer :: IERROR,ERRCODE
1689 #endif
1690 !      include 'COMMON.SETUP'
1691 !      include 'COMMON.CONTROL'
1692 !      include 'COMMON.VAR'
1693 !      include 'COMMON.MD'
1694 !#ifndef LANG0
1695 !      include 'COMMON.LANGEVIN'
1696 !#else
1697 !      include 'COMMON.LANGEVIN.lang0'
1698 !#endif
1699 !      include 'COMMON.CHAIN'
1700 !      include 'COMMON.DERIV'
1701 !      include 'COMMON.GEO'
1702 !      include 'COMMON.LOCAL'
1703 !      include 'COMMON.INTERACT'
1704 !      include 'COMMON.IOUNITS'
1705 !      include 'COMMON.NAMES'
1706 !      include 'COMMON.TIME1'
1707       real(kind=8),dimension(0:n_ene) :: energia_short,energia_long
1708       real(kind=8),dimension(3) :: L,vcm,incr
1709       real(kind=8),dimension(3,0:2*nres) :: dc_old0,d_t_old0,d_a_old0 !(3,0:maxres2) maxres2=2*maxres
1710       logical :: PRINT_AMTS_MSG = .false.
1711       integer :: count,rstcount !ilen,
1712 !el      external ilen
1713       character(len=50) :: tytul
1714       integer :: maxcount_scale = 10
1715 !el      common /gucio/ cm
1716 !el      real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres
1717 !el      common /stochcalc/ stochforcvec
1718       integer :: itt,i,j,itsplit,itime
1719       logical :: scale
1720 !el      common /cipiszcze/ itt
1721
1722       real(kind=8) :: epdrift,tt0,epdriftmax
1723       itt = itt_comm
1724
1725       if (.not.allocated(stochforcvec)) allocate(stochforcvec(6*nres))  !(MAXRES6) maxres6=6*maxres
1726
1727       itt=itime
1728       if (ntwe.ne.0) then
1729       if (large.and. mod(itime,ntwe).eq.0) then
1730         write (iout,*) "***************** RESPA itime",itime
1731         write (iout,*) "Cartesian and internal coordinates: step 0"
1732 !        call cartprint
1733         call pdbout(0.0d0,"cipiszcze",iout)
1734         call intout
1735         write (iout,*) "Accelerations from long-range forces"
1736         do i=0,nres
1737           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
1738             (d_a(j,i+nres),j=1,3)
1739         enddo
1740         write (iout,*) "Velocities, step 0"
1741         do i=0,nres
1742           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
1743             (d_t(j,i+nres),j=1,3)
1744         enddo
1745       endif
1746       endif
1747 !
1748 ! Perform the initial RESPA step (increment velocities)
1749 !      write (iout,*) "*********************** RESPA ini"
1750       call RESPA_vel
1751       if (ntwe.ne.0) then
1752       if (mod(itime,ntwe).eq.0 .and. large) then
1753         write (iout,*) "Velocities, end"
1754         do i=0,nres
1755           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
1756             (d_t(j,i+nres),j=1,3)
1757         enddo
1758       endif
1759       endif
1760 ! Compute the short-range forces
1761 #ifdef MPI
1762       tt0 =MPI_Wtime()
1763 #else
1764       tt0 = tcpu()
1765 #endif
1766 ! 7/2/2009 commented out
1767 !      call zerograd
1768 !      call etotal_short(energia_short)
1769 !      call cartgrad
1770 !      call lagrangian
1771 ! 7/2/2009 Copy accelerations due to short-lange forces from previous MD step
1772         do i=0,2*nres
1773           do j=1,3
1774             d_a(j,i)=d_a_short(j,i)
1775           enddo
1776         enddo
1777       if (ntwe.ne.0) then
1778       if (large.and. mod(itime,ntwe).eq.0) then
1779         write (iout,*) "energia_short",energia_short(0)
1780         write (iout,*) "Accelerations from short-range forces"
1781         do i=0,nres
1782           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
1783             (d_a(j,i+nres),j=1,3)
1784         enddo
1785       endif
1786       endif
1787 #ifdef MPI
1788         t_enegrad=t_enegrad+MPI_Wtime()-tt0
1789 #else
1790         t_enegrad=t_enegrad+tcpu()-tt0
1791 #endif
1792       do i=0,2*nres
1793         do j=1,3
1794           dc_old(j,i)=dc(j,i)
1795           d_t_old(j,i)=d_t(j,i)
1796           d_a_old(j,i)=d_a(j,i)
1797         enddo
1798       enddo
1799 ! 6/30/08 A-MTS: attempt at increasing the split number
1800       do i=0,2*nres
1801         do j=1,3
1802           dc_old0(j,i)=dc_old(j,i)
1803           d_t_old0(j,i)=d_t_old(j,i)
1804           d_a_old0(j,i)=d_a_old(j,i)
1805         enddo
1806       enddo
1807       if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2
1808       if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0
1809 !
1810       scale=.true.
1811       d_time0=d_time
1812       do while (scale)
1813
1814       scale=.false.
1815 !      write (iout,*) "itime",itime," ntime_split",ntime_split
1816 ! Split the time step
1817       d_time=d_time0/ntime_split
1818 ! Perform the short-range RESPA steps (velocity Verlet increments of
1819 ! positions and velocities using short-range forces)
1820 !      write (iout,*) "*********************** RESPA split"
1821       do itsplit=1,ntime_split
1822         if (lang.eq.1) then
1823           call sddir_precalc
1824         else if (lang.eq.2 .or. lang.eq.3) then
1825 #ifndef LANG0
1826           call stochastic_force(stochforcvec)
1827 #else
1828           write (iout,*) &
1829             "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
1830 #ifdef MPI
1831           call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
1832 #endif
1833           stop
1834 #endif
1835         endif
1836 ! First step of the velocity Verlet algorithm
1837         if (lang.eq.2) then
1838 #ifndef LANG0
1839           call sd_verlet1
1840 #endif
1841         else if (lang.eq.3) then
1842 #ifndef LANG0
1843           call sd_verlet1_ciccotti
1844 #endif
1845         else if (lang.eq.1) then
1846           call sddir_verlet1
1847         else
1848           call verlet1
1849         endif
1850 ! Build the chain from the newly calculated coordinates
1851         call chainbuild_cart
1852         if (rattle) call rattle1
1853         if (ntwe.ne.0) then
1854         if (large.and. mod(itime,ntwe).eq.0) then
1855           write (iout,*) "***** ITSPLIT",itsplit
1856           write (iout,*) "Cartesian and internal coordinates: step 1"
1857           call pdbout(0.0d0,"cipiszcze",iout)
1858 !          call cartprint
1859           call intout
1860           write (iout,*) "Velocities, step 1"
1861           do i=0,nres
1862             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
1863               (d_t(j,i+nres),j=1,3)
1864           enddo
1865         endif
1866         endif
1867 #ifdef MPI
1868         tt0 = MPI_Wtime()
1869 #else
1870         tt0 = tcpu()
1871 #endif
1872 ! Calculate energy and forces
1873         call zerograd
1874         call etotal_short(energia_short)
1875 ! AL 4/17/17: Exit itime_split loop when energy goes infinite
1876         if (energia_short(0).gt.0.99e20 .or. isnan(energia_short(0)) ) then
1877           if (PRINT_AMTS_MSG) &
1878           write (iout,*) "Infinities/NaNs in energia_short",energia_short(0),"; increasing ntime_split to",ntime_split
1879           ntime_split=ntime_split*2
1880           if (ntime_split.gt.maxtime_split) then
1881 #ifdef MPI
1882           write (iout,*) &
1883      "Cannot rescue the run; aborting job. Retry with a smaller time step"
1884           call flush(iout)
1885           call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
1886 #else
1887           write (iout,*) &
1888      "Cannot rescue the run; terminating. Retry with a smaller time step"
1889 #endif
1890           endif
1891           exit
1892         endif
1893 ! End change
1894         if (large.and. mod(itime,ntwe).eq.0) &
1895           call enerprint(energia_short)
1896 #ifdef TIMING_ENE
1897 #ifdef MPI
1898         t_eshort=t_eshort+MPI_Wtime()-tt0
1899 #else
1900         t_eshort=t_eshort+tcpu()-tt0
1901 #endif
1902 #endif
1903         call cartgrad
1904 ! Get the new accelerations
1905         call lagrangian
1906 ! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array
1907         do i=0,2*nres
1908           do j=1,3
1909             d_a_short(j,i)=d_a(j,i)
1910           enddo
1911         enddo
1912         if (ntwe.ne.0) then
1913         if (large.and. mod(itime,ntwe).eq.0) then
1914           write (iout,*)"energia_short",energia_short(0)
1915           write (iout,*) "Accelerations from short-range forces"
1916           do i=0,nres
1917             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
1918               (d_a(j,i+nres),j=1,3)
1919           enddo
1920         endif
1921         endif
1922 ! 6/30/08 A-MTS
1923 ! Determine maximum acceleration and scale down the timestep if needed
1924         call max_accel
1925         amax=amax/ntime_split**2
1926         call predict_edrift(epdrift)
1927         if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) &
1928          write (iout,*) "amax",amax," damax",damax,&
1929          " epdrift",epdrift," epdriftmax",epdriftmax
1930 ! Exit loop and try with increased split number if the change of
1931 ! acceleration is too big
1932         if (amax.gt.damax .or. epdrift.gt.edriftmax) then
1933           if (ntime_split.lt.maxtime_split) then
1934             scale=.true.
1935             ntime_split=ntime_split*2
1936 ! AL 4/17/17: We should exit the itime_split loop when acceleration change is too big
1937             exit
1938             do i=0,2*nres
1939               do j=1,3
1940                 dc_old(j,i)=dc_old0(j,i)
1941                 d_t_old(j,i)=d_t_old0(j,i)
1942                 d_a_old(j,i)=d_a_old0(j,i)
1943               enddo
1944             enddo
1945             if (PRINT_AMTS_MSG) then
1946             write (iout,*) "acceleration/energy drift too large",amax,&
1947             epdrift," split increased to ",ntime_split," itime",itime,&
1948              " itsplit",itsplit
1949             endif
1950             exit
1951           else
1952             write (iout,*) &
1953             "Uh-hu. Bumpy landscape. Maximum splitting number",&
1954              maxtime_split,&
1955             " already reached!!! Trying to carry on!"
1956           endif
1957         endif
1958 #ifdef MPI
1959         t_enegrad=t_enegrad+MPI_Wtime()-tt0
1960 #else
1961         t_enegrad=t_enegrad+tcpu()-tt0
1962 #endif
1963 ! Second step of the velocity Verlet algorithm
1964         if (lang.eq.2) then
1965 #ifndef LANG0
1966           call sd_verlet2
1967 #endif
1968         else if (lang.eq.3) then
1969 #ifndef LANG0
1970           call sd_verlet2_ciccotti
1971 #endif
1972         else if (lang.eq.1) then
1973           call sddir_verlet2
1974         else
1975           call verlet2
1976         endif
1977         if (rattle) call rattle2
1978 ! Backup the coordinates, velocities, and accelerations
1979         do i=0,2*nres
1980           do j=1,3
1981             dc_old(j,i)=dc(j,i)
1982             d_t_old(j,i)=d_t(j,i)
1983             d_a_old(j,i)=d_a(j,i)
1984           enddo
1985         enddo
1986       enddo
1987
1988       enddo ! while scale
1989
1990 ! Restore the time step
1991       d_time=d_time0
1992 ! Compute long-range forces
1993 #ifdef MPI
1994       tt0 =MPI_Wtime()
1995 #else
1996       tt0 = tcpu()
1997 #endif
1998       call zerograd
1999       call etotal_long(energia_long)
2000       if (energia_long(0).gt.0.99e20 .or. isnan(energia_long(0))) then
2001 #ifdef MPI
2002         write (iout,*) &
2003               "Infinitied/NaNs in energia_long, Aborting MPI job."
2004         call flush(iout)
2005         call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
2006 #else
2007         write (iout,*) "Infinitied/NaNs in energia_long, terminating."
2008         stop
2009 #endif
2010       endif
2011       if (large.and. mod(itime,ntwe).eq.0) &
2012           call enerprint(energia_long)
2013 #ifdef TIMING_ENE
2014 #ifdef MPI
2015         t_elong=t_elong+MPI_Wtime()-tt0
2016 #else
2017         t_elong=t_elong+tcpu()-tt0
2018 #endif
2019 #endif
2020         potE=potEcomp(0)-potEcomp(51)
2021       call cartgrad
2022       call lagrangian
2023 #ifdef MPI
2024         t_enegrad=t_enegrad+MPI_Wtime()-tt0
2025 #else
2026         t_enegrad=t_enegrad+tcpu()-tt0
2027 #endif
2028 ! Compute accelerations from long-range forces
2029       if (ntwe.ne.0) then
2030       if (large.and. mod(itime,ntwe).eq.0) then
2031         write (iout,*) "energia_long",energia_long(0)
2032         write (iout,*) "Cartesian and internal coordinates: step 2"
2033 !        call cartprint
2034         call pdbout(0.0d0,"cipiszcze",iout)
2035         call intout
2036         write (iout,*) "Accelerations from long-range forces"
2037         do i=0,nres
2038           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
2039             (d_a(j,i+nres),j=1,3)
2040         enddo
2041         write (iout,*) "Velocities, step 2"
2042         do i=0,nres
2043           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
2044             (d_t(j,i+nres),j=1,3)
2045         enddo
2046       endif
2047       endif
2048 ! Compute the final RESPA step (increment velocities)
2049 !      write (iout,*) "*********************** RESPA fin"
2050       call RESPA_vel
2051 ! Compute the complete potential energy
2052       do i=0,n_ene
2053         potEcomp(i)=energia_short(i)+energia_long(i)
2054       enddo
2055       potE=potEcomp(0)-potEcomp(51)
2056 !      potE=energia_short(0)+energia_long(0)
2057       totT=totT+d_time
2058         totTafm=totT
2059 ! Calculate the kinetic and the total energy and the kinetic temperature
2060       call kinetic(EK)
2061       totE=EK+potE
2062 ! Couple the system to Berendsen bath if needed
2063       if (tbf .and. lang.eq.0) then
2064         call verlet_bath
2065       endif
2066       kinetic_T=2.0d0/(dimen3*Rb)*EK
2067 ! Backup the coordinates, velocities, and accelerations
2068       if (ntwe.ne.0) then
2069       if (mod(itime,ntwe).eq.0 .and. large) then
2070         write (iout,*) "Velocities, end"
2071         do i=0,nres
2072           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
2073             (d_t(j,i+nres),j=1,3)
2074         enddo
2075       endif
2076       endif
2077       return
2078       end subroutine RESPA_step
2079 !-----------------------------------------------------------------------------
2080       subroutine RESPA_vel
2081 !  First and last RESPA step (incrementing velocities using long-range
2082 !  forces).
2083       use energy_data
2084 !      implicit real*8 (a-h,o-z)
2085 !      include 'DIMENSIONS'
2086 !      include 'COMMON.CONTROL'
2087 !      include 'COMMON.VAR'
2088 !      include 'COMMON.MD'
2089 !      include 'COMMON.CHAIN'
2090 !      include 'COMMON.DERIV'
2091 !      include 'COMMON.GEO'
2092 !      include 'COMMON.LOCAL'
2093 !      include 'COMMON.INTERACT'
2094 !      include 'COMMON.IOUNITS'
2095 !      include 'COMMON.NAMES'
2096       integer :: i,j,inres,mnum
2097
2098       do j=1,3
2099         d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time
2100       enddo
2101       do i=nnt,nct-1
2102         do j=1,3
2103           d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time
2104         enddo
2105       enddo
2106       do i=nnt,nct
2107          mnum=molnum(i)
2108 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2109          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2110           .and.(mnum.lt.4)) then
2111           inres=i+nres
2112           do j=1,3
2113             d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time
2114           enddo
2115         endif
2116       enddo
2117       return
2118       end subroutine RESPA_vel
2119 !-----------------------------------------------------------------------------
2120       subroutine verlet1
2121 ! Applying velocity Verlet algorithm - step 1 to coordinates
2122       use energy_data
2123 !      implicit real*8 (a-h,o-z)
2124 !      include 'DIMENSIONS'
2125 !      include 'COMMON.CONTROL'
2126 !      include 'COMMON.VAR'
2127 !      include 'COMMON.MD'
2128 !      include 'COMMON.CHAIN'
2129 !      include 'COMMON.DERIV'
2130 !      include 'COMMON.GEO'
2131 !      include 'COMMON.LOCAL'
2132 !      include 'COMMON.INTERACT'
2133 !      include 'COMMON.IOUNITS'
2134 !      include 'COMMON.NAMES'
2135       real(kind=8) :: adt,adt2
2136       integer :: i,j,inres,mnum
2137
2138 #ifdef DEBUG
2139       write (iout,*) "VELVERLET1 START: DC"
2140       do i=0,nres
2141         write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),&
2142          (dc(j,i+nres),j=1,3)
2143       enddo
2144 #endif
2145       do j=1,3
2146         adt=d_a_old(j,0)*d_time
2147         adt2=0.5d0*adt
2148         dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time
2149         d_t_new(j,0)=d_t_old(j,0)+adt2
2150         d_t(j,0)=d_t_old(j,0)+adt
2151       enddo
2152       do i=nnt,nct-1
2153         do j=1,3
2154           adt=d_a_old(j,i)*d_time
2155           adt2=0.5d0*adt
2156           dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time
2157           d_t_new(j,i)=d_t_old(j,i)+adt2
2158           d_t(j,i)=d_t_old(j,i)+adt
2159         enddo
2160       enddo
2161       do i=nnt,nct
2162          mnum=molnum(i)
2163 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2164          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2165           .and.(mnum.lt.4)) then
2166           inres=i+nres
2167           do j=1,3
2168             adt=d_a_old(j,inres)*d_time
2169             adt2=0.5d0*adt
2170             dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time
2171             d_t_new(j,inres)=d_t_old(j,inres)+adt2
2172             d_t(j,inres)=d_t_old(j,inres)+adt
2173           enddo
2174         endif
2175       enddo
2176 #ifdef DEBUG
2177       write (iout,*) "VELVERLET1 END: DC"
2178       do i=0,nres
2179         write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),&
2180          (dc(j,i+nres),j=1,3)
2181       enddo
2182 #endif
2183       return
2184       end subroutine verlet1
2185 !-----------------------------------------------------------------------------
2186       subroutine verlet2
2187 !  Step 2 of the velocity Verlet algorithm: update velocities
2188       use energy_data
2189 !      implicit real*8 (a-h,o-z)
2190 !      include 'DIMENSIONS'
2191 !      include 'COMMON.CONTROL'
2192 !      include 'COMMON.VAR'
2193 !      include 'COMMON.MD'
2194 !      include 'COMMON.CHAIN'
2195 !      include 'COMMON.DERIV'
2196 !      include 'COMMON.GEO'
2197 !      include 'COMMON.LOCAL'
2198 !      include 'COMMON.INTERACT'
2199 !      include 'COMMON.IOUNITS'
2200 !      include 'COMMON.NAMES'
2201       integer :: i,j,inres,mnum
2202
2203       do j=1,3
2204         d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time
2205       enddo
2206       do i=nnt,nct-1
2207         do j=1,3
2208           d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time
2209         enddo
2210       enddo
2211       do i=nnt,nct
2212          mnum=molnum(i)
2213 !        iti=iabs(itype(i,mnum))
2214 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2215          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2216           .and.(mnum.lt.4)) then
2217           inres=i+nres
2218           do j=1,3
2219             d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time
2220           enddo
2221         endif
2222       enddo
2223       return
2224       end subroutine verlet2
2225 !-----------------------------------------------------------------------------
2226       subroutine sddir_precalc
2227 ! Applying velocity Verlet algorithm - step 1 to coordinates
2228 !      implicit real*8 (a-h,o-z)
2229 !      include 'DIMENSIONS'
2230       use MPI_data
2231       use control_data
2232 #ifdef MPI
2233       include 'mpif.h'
2234 #endif
2235 !      include 'COMMON.CONTROL'
2236 !      include 'COMMON.VAR'
2237 !      include 'COMMON.MD'
2238 !#ifndef LANG0
2239 !      include 'COMMON.LANGEVIN'
2240 !#else
2241 !      include 'COMMON.LANGEVIN.lang0'
2242 !#endif
2243 !      include 'COMMON.CHAIN'
2244 !      include 'COMMON.DERIV'
2245 !      include 'COMMON.GEO'
2246 !      include 'COMMON.LOCAL'
2247 !      include 'COMMON.INTERACT'
2248 !      include 'COMMON.IOUNITS'
2249 !      include 'COMMON.NAMES'
2250 !      include 'COMMON.TIME1'
2251 !el      real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres
2252 !el      common /stochcalc/ stochforcvec
2253       real(kind=8) :: time00
2254       integer :: i
2255 !
2256 ! Compute friction and stochastic forces
2257 !
2258 #ifdef MPI
2259       time00=MPI_Wtime()
2260       if (large) print *,"before friction_force"
2261       call friction_force
2262       if (large) print *,"after friction_force"
2263       time_fric=time_fric+MPI_Wtime()-time00
2264       time00=MPI_Wtime()
2265       call stochastic_force(stochforcvec)
2266       time_stoch=time_stoch+MPI_Wtime()-time00
2267 #endif
2268 !
2269 ! Compute the acceleration due to friction forces (d_af_work) and stochastic
2270 ! forces (d_as_work)
2271 !
2272 !      call ginv_mult(fric_work, d_af_work)
2273 !      call ginv_mult(stochforcvec, d_as_work)
2274 #ifdef FIVEDIAG
2275       call fivediaginv_mult(dimen,fric_work, d_af_work)
2276       call fivediaginv_mult(dimen,stochforcvec, d_as_work)
2277       if (large) then
2278       write(iout,*),"dimen",dimen
2279       do i=1,dimen
2280        write(iout,*) "fricwork",fric_work(i), d_af_work(i)
2281        write(iout,*) "stochforcevec", stochforcvec(i), d_as_work(i)
2282       enddo
2283       endif
2284 #else
2285       call ginv_mult(fric_work, d_af_work)
2286       call ginv_mult(stochforcvec, d_as_work)
2287 #endif
2288
2289       return
2290       end subroutine sddir_precalc
2291 !-----------------------------------------------------------------------------
2292       subroutine sddir_verlet1
2293 ! Applying velocity Verlet algorithm - step 1 to velocities
2294 !
2295       use energy_data
2296 !      implicit real*8 (a-h,o-z)
2297 !      include 'DIMENSIONS'
2298 !      include 'COMMON.CONTROL'
2299 !      include 'COMMON.VAR'
2300 !      include 'COMMON.MD'
2301 !#ifndef LANG0
2302 !      include 'COMMON.LANGEVIN'
2303 !#else
2304 !      include 'COMMON.LANGEVIN.lang0'
2305 !#endif
2306 !      include 'COMMON.CHAIN'
2307 !      include 'COMMON.DERIV'
2308 !      include 'COMMON.GEO'
2309 !      include 'COMMON.LOCAL'
2310 !      include 'COMMON.INTERACT'
2311 !      include 'COMMON.IOUNITS'
2312 !      include 'COMMON.NAMES'
2313 ! Revised 3/31/05 AL: correlation between random contributions to
2314 ! position and velocity increments included.
2315       real(kind=8) :: sqrt13 = 0.57735026918962576451d0 ! 1/sqrt(3)
2316       real(kind=8) :: adt,adt2
2317       integer :: i,j,ind,inres,mnum
2318 !
2319 ! Add the contribution from BOTH friction and stochastic force to the
2320 ! coordinates, but ONLY the contribution from the friction forces to velocities
2321 !
2322       do j=1,3
2323         adt=(d_a_old(j,0)+d_af_work(j))*d_time
2324         adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time
2325 !        write(iout,*)  i,"adt",adt,"ads",adt2,d_a_old(j,0),d_af_work(j),d_time
2326         dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time
2327         d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt
2328         d_t(j,0)=d_t_old(j,0)+adt
2329       enddo
2330       ind=3
2331       do i=nnt,nct-1
2332         do j=1,3
2333           adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time
2334           adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time
2335 !            write(iout,*)  i,"adt",adt,"ads",adt2,d_a_old(j,i),d_af_work(ind+j)
2336           dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time
2337           d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt
2338           d_t(j,i)=d_t_old(j,i)+adt
2339         enddo
2340         ind=ind+3
2341       enddo
2342       do i=nnt,nct
2343          mnum=molnum(i)
2344 !        iti=iabs(itype(i,mnum))
2345 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2346          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2347           .and.(mnum.lt.4)) then
2348           inres=i+nres
2349           do j=1,3
2350             adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time
2351             adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time
2352 !            write(iout,*)  i,"adt",adt,"ads",adt2,d_a_old(j,inres),d_af_work(ind+j)
2353             dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time
2354             d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt
2355             d_t(j,inres)=d_t_old(j,inres)+adt
2356           enddo
2357           ind=ind+3
2358         endif
2359       enddo
2360
2361       return
2362       end subroutine sddir_verlet1
2363 !-----------------------------------------------------------------------------
2364       subroutine sddir_verlet2
2365 !  Calculating the adjusted velocities for accelerations
2366 !
2367       use energy_data
2368 !      implicit real*8 (a-h,o-z)
2369 !      include 'DIMENSIONS'
2370 !      include 'COMMON.CONTROL'
2371 !      include 'COMMON.VAR'
2372 !      include 'COMMON.MD'
2373 !#ifndef LANG0
2374 !      include 'COMMON.LANGEVIN'
2375 !#else
2376 !      include 'COMMON.LANGEVIN.lang0'
2377 !#endif
2378 !      include 'COMMON.CHAIN'
2379 !      include 'COMMON.DERIV'
2380 !      include 'COMMON.GEO'
2381 !      include 'COMMON.LOCAL'
2382 !      include 'COMMON.INTERACT'
2383 !      include 'COMMON.IOUNITS'
2384 !      include 'COMMON.NAMES'
2385       real(kind=8),dimension(6*nres) :: stochforcvec,d_as_work1 !(MAXRES6) maxres6=6*maxres
2386       real(kind=8) :: cos60 = 0.5d0, sin60 = 0.86602540378443864676d0
2387       integer :: i,j,ind,inres,mnum
2388 ! Revised 3/31/05 AL: correlation between random contributions to
2389 ! position and velocity increments included.
2390 ! The correlation coefficients are calculated at low-friction limit.
2391 ! Also, friction forces are now not calculated with new velocities.
2392
2393 !      call friction_force
2394       call stochastic_force(stochforcvec)
2395 !
2396 ! Compute the acceleration due to friction forces (d_af_work) and stochastic
2397 ! forces (d_as_work)
2398 !
2399 #ifdef FIVEDIAG
2400       call fivediaginv_mult(6*nres,stochforcvec, d_as_work1)
2401 #else
2402       call ginv_mult(stochforcvec, d_as_work1)
2403 #endif
2404
2405 !
2406 ! Update velocities
2407 !
2408       do j=1,3
2409         d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) &
2410           +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time
2411       enddo
2412       ind=3
2413       do i=nnt,nct-1
2414         do j=1,3
2415           d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) &
2416            +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time
2417         enddo
2418         ind=ind+3
2419       enddo
2420       do i=nnt,nct
2421          mnum=molnum(i)
2422 !        iti=iabs(itype(i,mnum))
2423 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2424          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2425           .and.(mnum.lt.4)) then
2426           inres=i+nres
2427           do j=1,3
2428             d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) &
2429              +d_af_work(ind+j))+sin60*d_as_work(ind+j) &
2430              +cos60*d_as_work1(ind+j))*d_time
2431           enddo
2432           ind=ind+3
2433         endif
2434       enddo
2435       return
2436       end subroutine sddir_verlet2
2437 !-----------------------------------------------------------------------------
2438       subroutine max_accel
2439 !
2440 ! Find the maximum difference in the accelerations of the the sites
2441 ! at the beginning and the end of the time step.
2442 !
2443       use energy_data
2444 !      implicit real*8 (a-h,o-z)
2445 !      include 'DIMENSIONS'
2446 !      include 'COMMON.CONTROL'
2447 !      include 'COMMON.VAR'
2448 !      include 'COMMON.MD'
2449 !      include 'COMMON.CHAIN'
2450 !      include 'COMMON.DERIV'
2451 !      include 'COMMON.GEO'
2452 !      include 'COMMON.LOCAL'
2453 !      include 'COMMON.INTERACT'
2454 !      include 'COMMON.IOUNITS'
2455       real(kind=8),dimension(3) :: aux,accel,accel_old
2456       real(kind=8) :: dacc
2457       integer :: i,j,mnum
2458
2459       do j=1,3
2460 !        aux(j)=d_a(j,0)-d_a_old(j,0)
2461          accel_old(j)=d_a_old(j,0)
2462          accel(j)=d_a(j,0)
2463       enddo
2464       amax=0.0d0
2465       do i=nnt,nct
2466 ! Backbone
2467         if (i.lt.nct) then
2468 ! 7/3/08 changed to asymmetric difference
2469           do j=1,3
2470 !            accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i))
2471             accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i)
2472             accel(j)=accel(j)+0.5d0*d_a(j,i)
2473 !            if (dabs(accel(j)).gt.amax) amax=dabs(accel(j))
2474             if (dabs(accel(j)).gt.dabs(accel_old(j))) then
2475               dacc=dabs(accel(j)-accel_old(j))
2476 !              write (iout,*) i,dacc
2477               if (dacc.gt.amax) amax=dacc
2478             endif
2479           enddo
2480         endif
2481       enddo
2482 ! Side chains
2483       do j=1,3
2484 !        accel(j)=aux(j)
2485         accel_old(j)=d_a_old(j,0)
2486         accel(j)=d_a(j,0)
2487       enddo
2488       if (nnt.eq.2) then
2489         do j=1,3
2490           accel_old(j)=accel_old(j)+d_a_old(j,1)
2491           accel(j)=accel(j)+d_a(j,1)
2492         enddo
2493       endif
2494       do i=nnt,nct
2495          mnum=molnum(i)
2496 !        iti=iabs(itype(i,mnum))
2497 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2498          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2499           .and.(mnum.lt.4)) then
2500           do j=1,3
2501 !            accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres)
2502             accel_old(j)=accel_old(j)+d_a_old(j,i+nres)
2503             accel(j)=accel(j)+d_a(j,i+nres)
2504           enddo
2505         endif
2506         do j=1,3
2507 !          if (dabs(accel(j)).gt.amax) amax=dabs(accel(j))
2508           if (dabs(accel(j)).gt.dabs(accel_old(j))) then
2509             dacc=dabs(accel(j)-accel_old(j))
2510 !            write (iout,*) "side-chain",i,dacc
2511             if (dacc.gt.amax) amax=dacc
2512           endif
2513         enddo
2514         do j=1,3
2515           accel_old(j)=accel_old(j)+d_a_old(j,i)
2516           accel(j)=accel(j)+d_a(j,i)
2517 !          aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i)
2518         enddo
2519       enddo
2520       return
2521       end subroutine max_accel
2522 !-----------------------------------------------------------------------------
2523       subroutine predict_edrift(epdrift)
2524 !
2525 ! Predict the drift of the potential energy
2526 !
2527      use energy_data
2528      use control_data, only: lmuca
2529 !      implicit real*8 (a-h,o-z)
2530 !      include 'DIMENSIONS'
2531 !      include 'COMMON.CONTROL'
2532 !      include 'COMMON.VAR'
2533 !      include 'COMMON.MD'
2534 !      include 'COMMON.CHAIN'
2535 !      include 'COMMON.DERIV'
2536 !      include 'COMMON.GEO'
2537 !      include 'COMMON.LOCAL'
2538 !      include 'COMMON.INTERACT'
2539 !      include 'COMMON.IOUNITS'
2540 !      include 'COMMON.MUCA'
2541       real(kind=8) :: epdrift,epdriftij
2542       integer :: i,j
2543 ! Drift of the potential energy
2544       epdrift=0.0d0
2545       do i=nnt,nct
2546 ! Backbone
2547         if (i.lt.nct) then
2548           do j=1,3
2549             epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i))
2550             if (lmuca) epdriftij=epdriftij*factor
2551 !            write (iout,*) "back",i,j,epdriftij
2552             if (epdriftij.gt.epdrift) epdrift=epdriftij
2553           enddo
2554         endif
2555 ! Side chains
2556         if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1.and.&
2557         molnum(i).lt.4) then
2558           do j=1,3
2559             epdriftij= &
2560              dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i))
2561             if (lmuca) epdriftij=epdriftij*factor
2562 !            write (iout,*) "side",i,j,epdriftij
2563             if (epdriftij.gt.epdrift) epdrift=epdriftij
2564           enddo
2565         endif
2566       enddo
2567       epdrift=0.5d0*epdrift*d_time*d_time
2568 !      write (iout,*) "epdrift",epdrift
2569       return
2570       end subroutine predict_edrift
2571 !-----------------------------------------------------------------------------
2572       subroutine verlet_bath
2573 !
2574 !  Coupling to the thermostat by using the Berendsen algorithm
2575 !
2576       use energy_data
2577 !      implicit real*8 (a-h,o-z)
2578 !      include 'DIMENSIONS'
2579 !      include 'COMMON.CONTROL'
2580 !      include 'COMMON.VAR'
2581 !      include 'COMMON.MD'
2582 !      include 'COMMON.CHAIN'
2583 !      include 'COMMON.DERIV'
2584 !      include 'COMMON.GEO'
2585 !      include 'COMMON.LOCAL'
2586 !      include 'COMMON.INTERACT'
2587 !      include 'COMMON.IOUNITS'
2588 !      include 'COMMON.NAMES'
2589       real(kind=8) :: T_half,fact
2590       integer :: i,j,inres,mnum
2591 !
2592       T_half=2.0d0/(dimen3*Rb)*EK
2593       fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0))
2594 !      write(iout,*) "T_half", T_half
2595 !      write(iout,*) "EK", EK
2596 !      write(iout,*) "fact", fact
2597       do j=1,3
2598         d_t(j,0)=fact*d_t(j,0)
2599       enddo
2600       do i=nnt,nct-1
2601         do j=1,3
2602           d_t(j,i)=fact*d_t(j,i)
2603         enddo
2604       enddo
2605       do i=nnt,nct
2606          mnum=molnum(i)
2607 !        iti=iabs(itype(i,mnum))
2608 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
2609          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
2610           .and.(mnum.lt.4)) then
2611           inres=i+nres
2612           do j=1,3
2613             d_t(j,inres)=fact*d_t(j,inres)
2614           enddo
2615         endif
2616       enddo
2617       return
2618       end subroutine verlet_bath
2619 !-----------------------------------------------------------------------------
2620       subroutine init_MD
2621 !  Set up the initial conditions of a MD simulation
2622       use comm_gucio
2623       use energy_data
2624       use control, only:tcpu
2625 !el      use io_basic, only:ilen
2626       use control_data
2627       use MPI_data
2628       use minimm, only:minim_dc,minimize,sc_move
2629       use io_config, only:readrst
2630       use io, only:statout
2631       use random, only: iran_num
2632 !      implicit real*8 (a-h,o-z)
2633 !      include 'DIMENSIONS'
2634 #ifdef MP
2635       include 'mpif.h'
2636       character(len=16) :: form
2637       integer :: IERROR,ERRCODE
2638 #endif
2639       integer :: iranmin,itrial,itmp,n_model_try,k, &
2640                  i_model
2641       integer, dimension(:),allocatable :: list_model_try
2642       integer, dimension(0:nodes-1) :: i_start_models
2643 !      include 'COMMON.SETUP'
2644 !      include 'COMMON.CONTROL'
2645 !      include 'COMMON.VAR'
2646 !      include 'COMMON.MD'
2647 !#ifndef LANG0
2648 !      include 'COMMON.LANGEVIN'
2649 !#else
2650 !      include 'COMMON.LANGEVIN.lang0'
2651 !#endif
2652 !      include 'COMMON.CHAIN'
2653 !      include 'COMMON.DERIV'
2654 !      include 'COMMON.GEO'
2655 !      include 'COMMON.LOCAL'
2656 !      include 'COMMON.INTERACT'
2657 !      include 'COMMON.IOUNITS'
2658 !      include 'COMMON.NAMES'
2659 !      include 'COMMON.REMD'
2660       real(kind=8),dimension(0:n_ene) :: energia_long,energia_short,energia
2661       real(kind=8),dimension(3) :: vcm,incr,L
2662       real(kind=8) :: xv,sigv,lowb,highb
2663       real(kind=8),dimension(6*nres) :: varia   !(maxvar) (maxvar=6*maxres)
2664       character(len=256) :: qstr
2665 !el      integer ilen
2666 !el      external ilen
2667       character(len=50) :: tytul
2668       logical :: file_exist
2669 !el      common /gucio/ cm
2670       integer :: i,j,ipos,iq,iw,nft_sc,iretcode,ierr,mnum,itime
2671 #ifndef LBFGS
2672       integer :: nfun
2673 #endif
2674       real(kind=8) :: etot,tt0
2675       logical :: fail
2676
2677       d_time0=d_time
2678 !      write(iout,*) "d_time", d_time
2679 ! Compute the standard deviations of stochastic forces for Langevin dynamics
2680 ! if the friction coefficients do not depend on surface area
2681       if (lang.gt.0 .and. .not.surfarea) then
2682         do i=nnt,nct-1
2683           mnum=molnum(i)
2684           stdforcp(i)=stdfp(mnum)*dsqrt(gamp(mnum))
2685         enddo
2686         do i=nnt,nct
2687           mnum=molnum(i)
2688           stdforcsc(i)=stdfsc(iabs(itype(i,mnum)),mnum) &
2689                       *dsqrt(gamsc(iabs(itype(i,mnum)),mnum))
2690         enddo
2691       endif
2692
2693 ! Open the pdb file for snapshotshots
2694 #ifdef MPI
2695       if(mdpdb) then
2696         if (ilen(tmpdir).gt.0) &
2697           call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// &
2698             liczba(:ilen(liczba))//".pdb")
2699         open(ipdb,&
2700         file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) &
2701         //".pdb")
2702       else
2703 #ifdef NOXDR
2704         if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) &
2705           call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// &
2706             liczba(:ilen(liczba))//".x")
2707         cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) &
2708         //".x"
2709 #else
2710         if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) &
2711           call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// &
2712             liczba(:ilen(liczba))//".cx")
2713         cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) &
2714         //".cx"
2715 #endif
2716       endif
2717 #else
2718       if(mdpdb) then
2719          if (ilen(tmpdir).gt.0) &
2720            call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb")
2721          open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb")
2722       else
2723          if (ilen(tmpdir).gt.0) &
2724            call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx")
2725          cartname=prefix(:ilen(prefix))//"_MD.cx"
2726       endif
2727 #endif
2728       if (usampl) then
2729         write (qstr,'(256(1h ))')
2730         ipos=1
2731         do i=1,nfrag
2732           iq = qinfrag(i,iset)*10
2733           iw = wfrag(i,iset)/100
2734           if (iw.gt.0) then
2735             if(me.eq.king.or..not.out1file) &
2736              write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw
2737             write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw
2738             ipos=ipos+7
2739           endif
2740         enddo
2741         do i=1,npair
2742           iq = qinpair(i,iset)*10
2743           iw = wpair(i,iset)/100
2744           if (iw.gt.0) then
2745             if(me.eq.king.or..not.out1file) &
2746              write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw
2747             write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw
2748             ipos=ipos+7
2749           endif
2750         enddo
2751 !        pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb'
2752 #ifdef NOXDR
2753 !        cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x'
2754 #else
2755 !        cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx'
2756 #endif
2757 !        statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat'
2758       endif
2759       icg=1
2760       if (rest) then
2761        if (restart1file) then
2762          if (me.eq.king) &
2763            inquire(file=mremd_rst_name,exist=file_exist)
2764            write (*,*) me," Before broadcast: file_exist",file_exist
2765 #ifdef MPI !el
2766          call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,&
2767                 IERR)
2768 #endif !el
2769          write (*,*) me," After broadcast: file_exist",file_exist
2770 !        inquire(file=mremd_rst_name,exist=file_exist)
2771         if(me.eq.king.or..not.out1file) &
2772          write(iout,*) "Initial state read by master and distributed"
2773        else
2774          if (ilen(tmpdir).gt.0) &
2775            call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' &
2776             //liczba(:ilen(liczba))//'.rst')
2777         inquire(file=rest2name,exist=file_exist)
2778        endif
2779        if(file_exist) then
2780          if(.not.restart1file) then
2781            if(me.eq.king.or..not.out1file) &
2782             write(iout,*) "Initial state will be read from file ",&
2783             rest2name(:ilen(rest2name))
2784            call readrst
2785          endif
2786          call rescale_weights(t_bath)
2787        else
2788         if(me.eq.king.or..not.out1file)then
2789          if (restart1file) then
2790           write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)),&
2791              " does not exist"
2792          else
2793           write(iout,*) "File ",rest2name(:ilen(rest2name)),&
2794              " does not exist"
2795          endif
2796          write(iout,*) "Initial velocities randomly generated"
2797         endif
2798         call random_vel
2799         totT=0.0d0
2800         totTafm=totT
2801        endif
2802       else
2803 ! Generate initial velocities
2804         if(me.eq.king.or..not.out1file) &
2805          write(iout,*) "Initial velocities randomly generated"
2806         call random_vel
2807         totT=0.0d0
2808         totTafm=totT
2809       endif
2810 !      rest2name = prefix(:ilen(prefix))//'.rst'
2811       if(me.eq.king.or..not.out1file)then
2812        write (iout,*) "Initial velocities"
2813        do i=0,nres
2814          write (iout,'(i6,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
2815          (d_t(j,i+nres),j=1,3)
2816        enddo
2817 !  Zeroing the total angular momentum of the system
2818        write(iout,*) "Calling the zero-angular momentum subroutine"
2819       endif
2820       call inertia_tensor
2821 !  Getting the potential energy and forces and velocities and accelerations
2822       call vcm_vel(vcm)
2823 !      write (iout,*) "velocity of the center of the mass:"
2824 !      write (iout,*) (vcm(j),j=1,3)
2825       do j=1,3
2826         d_t(j,0)=d_t(j,0)-vcm(j)
2827       enddo
2828 ! Removing the velocity of the center of mass
2829       call vcm_vel(vcm)
2830       if(me.eq.king.or..not.out1file)then
2831        write (iout,*) "vcm right after adjustment:"
2832        write (iout,*) (vcm(j),j=1,3)
2833       endif
2834
2835
2836
2837 !         call chainbuild
2838
2839       if ((.not.rest).or.(forceminim)) then
2840          if (forceminim) call chainbuild_cart
2841   122   continue
2842          if(iranconf.ne.0 .or.indpdb.gt.0.and..not.unres_pdb .or.preminim) then
2843           if (overlapsc) then
2844            print *, 'Calling OVERLAP_SC'
2845            call overlap_sc(fail)
2846            print *,'after OVERLAP'
2847           endif
2848           if (searchsc) then
2849            print *,'call SC_MOVE'
2850            call sc_move(2,nres-1,10,1d10,nft_sc,etot)
2851            print *,'SC_move',nft_sc,etot
2852            if(me.eq.king.or..not.out1file) &
2853             write(iout,*) 'SC_move',nft_sc,etot
2854           endif
2855
2856           if(dccart)then
2857            print *, 'Calling MINIM_DC'
2858            call minim_dc(etot,iretcode,nfun)
2859           else
2860            call geom_to_var(nvar,varia)
2861            print *,'Calling MINIMIZE.'
2862            call minimize(etot,varia,iretcode,nfun)
2863            call var_to_geom(nvar,varia)
2864           endif
2865             write(iout,*) "just before minimin"
2866           call cartprint
2867           if(me.eq.king.or..not.out1file) &
2868              write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun
2869          endif
2870           write(iout,*) "just after minimin"
2871           call cartprint
2872          if(iranconf.ne.0) then
2873 !c 8/22/17 AL Loop to produce a low-energy random conformation
2874           DO iranmin=1,40
2875           if (overlapsc) then
2876            if(me.eq.king.or..not.out1file) &
2877              write (iout,*) 'Calling OVERLAP_SC'
2878            call overlap_sc(fail)
2879           endif !endif overlap
2880
2881           if (searchsc) then
2882            call sc_move(2,nres-1,10,1d10,nft_sc,etot)
2883            print *,'SC_move',nft_sc,etot
2884            if(me.eq.king.or..not.out1file) &
2885            write(iout,*) 'SC_move',nft_sc,etot
2886           endif
2887
2888           if(dccart)then
2889            print *, 'Calling MINIM_DC'
2890            call minim_dc(etot,iretcode,nfun)
2891            call int_from_cart1(.false.)
2892           else
2893            call geom_to_var(nvar,varia)
2894            print *,'Calling MINIMIZE.'
2895            call minimize(etot,varia,iretcode,nfun)
2896            call var_to_geom(nvar,varia)
2897           endif
2898           if(me.eq.king.or..not.out1file) &
2899             write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun
2900             write(iout,*) "just after minimin"
2901           call cartprint
2902           if (isnan(etot) .or. etot.gt.4.0d6) then
2903             write (iout,*) "Energy too large",etot, &
2904              " trying another random conformation"
2905             do itrial=1,100
2906               itmp=1
2907               call gen_rand_conf(itmp,*30)
2908               goto 40
2909    30         write (iout,*) 'Failed to generate random conformation', &
2910                ', itrial=',itrial
2911               write (*,*) 'Processor:',me, &
2912                ' Failed to generate random conformation',&
2913                ' itrial=',itrial
2914               call intout
2915 #ifdef AIX
2916               call flush_(iout)
2917 #else
2918               call flush(iout)
2919 #endif
2920             enddo
2921             write (iout,'(a,i3,a)') 'Processor:',me, &
2922              ' error in generating random conformation.'
2923             write (*,'(a,i3,a)') 'Processor:',me, &
2924              ' error in generating random conformation.'
2925             call flush(iout)
2926 #ifdef MPI
2927 !            call MPI_Abort(mpi_comm_world,error_msg,ierrcode)
2928             call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
2929 #else
2930             stop
2931 #endif
2932    40       continue
2933           else
2934             goto 44
2935           endif
2936           ENDDO
2937
2938           write (iout,'(a,i3,a)') 'Processor:',me, &
2939              ' failed to generate a low-energy random conformation.'
2940             write (*,'(a,i3,a,f10.3)') 'Processor:',me, &
2941              ' failed to generate a low-energy random conformation.',etot
2942             call flush(iout)
2943             call intout
2944 #ifdef MPI
2945 !            call MPI_Abort(mpi_comm_world,error_msg,ierrcode)
2946         call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
2947 #else
2948             stop
2949 #endif
2950    44     continue
2951         else if (preminim) then
2952           if (start_from_model) then
2953             n_model_try=0
2954             fail=.true.
2955             list_model_try=0
2956             do while (fail .and. n_model_try.lt.nmodel_start)
2957               write (iout,*) "n_model_try",n_model_try
2958               do
2959                 i_model=iran_num(1,nmodel_start)
2960                 do k=1,n_model_try
2961                   if (i_model.eq.list_model_try(k)) exit
2962                 enddo
2963                 if (k.gt.n_model_try) exit
2964               enddo
2965               n_model_try=n_model_try+1
2966               list_model_try(n_model_try)=i_model
2967               if (me.eq.king .or. .not. out1file) &
2968               write (iout,*) 'Trying to start from model ',&
2969               pdbfiles_chomo(i_model)(:ilen(pdbfiles_chomo(i_model)))
2970               do i=1,2*nres
2971                 do j=1,3
2972                   c(j,i)=chomo(j,i,i_model)
2973                 enddo
2974               enddo
2975               call int_from_cart(.true.,.false.)
2976               call sc_loc_geom(.false.)
2977               dc(:,0)=c(:,1)
2978               do i=1,nres-1
2979                 do j=1,3
2980                   dc(j,i)=c(j,i+1)-c(j,i)
2981                   dc_norm(j,i)=dc(j,i)*vbld_inv(i+1)
2982                 enddo
2983               enddo
2984               do i=2,nres-1
2985                 do j=1,3
2986                   dc(j,i+nres)=c(j,i+nres)-c(j,i)
2987                   dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres)
2988                 enddo
2989               enddo
2990               if (me.eq.king.or..not.out1file) then
2991               write (iout,*) "Energies before removing overlaps"
2992               call etotal(energia(0))
2993               call enerprint(energia(0))
2994               endif
2995 ! Remove SC overlaps if requested
2996               if (overlapsc) then
2997                 write (iout,*) 'Calling OVERLAP_SC'
2998                 call overlap_sc(fail)
2999                 if (fail) then
3000                   write (iout,*)&
3001                  "Failed to remove overlap from model",i_model
3002                   cycle
3003                 endif
3004               endif
3005               if (me.eq.king.or..not.out1file) then
3006               write (iout,*) "Energies after removing overlaps"
3007               call etotal(energia(0))
3008               call enerprint(energia(0))
3009               endif
3010 #ifdef SEARCHSC
3011 ! Search for better SC rotamers if requested
3012               if (searchsc) then
3013                 call sc_move(2,nres-1,10,1d10,nft_sc,etot)
3014                 print *,'SC_move',nft_sc,etot
3015                 if (me.eq.king.or..not.out1file)&
3016                  write(iout,*) 'SC_move',nft_sc,etot
3017               endif
3018               call etotal(energia(0))
3019 #endif
3020             enddo
3021             call MPI_Gather(i_model,1,MPI_INTEGER,i_start_models(0),&
3022              1,MPI_INTEGER,king,CG_COMM,IERROR)
3023             if (n_model_try.gt.nmodel_start .and.&
3024               (me.eq.king .or. out1file)) then
3025               write (iout,*)&
3026          "All models have irreparable overlaps. Trying randoms starts."
3027               iranconf=1
3028               i_model=nmodel_start+1
3029               goto 122
3030             endif
3031           else
3032 ! Remove SC overlaps if requested
3033               if (overlapsc) then
3034                 write (iout,*) 'Calling OVERLAP_SC'
3035                 call overlap_sc(fail)
3036                 if (fail) then
3037                   write (iout,*)&
3038                  "Failed to remove overlap"
3039                 endif
3040               endif
3041               if (me.eq.king.or..not.out1file) then
3042               write (iout,*) "Energies after removing overlaps"
3043               call etotal(energia(0))
3044               call enerprint(energia(0))
3045               endif
3046           endif
3047 ! 8/22/17 AL Minimize initial structure
3048           if (dccart) then
3049             if (me.eq.king.or..not.out1file) write(iout,*)&
3050              'Minimizing initial PDB structure: Calling MINIM_DC'
3051             call minim_dc(etot,iretcode,nfun)
3052 #ifdef LBFGS
3053             if (me.eq.king.or..not.out1file)&
3054             write(iout,*) 'LBFGS return code is ',statusbf,' eval ',nfun
3055 #endif
3056           else
3057             call geom_to_var(nvar,varia)
3058             if(me.eq.king.or..not.out1file) write (iout,*)&
3059              'Minimizing initial PDB structure: Calling MINIMIZE.'
3060             call minimize(etot,varia,iretcode,nfun)
3061             call var_to_geom(nvar,varia)
3062 #ifdef LBFGS
3063             if (me.eq.king.or..not.out1file)&
3064             write(iout,*) 'LBFGS return code is ',statusbf,' eval ',nfun
3065             if(me.eq.king.or..not.out1file)&
3066             write(iout,*) 'LBFGS return code is ',statusbf,' eval ',nfun
3067 #else
3068             if (me.eq.king.or..not.out1file)&
3069             write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun
3070             if(me.eq.king.or..not.out1file)&
3071             write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun
3072 #endif
3073           endif
3074         endif
3075         if (nmodel_start.gt.0 .and. me.eq.king) then
3076           write (iout,'(a)') "Task  Starting model"
3077           do i=0,nodes-1
3078             if (i_start_models(i).gt.nmodel_start) then
3079               write (iout,'(i4,2x,a)') i,"RANDOM STRUCTURE"
3080             else
3081               write(iout,'(i4,2x,a)')i,pdbfiles_chomo(i_start_models(i)) &
3082                (:ilen(pdbfiles_chomo(i_start_models(i))))
3083             endif
3084           enddo
3085         endif
3086       endif
3087       call chainbuild_cart
3088       call kinetic(EK)
3089             write(iout,*) "just after kinetic"
3090           call cartprint
3091       if (tbf) then
3092         call verlet_bath
3093       endif
3094       kinetic_T=2.0d0/(dimen3*Rb)*EK
3095       if(me.eq.king.or..not.out1file)then
3096             write(iout,*) "just after verlet_bath"
3097        call cartprint
3098        call intout
3099       endif
3100 #ifdef MPI
3101       tt0=MPI_Wtime()
3102 #else
3103       tt0=tcpu()
3104 #endif
3105       call zerograd
3106       write(iout,*) "before ETOTAL"
3107       call etotal(potEcomp)
3108       if (large) call enerprint(potEcomp)
3109 #ifdef TIMING_ENE
3110 #ifdef MPI
3111       t_etotal=t_etotal+MPI_Wtime()-tt0
3112 #else
3113       t_etotal=t_etotal+tcpu()-tt0
3114 #endif
3115 #endif
3116       potE=potEcomp(0)
3117       call cartgrad
3118       write(iout,*) "before lagrangian"
3119       call lagrangian
3120       write(iout,*) "before max_accel"
3121       call max_accel
3122       if (amax*d_time .gt. dvmax) then
3123         d_time=d_time*dvmax/amax
3124         if(me.eq.king.or..not.out1file) write (iout,*) &
3125          "Time step reduced to",d_time,&
3126          " because of too large initial acceleration."
3127       endif
3128       if(me.eq.king.or..not.out1file)then
3129        write(iout,*) "Potential energy and its components"
3130        call enerprint(potEcomp)
3131 !       write(iout,*) (potEcomp(i),i=0,n_ene)
3132       endif
3133       potE=potEcomp(0)-potEcomp(51)
3134       totE=EK+potE
3135       itime=0
3136       itime_mat=itime
3137       if (ntwe.ne.0) call statout(itime)
3138       if(me.eq.king.or..not.out1file) &
3139         write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", &
3140          " Kinetic energy",EK," Potential energy",potE, &
3141          " Total energy",totE," Maximum acceleration ", &
3142          amax
3143       if (large) then
3144         write (iout,*) "Initial coordinates"
3145         do i=1,nres
3146           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3),&
3147           (c(j,i+nres),j=1,3)
3148         enddo
3149         write (iout,*) "Initial dC"
3150         do i=0,nres
3151           write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),&
3152           (dc(j,i+nres),j=1,3)
3153         enddo
3154         write (iout,*) "Initial velocities"
3155         write (iout,"(13x,' backbone ',23x,' side chain')")
3156         do i=0,nres
3157           write (iout,'(i6,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),&
3158           (d_t(j,i+nres),j=1,3)
3159         enddo
3160         write (iout,*) "Initial accelerations"
3161         do i=0,nres
3162 !          write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
3163           write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3),&
3164           (d_a(j,i+nres),j=1,3)
3165         enddo
3166       endif
3167       do i=0,2*nres
3168         do j=1,3
3169           dc_old(j,i)=dc(j,i)
3170           d_t_old(j,i)=d_t(j,i)
3171           d_a_old(j,i)=d_a(j,i)
3172         enddo
3173 !        write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3)
3174       enddo
3175       if (RESPA) then
3176 #ifdef MPI
3177         tt0 =MPI_Wtime()
3178 #else
3179         tt0 = tcpu()
3180 #endif
3181         call zerograd
3182         call etotal_short(energia_short)
3183         if (large) call enerprint(potEcomp)
3184 #ifdef TIMING_ENE
3185 #ifdef MPI
3186         t_eshort=t_eshort+MPI_Wtime()-tt0
3187 #else
3188         t_eshort=t_eshort+tcpu()-tt0
3189 #endif
3190 #endif
3191         call cartgrad
3192         call lagrangian
3193         if(.not.out1file .and. large) then
3194           write (iout,*) "energia_long",energia_long(0),&
3195            " energia_short",energia_short(0),&
3196            " total",energia_long(0)+energia_short(0)
3197           write (iout,*) "Initial fast-force accelerations"
3198           do i=0,nres
3199             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
3200             (d_a(j,i+nres),j=1,3)
3201           enddo
3202         endif
3203 ! 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array
3204         do i=0,2*nres
3205           do j=1,3
3206             d_a_short(j,i)=d_a(j,i)
3207           enddo
3208         enddo
3209 #ifdef MPI
3210         tt0=MPI_Wtime()
3211 #else
3212         tt0=tcpu()
3213 #endif
3214         call zerograd
3215         call etotal_long(energia_long)
3216         if (large) call enerprint(potEcomp)
3217 #ifdef TIMING_ENE
3218 #ifdef MPI
3219         t_elong=t_elong+MPI_Wtime()-tt0
3220 #else
3221         t_elong=t_elong+tcpu()-tt0
3222 #endif
3223 #endif
3224         call cartgrad
3225         call lagrangian
3226         if(.not.out1file .and. large) then
3227           write (iout,*) "energia_long",energia_long(0)
3228           write (iout,*) "Initial slow-force accelerations"
3229           do i=0,nres
3230             write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),&
3231             (d_a(j,i+nres),j=1,3)
3232           enddo
3233         endif
3234 #ifdef MPI
3235         t_enegrad=t_enegrad+MPI_Wtime()-tt0
3236 #else
3237         t_enegrad=t_enegrad+tcpu()-tt0
3238 #endif
3239       endif
3240       return
3241       end subroutine init_MD
3242 !-----------------------------------------------------------------------------
3243       subroutine random_vel
3244
3245 !      implicit real*8 (a-h,o-z)
3246       use energy_data
3247       use random, only:anorm_distr
3248       use MD_data
3249 !      include 'DIMENSIONS'
3250 !      include 'COMMON.CONTROL'
3251 !      include 'COMMON.VAR'
3252 !      include 'COMMON.MD'
3253 !#ifndef LANG0
3254 !      include 'COMMON.LANGEVIN'
3255 !#else
3256 !      include 'COMMON.LANGEVIN.lang0'
3257 !#endif
3258 !      include 'COMMON.CHAIN'
3259 !      include 'COMMON.DERIV'
3260 !      include 'COMMON.GEO'
3261 !      include 'COMMON.LOCAL'
3262 !      include 'COMMON.INTERACT'
3263 !      include 'COMMON.IOUNITS'
3264 !      include 'COMMON.NAMES'
3265 !      include 'COMMON.TIME1'
3266       real(kind=8) :: xv,sigv,lowb,highb  ,Ek1
3267 #ifdef FIVEDIAG
3268       integer ichain,n,innt,inct,ibeg,ierr
3269       real(kind=8) ,allocatable, dimension(:)::  work
3270       integer,allocatable,dimension(:) :: iwork
3271 !      double precision Ghalf(mmaxres2_chain),Geigen(maxres2_chain),&
3272 !      Gvec(maxres2_chain,maxres2_chain)
3273 !      common /przechowalnia/Ghalf,Geigen,Gvec
3274 !#ifdef DEBUG
3275 !      double precision inertia(maxres2_chain,maxres2_chain)
3276 !#endif
3277 #endif
3278 !#define DEBUG
3279 #ifdef FIVEDIAG
3280        real(kind=8) ,allocatable, dimension(:)  :: xsolv,DML,rs
3281        real(kind=8) :: sumx,Ek2,Ek3,aux,masinv
3282 #ifdef DEBUG
3283        real(kind=8) ,allocatable, dimension(:)  :: rsold
3284        real (kind=8),allocatable,dimension(:,:) :: matold,inertia
3285        integer :: iti
3286 #endif
3287 #endif
3288       integer :: i,j,ii,k,mark,imark,mnum,nres2
3289       integer(kind=8) :: ind
3290 ! Generate random velocities from Gaussian distribution of mean 0 and std of KT/m
3291 !#undef DEBUG
3292 ! First generate velocities in the eigenspace of the G matrix
3293 !      write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3
3294 !      call flush(iout)
3295 #ifdef FIVEDIAG
3296        if(.not.allocated(work)) then
3297        allocate(work(48*nres))
3298        allocate(iwork(6*nres))
3299        endif
3300        print *,"IN RANDOM VEL"
3301        nres2=2*nres
3302 !       print *,size(ghalf)
3303 #undef DEBUG
3304 #ifdef DEBUG
3305       write (iout,*) "Random_vel, fivediag"
3306       flush(iout)
3307       allocate(inertia(2*nres,2*nres))
3308 #endif
3309       d_t=0.0d0
3310       Ek2=0.0d0
3311       EK=0.0d0
3312       Ek3=0.0d0
3313 #ifdef DEBUG
3314       write(iout,*), nchain
3315 #endif
3316       do ichain=1,nchain
3317         ind=0
3318 !        if(.not.allocated(ghalf)) print *,"COCO"
3319 !        if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2))
3320 !        ghalf=0.0d0
3321         n=dimen_chain(ichain)
3322         innt=iposd_chain(ichain)
3323         if (molnum(innt).eq.5) go to 137
3324         if(.not.allocated(ghalf)) print *,"COCO"
3325         if(.not.allocated(Ghalf)) allocate(Ghalf(1300*(1300+1)/2))
3326         ghalf=0.0d0
3327         inct=innt+n-1
3328 #ifdef DEBUG
3329         write (iout,*) "Chain",ichain," n",n," start",innt
3330         do i=innt,inct
3331           if (i.lt.inct-1) then
3332            write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i),DU1orig(i),&
3333               DU2orig(i)
3334           else if (i.eq.inct-1) then
3335             write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i),DU1orig(i)
3336           else
3337             write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i)
3338           endif
3339         enddo
3340 #endif
3341
3342         ghalf(ind+1)=dmorig(innt)
3343         ghalf(ind+2)=du1orig(innt)
3344         ghalf(ind+3)=dmorig(innt+1)
3345         ind=ind+3
3346         do i=3,n
3347           ind=ind+i-3
3348           write (iout,*) "i",i," ind",ind," indu2",innt+i-2,&
3349             " indu1",innt+i-1," indm",innt+i
3350           ghalf(ind+1)=du2orig(innt-1+i-2)
3351           ghalf(ind+2)=du1orig(innt-1+i-1)
3352           ghalf(ind+3)=dmorig(innt-1+i)
3353 !c          write (iout,'(3(a,i2,1x))') "DU2",innt-1+i-2,
3354 !c     &       "DU1",innt-1+i-1,"DM ",innt-1+i
3355           ind=ind+3
3356         enddo
3357 #ifdef DEBUG
3358         ind=0
3359         do i=1,n
3360           do j=1,i
3361             ind=ind+1
3362             inertia(i,j)=ghalf(ind)
3363             inertia(j,i)=ghalf(ind)
3364           enddo
3365         enddo
3366 #endif
3367 #ifdef DEBUG
3368         write (iout,*) "Chain ",ichain," ind",ind," dim",n*(n+1)/2
3369         write (iout,*) "Five-diagonal inertia matrix, lower triangle"
3370 !        call matoutr(n,ghalf)
3371 #endif
3372         call gldiag(nres*2,n,n,Ghalf,work,Geigen,Gvec,ierr,iwork)
3373         if (large) then
3374           write (iout,'(//a,i3)')&
3375          "Eigenvectors and eigenvalues of the G matrix chain",ichain
3376           call eigout(n,n,nres*2,nres*2,Gvec,Geigen)
3377         endif
3378 #ifdef DIAGCHECK
3379 !c check diagonalization
3380         do i=1,n
3381           do j=1,n
3382             aux=0.0d0
3383             do k=1,n
3384               do l=1,n
3385                 aux=aux+gvec(k,i)*gvec(l,j)*inertia(k,l)
3386               enddo
3387             enddo
3388             if (i.eq.j) then
3389               write (iout,*) i,j,aux,geigen(i)
3390             else
3391               write (iout,*) i,j,aux
3392             endif
3393           enddo
3394         enddo
3395 #endif
3396 137     continue
3397         write(iout,*) "HERE,",n
3398         xv=0.0d0
3399         ii=0
3400         do i=1,n
3401           do k=1,3
3402             ii=ii+1
3403             if (molnum(innt).eq.5) geigen(i)=1.0/msc(itype(innt+i-1,5),5)
3404
3405             sigv=dsqrt((Rb*t_bath)/geigen(i))
3406             lowb=-5*sigv
3407             highb=5*sigv
3408             d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb)
3409             EK=EK+0.5d0*geigen(i)*d_t_work_new(ii)**2
3410 !            write (iout,*) "i",i," ii",ii," geigen",geigen(i), &
3411 !           " d_t_work_new",d_t_work_new(ii)
3412           enddo
3413         enddo
3414         if (molnum(innt).eq.5) then
3415
3416         do k=1,3
3417           do i=1,n
3418             ind=(i-1)*3+k
3419             d_t_work(ind)=0.0d0
3420             masinv=1.0/msc(itype(innt+i-1,5),5)
3421             d_t_work(ind)=d_t_work(ind)&
3422             +masinv*d_t_work_new((i-1)*3+k)
3423           enddo
3424         enddo
3425
3426         else
3427         do k=1,3
3428           do i=1,n
3429             ind=(i-1)*3+k
3430             d_t_work(ind)=0.0d0
3431             do j=1,n
3432               d_t_work(ind)=d_t_work(ind)&
3433                      +Gvec(i,j)*d_t_work_new((j-1)*3+k)
3434             enddo
3435           enddo
3436         enddo
3437         endif
3438 #ifdef DEBUG
3439         aux=0.0d0
3440         do k=1,3
3441           do i=1,n
3442             do j=1,n
3443             aux=aux+inertia(i,j)*d_t_work(3*(i-1)+k)*d_t_work(3*(j-1)+k)
3444             enddo
3445           enddo
3446         enddo
3447         Ek3=Ek3+aux/2
3448 #endif
3449 !c Transfer to the d_t vector
3450         innt=chain_border(1,ichain)
3451         inct=chain_border(2,ichain)
3452         ind=0
3453 !c        write (iout,*) "ichain",ichain," innt",innt," inct",inct
3454         do i=innt,inct
3455           do j=1,3
3456             ind=ind+1
3457             d_t(j,i)=d_t_work(ind)
3458           enddo
3459           mnum=molnum(i)
3460           if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum).and.mnum.le.2) then
3461             do j=1,3
3462               ind=ind+1
3463               d_t(j,i+nres)=d_t_work(ind)
3464             enddo
3465           endif
3466         enddo
3467       enddo
3468       if (large) then
3469         write (iout,*)
3470         write (iout,*) "Random velocities in the Calpha,SC space"
3471         do i=1,nres
3472           mnum=molnum(i)
3473           write (iout,'(a3,1h(,i5,1h),3f10.5,3x,3f10.5)')&
3474          restyp(itype(i,mnum),mnum),i,(d_t(j,i),j=1,3),(d_t(j,i+nres),j=1,3)
3475         enddo
3476       endif
3477       call kinetic_CASC(Ek1)
3478 !
3479 ! Transform the velocities to virtual-bond space
3480 !
3481 #define WLOS
3482 #ifdef WLOS
3483       if (nnt.eq.1) then
3484         d_t(:,0)=d_t(:,1)
3485       endif
3486       do i=1,nres
3487         mnum=molnum(i)
3488         if (itype(i,1).eq.10 .or. itype(i,mnum).eq.ntyp1_molec(mnum).or.mnum.ge.3) then
3489           do j=1,3
3490             d_t(j,i)=d_t(j,i+1)-d_t(j,i)
3491           enddo
3492         else
3493           do j=1,3
3494             d_t(j,i+nres)=d_t(j,i+nres)-d_t(j,i)
3495             d_t(j,i)=d_t(j,i+1)-d_t(j,i)
3496           enddo
3497         end if
3498       enddo
3499       d_t(:,nres)=0.0d0
3500       d_t(:,nct)=0.0d0
3501       d_t(:,2*nres)=0.0d0
3502       if (nnt.gt.1) then
3503         d_t(:,0)=d_t(:,1)
3504         d_t(:,1)=0.0d0
3505       endif
3506 !c      d_a(:,0)=d_a(:,1)
3507 !c      d_a(:,1)=0.0d0
3508 !c      write (iout,*) "Shifting accelerations"
3509       do ichain=2,nchain
3510 !c        write (iout,*) "ichain",chain_border1(1,ichain)-1,
3511 !c     &     chain_border1(1,ichain)
3512         d_t(:,chain_border1(1,ichain)-1)=d_t(:,chain_border1(1,ichain))
3513         d_t(:,chain_border1(1,ichain))=0.0d0
3514       enddo
3515 !c      write (iout,*) "Adding accelerations"
3516       do ichain=2,nchain
3517 !c        write (iout,*) "chain",ichain,chain_border1(1,ichain)-1,
3518 !c     &   chain_border(2,ichain-1)
3519         d_t(:,chain_border1(1,ichain)-1)=&
3520         d_t(:,chain_border1(1,ichain)-1)+d_t(:,chain_border(2,ichain-1))
3521         d_t(:,chain_border(2,ichain-1))=0.0d0
3522       enddo
3523       do ichain=2,nchain
3524         write (iout,*) "chain",ichain,chain_border1(1,ichain)-1,&
3525         chain_border(2,ichain-1)
3526         d_t(:,chain_border1(1,ichain)-1)=&
3527        d_t(:,chain_border1(1,ichain)-1)+d_t(:,chain_border(2,ichain-1))
3528         d_t(:,chain_border(2,ichain-1))=0.0d0
3529       enddo
3530 #else
3531       ibeg=0
3532 !c      do j=1,3
3533 !c        d_t(j,0)=d_t(j,nnt)
3534 !c      enddo
3535       do ichain=1,nchain
3536       innt=chain_border(1,ichain)
3537       inct=chain_border(2,ichain)
3538 !c      write (iout,*) "ichain",ichain," innt",innt," inct",inct
3539 !c      write (iout,*) "ibeg",ibeg
3540       do j=1,3
3541         d_t(j,ibeg)=d_t(j,innt)
3542       enddo
3543       ibeg=inct+1
3544       do i=innt,inct
3545         mnum=molnum(i)
3546         if (iabs(itype(i,1).eq.10).or.mnum.ge.3) then
3547 !c          write (iout,*) "i",i,(d_t(j,i),j=1,3),(d_t(j,i+1),j=1,3)
3548           do j=1,3
3549             d_t(j,i)=d_t(j,i+1)-d_t(j,i)
3550           enddo
3551         else
3552           do j=1,3
3553             d_t(j,i+nres)=d_t(j,i+nres)-d_t(j,i)
3554             d_t(j,i)=d_t(j,i+1)-d_t(j,i)
3555           enddo
3556         end if
3557       enddo
3558       enddo
3559 #endif
3560       if (large) then
3561         write (iout,*)
3562         write (iout,*)&
3563          "Random velocities in the virtual-bond-vector space"
3564         write (iout,'(3hORG,1h(,i5,1h),3f10.5)') 0,(d_t(j,0),j=1,3)
3565         do i=1,nres
3566           write (iout,'(a3,1h(,i5,1h),3f10.5,3x,3f10.5)')&
3567           restyp(itype(i,mnum),mnum),i,(d_t(j,i),j=1,3),(d_t(j,i+nres),j=1,3)
3568         enddo
3569         write (iout,*)
3570        write (iout,*) "Kinetic energy from inertia matrix eigenvalues",&
3571         Ek
3572         write (iout,*)&
3573         "Kinetic temperatures from inertia matrix eigenvalues",&
3574         2*Ek/(3*dimen*Rb)
3575 #ifdef DEBUG
3576         write (iout,*) "Kinetic energy from inertia matrix",Ek3
3577         write (iout,*) "Kinetic temperatures from inertia",&
3578         2*Ek3/(3*dimen*Rb)
3579 #endif
3580         write (iout,*) "Kinetic energy from velocities in CA-SC space",&
3581          Ek1
3582         write (iout,*)&
3583         "Kinetic temperatures from velovities in CA-SC space",&
3584           2*Ek1/(3*dimen*Rb)
3585         call kinetic(Ek1)
3586         write (iout,*)&
3587         "Kinetic energy from virtual-bond-vector velocities",Ek1
3588         write (iout,*)&
3589         "Kinetic temperature from virtual-bond-vector velocities ",&
3590         2*Ek1/(dimen3*Rb)
3591       endif
3592 #else
3593       xv=0.0d0
3594       ii=0
3595       do i=1,dimen
3596         do k=1,3
3597           ii=ii+1
3598           sigv=dsqrt((Rb*t_bath)/geigen(i))
3599           lowb=-5*sigv
3600           highb=5*sigv
3601           d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb)
3602 #ifdef DEBUG
3603           write (iout,*) "i",i," ii",ii," geigen",geigen(i),&
3604             " d_t_work_new",d_t_work_new(ii)
3605 #endif
3606         enddo
3607       enddo
3608 #ifdef DEBUG
3609 ! diagnostics
3610       Ek1=0.0d0
3611       ii=0
3612       do i=1,dimen
3613         do k=1,3
3614           ii=ii+1
3615           Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2
3616         enddo
3617       enddo
3618       write (iout,*) "Ek from eigenvectors",Ek1
3619       write (iout,*) "Kinetic temperatures",2*Ek1/(3*dimen*Rb)
3620 ! end diagnostics
3621 #endif
3622
3623       do k=0,2
3624         do i=1,dimen
3625           ind=(i-1)*3+k+1
3626           d_t_work(ind)=0.0d0
3627           do j=1,dimen
3628             d_t_work(ind)=d_t_work(ind) &
3629                             +Gvec(i,j)*d_t_work_new((j-1)*3+k+1)
3630           enddo
3631 !          write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind)
3632 !          call flush(iout)
3633         enddo
3634       enddo
3635 ! Transfer to the d_t vector
3636       do j=1,3
3637         d_t(j,0)=d_t_work(j)
3638       enddo
3639       ind=3
3640       do i=nnt,nct-1
3641         do j=1,3
3642           ind=ind+1
3643           d_t(j,i)=d_t_work(ind)
3644         enddo
3645       enddo
3646       do i=nnt,nct
3647          mnum=molnum(i)
3648 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
3649          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
3650           .and.(mnum.lt.4)) then
3651           do j=1,3
3652             ind=ind+1
3653             d_t(j,i+nres)=d_t_work(ind)
3654           enddo
3655         endif
3656       enddo
3657 #endif
3658 !      call kinetic(EK)
3659 !      write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature",&
3660 !        2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1
3661 !      call flush(iout)
3662 !      write(iout,*) "end init MD"
3663 #undef DEBUG
3664       return
3665       end subroutine random_vel
3666 !-----------------------------------------------------------------------------
3667 #ifndef LANG0
3668       subroutine sd_verlet_p_setup
3669 ! Sets up the parameters of stochastic Verlet algorithm
3670 !      implicit real*8 (a-h,o-z)
3671 !      include 'DIMENSIONS'
3672       use control, only: tcpu
3673       use control_data
3674 #ifdef MPI
3675       include 'mpif.h'
3676 #endif
3677 !      include 'COMMON.CONTROL'
3678 !      include 'COMMON.VAR'
3679 !      include 'COMMON.MD'
3680 !#ifndef LANG0
3681 !      include 'COMMON.LANGEVIN'
3682 !#else
3683 !      include 'COMMON.LANGEVIN.lang0'
3684 !#endif
3685 !      include 'COMMON.CHAIN'
3686 !      include 'COMMON.DERIV'
3687 !      include 'COMMON.GEO'
3688 !      include 'COMMON.LOCAL'
3689 !      include 'COMMON.INTERACT'
3690 !      include 'COMMON.IOUNITS'
3691 !      include 'COMMON.NAMES'
3692 !      include 'COMMON.TIME1'
3693       real(kind=8),dimension(6*nres) :: emgdt   !(MAXRES6) maxres6=6*maxres
3694       real(kind=8) :: pterm,vterm,rho,rhoc,vsig
3695       real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,&
3696        prand_vec,vrand_vec1,vrand_vec2  !(MAXRES6) maxres6=6*maxres
3697       logical :: lprn = .false.
3698       real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0
3699       real(kind=8) :: ktm,gdt,egdt,gdt2,gdt3,gdt4,gdt5,gdt6,gdt7,gdt8,&
3700                  gdt9,psig,tt0
3701       integer :: i,maxres2
3702 #ifdef MPI
3703       tt0 = MPI_Wtime()
3704 #else
3705       tt0 = tcpu()
3706 #endif
3707 !
3708 ! AL 8/17/04 Code adapted from tinker
3709 !
3710 ! Get the frictional and random terms for stochastic dynamics in the
3711 ! eigenspace of mass-scaled UNRES friction matrix
3712 !
3713       maxres2=2*nres
3714       do i = 1, dimen
3715             gdt = fricgam(i) * d_time
3716 !
3717 ! Stochastic dynamics reduces to simple MD for zero friction
3718 !
3719             if (gdt .le. zero) then
3720                pfric_vec(i) = 1.0d0
3721                vfric_vec(i) = d_time
3722                afric_vec(i) = 0.5d0 * d_time * d_time
3723                prand_vec(i) = 0.0d0
3724                vrand_vec1(i) = 0.0d0
3725                vrand_vec2(i) = 0.0d0
3726 !
3727 ! Analytical expressions when friction coefficient is large
3728 !
3729             else
3730                if (gdt .ge. gdt_radius) then
3731                   egdt = dexp(-gdt)
3732                   pfric_vec(i) = egdt
3733                   vfric_vec(i) = (1.0d0-egdt) / fricgam(i)
3734                   afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i)
3735                   pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt
3736                   vterm = 1.0d0 - egdt**2
3737                   rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm)
3738 !
3739 ! Use series expansions when friction coefficient is small
3740 !
3741                else
3742                   gdt2 = gdt * gdt
3743                   gdt3 = gdt * gdt2
3744                   gdt4 = gdt2 * gdt2
3745                   gdt5 = gdt2 * gdt3
3746                   gdt6 = gdt3 * gdt3
3747                   gdt7 = gdt3 * gdt4
3748                   gdt8 = gdt4 * gdt4
3749                   gdt9 = gdt4 * gdt5
3750                   afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 &
3751                                 - gdt5/120.0d0 + gdt6/720.0d0 &
3752                                 - gdt7/5040.0d0 + gdt8/40320.0d0 &
3753                                 - gdt9/362880.0d0) / fricgam(i)**2
3754                   vfric_vec(i) = d_time - fricgam(i)*afric_vec(i)
3755                   pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i)
3756                   pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 &
3757                              + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 &
3758                              + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 &
3759                              + 127.0d0*gdt9/90720.0d0
3760                   vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 &
3761                              - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 &
3762                              - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 &
3763                              - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0
3764                   rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 &
3765                              - 17.0d0*gdt2/1280.0d0 &
3766                              + 17.0d0*gdt3/6144.0d0 &
3767                              + 40967.0d0*gdt4/34406400.0d0 &
3768                              - 57203.0d0*gdt5/275251200.0d0 &
3769                              - 1429487.0d0*gdt6/13212057600.0d0)
3770                end if
3771 !
3772 ! Compute the scaling factors of random terms for the nonzero friction case
3773 !
3774                ktm = 0.5d0*d_time/fricgam(i)
3775                psig = dsqrt(ktm*pterm) / fricgam(i)
3776                vsig = dsqrt(ktm*vterm)
3777                rhoc = dsqrt(1.0d0 - rho*rho)
3778                prand_vec(i) = psig
3779                vrand_vec1(i) = vsig * rho
3780                vrand_vec2(i) = vsig * rhoc
3781             end if
3782       end do
3783       if (lprn) then
3784       write (iout,*) &
3785         "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",&
3786         " vrand_vec2"
3787       do i=1,dimen
3788         write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),&
3789             afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i)
3790       enddo
3791       endif
3792 !
3793 ! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables
3794 !
3795 #ifndef   LANG0
3796       call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat)
3797       call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat)
3798       call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat)
3799       call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat)
3800       call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1)
3801       call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2)
3802 #endif
3803 #ifdef MPI
3804       t_sdsetup=t_sdsetup+MPI_Wtime()
3805 #else
3806       t_sdsetup=t_sdsetup+tcpu()-tt0
3807 #endif
3808       return
3809       end subroutine sd_verlet_p_setup
3810 !-----------------------------------------------------------------------------
3811       subroutine eigtransf1(n,ndim,ab,d,c)
3812
3813 !el      implicit none
3814       integer :: n,ndim
3815       real(kind=8) :: ab(ndim,ndim,n),c(ndim,n),d(ndim)
3816       integer :: i,j,k
3817       do i=1,n
3818         do j=1,n
3819           c(i,j)=0.0d0
3820           do k=1,n
3821             c(i,j)=c(i,j)+ab(k,j,i)*d(k)
3822           enddo
3823         enddo
3824       enddo
3825       return
3826       end subroutine eigtransf1
3827 !-----------------------------------------------------------------------------
3828       subroutine eigtransf(n,ndim,a,b,d,c)
3829
3830 !el      implicit none
3831       integer :: n,ndim
3832       real(kind=8) :: a(ndim,n),b(ndim,n),c(ndim,n),d(ndim)
3833       integer :: i,j,k
3834       do i=1,n
3835         do j=1,n
3836           c(i,j)=0.0d0
3837           do k=1,n
3838             c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k)
3839           enddo
3840         enddo
3841       enddo
3842       return
3843       end subroutine eigtransf
3844 !-----------------------------------------------------------------------------
3845       subroutine sd_verlet1
3846
3847 ! Applying stochastic velocity Verlet algorithm - step 1 to velocities
3848       use energy_data
3849 !      implicit real*8 (a-h,o-z)
3850 !      include 'DIMENSIONS'
3851 !      include 'COMMON.CONTROL'
3852 !      include 'COMMON.VAR'
3853 !      include 'COMMON.MD'
3854 !#ifndef LANG0
3855 !      include 'COMMON.LANGEVIN'
3856 !#else
3857 !      include 'COMMON.LANGEVIN.lang0'
3858 !#endif
3859 !      include 'COMMON.CHAIN'
3860 !      include 'COMMON.DERIV'
3861 !      include 'COMMON.GEO'
3862 !      include 'COMMON.LOCAL'
3863 !      include 'COMMON.INTERACT'
3864 !      include 'COMMON.IOUNITS'
3865 !      include 'COMMON.NAMES'
3866 !el      real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres
3867 !el      common /stochcalc/ stochforcvec
3868       logical :: lprn = .false.
3869       real(kind=8) :: ddt1,ddt2
3870       integer :: i,j,ind,inres
3871
3872 !      write (iout,*) "dc_old"
3873 !      do i=0,nres
3874 !        write (iout,'(i5,3f10.5,5x,3f10.5)')
3875 !     &   i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3)
3876 !      enddo
3877       do j=1,3
3878         dc_work(j)=dc_old(j,0)
3879         d_t_work(j)=d_t_old(j,0)
3880         d_a_work(j)=d_a_old(j,0)
3881       enddo
3882       ind=3
3883       do i=nnt,nct-1
3884         do j=1,3
3885           dc_work(ind+j)=dc_old(j,i)
3886           d_t_work(ind+j)=d_t_old(j,i)
3887           d_a_work(ind+j)=d_a_old(j,i)
3888         enddo
3889         ind=ind+3
3890       enddo
3891       do i=nnt,nct
3892          mnum=molnum(i)
3893 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
3894          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
3895           .and.(mnum.lt.4)) then
3896           do j=1,3
3897             dc_work(ind+j)=dc_old(j,i+nres)
3898             d_t_work(ind+j)=d_t_old(j,i+nres)
3899             d_a_work(ind+j)=d_a_old(j,i+nres)
3900           enddo
3901           ind=ind+3
3902         endif
3903       enddo
3904 #ifndef LANG0
3905       if (lprn) then
3906       write (iout,*) &
3907         "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",&
3908         " vrand_mat2"
3909       do i=1,dimen
3910         do j=1,dimen
3911           write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),&
3912             vfric_mat(i,j),afric_mat(i,j),&
3913             prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j)
3914         enddo
3915       enddo
3916       endif
3917       do i=1,dimen
3918         ddt1=0.0d0
3919         ddt2=0.0d0
3920         do j=1,dimen
3921           dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) &
3922             +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j)
3923           ddt1=ddt1+pfric_mat(i,j)*d_t_work(j)
3924           ddt2=ddt2+vfric_mat(i,j)*d_a_work(j)
3925         enddo
3926         d_t_work_new(i)=ddt1+0.5d0*ddt2
3927         d_t_work(i)=ddt1+ddt2
3928       enddo
3929 #endif
3930       do j=1,3
3931         dc(j,0)=dc_work(j)
3932         d_t(j,0)=d_t_work(j)
3933       enddo
3934       ind=3
3935       do i=nnt,nct-1
3936         do j=1,3
3937           dc(j,i)=dc_work(ind+j)
3938           d_t(j,i)=d_t_work(ind+j)
3939         enddo
3940         ind=ind+3
3941       enddo
3942       do i=nnt,nct
3943          mnum=molnum(i)
3944 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
3945          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
3946           .and.(mnum.lt.4)) then
3947           inres=i+nres
3948           do j=1,3
3949             dc(j,inres)=dc_work(ind+j)
3950             d_t(j,inres)=d_t_work(ind+j)
3951           enddo
3952           ind=ind+3
3953         endif
3954       enddo
3955       return
3956       end subroutine sd_verlet1
3957 !-----------------------------------------------------------------------------
3958       subroutine sd_verlet2
3959
3960 !  Calculating the adjusted velocities for accelerations
3961       use energy_data
3962 !      implicit real*8 (a-h,o-z)
3963 !      include 'DIMENSIONS'
3964 !      include 'COMMON.CONTROL'
3965 !      include 'COMMON.VAR'
3966 !      include 'COMMON.MD'
3967 !#ifndef LANG0
3968 !      include 'COMMON.LANGEVIN'
3969 !#else
3970 !      include 'COMMON.LANGEVIN.lang0'
3971 !#endif
3972 !      include 'COMMON.CHAIN'
3973 !      include 'COMMON.DERIV'
3974 !      include 'COMMON.GEO'
3975 !      include 'COMMON.LOCAL'
3976 !      include 'COMMON.INTERACT'
3977 !      include 'COMMON.IOUNITS'
3978 !      include 'COMMON.NAMES'
3979 !el      real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV   !(MAXRES6) maxres6=6*maxres
3980        real(kind=8),dimension(6*nres) :: stochforcvecV  !(MAXRES6) maxres6=6*maxres
3981 !el      common /stochcalc/ stochforcvec
3982 !
3983       real(kind=8) :: ddt1,ddt2
3984       integer :: i,j,ind,inres
3985 ! Compute the stochastic forces which contribute to velocity change
3986 !
3987       call stochastic_force(stochforcvecV)
3988
3989 #ifndef LANG0
3990       do i=1,dimen
3991         ddt1=0.0d0
3992         ddt2=0.0d0
3993         do j=1,dimen
3994           ddt1=ddt1+vfric_mat(i,j)*d_a_work(j)
3995           ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ &
3996            vrand_mat2(i,j)*stochforcvecV(j)
3997         enddo
3998         d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2
3999       enddo
4000 #endif
4001       do j=1,3
4002         d_t(j,0)=d_t_work(j)
4003       enddo
4004       ind=3
4005       do i=nnt,nct-1
4006         do j=1,3
4007           d_t(j,i)=d_t_work(ind+j)
4008         enddo
4009         ind=ind+3
4010       enddo
4011       do i=nnt,nct
4012          mnum=molnum(i)
4013 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
4014          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4015           .and.(mnum.lt.4)) then
4016           inres=i+nres
4017           do j=1,3
4018             d_t(j,inres)=d_t_work(ind+j)
4019           enddo
4020           ind=ind+3
4021         endif
4022       enddo
4023       return
4024       end subroutine sd_verlet2
4025 !-----------------------------------------------------------------------------
4026       subroutine sd_verlet_ciccotti_setup
4027
4028 ! Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's
4029 ! version
4030 !      implicit real*8 (a-h,o-z)
4031 !      include 'DIMENSIONS'
4032       use control, only: tcpu
4033       use control_data
4034 #ifdef MPI
4035       include 'mpif.h'
4036 #endif
4037 !      include 'COMMON.CONTROL'
4038 !      include 'COMMON.VAR'
4039 !      include 'COMMON.MD'
4040 !#ifndef LANG0
4041 !      include 'COMMON.LANGEVIN'
4042 !#else
4043 !      include 'COMMON.LANGEVIN.lang0'
4044 !#endif
4045 !      include 'COMMON.CHAIN'
4046 !      include 'COMMON.DERIV'
4047 !      include 'COMMON.GEO'
4048 !      include 'COMMON.LOCAL'
4049 !      include 'COMMON.INTERACT'
4050 !      include 'COMMON.IOUNITS'
4051 !      include 'COMMON.NAMES'
4052 !      include 'COMMON.TIME1'
4053       real(kind=8),dimension(6*nres) :: emgdt   !(MAXRES6) maxres6=6*maxres
4054       real(kind=8) :: pterm,vterm,rho,rhoc,vsig
4055       real(kind=8),dimension(6*nres) :: pfric_vec,vfric_vec,afric_vec,&
4056         prand_vec,vrand_vec1,vrand_vec2 !(MAXRES6) maxres6=6*maxres
4057       logical :: lprn = .false.
4058       real(kind=8) :: zero = 1.0d-8, gdt_radius = 0.05d0
4059       real(kind=8) :: ktm,gdt,egdt,tt0
4060       integer :: i,maxres2
4061 #ifdef MPI
4062       tt0 = MPI_Wtime()
4063 #else
4064       tt0 = tcpu()
4065 #endif
4066 !
4067 ! AL 8/17/04 Code adapted from tinker
4068 !
4069 ! Get the frictional and random terms for stochastic dynamics in the
4070 ! eigenspace of mass-scaled UNRES friction matrix
4071 !
4072       maxres2=2*nres
4073       do i = 1, dimen
4074             write (iout,*) "i",i," fricgam",fricgam(i)
4075             gdt = fricgam(i) * d_time
4076 !
4077 ! Stochastic dynamics reduces to simple MD for zero friction
4078 !
4079             if (gdt .le. zero) then
4080                pfric_vec(i) = 1.0d0
4081                vfric_vec(i) = d_time
4082                afric_vec(i) = 0.5d0*d_time*d_time
4083                prand_vec(i) = afric_vec(i)
4084                vrand_vec2(i) = vfric_vec(i)
4085 !
4086 ! Analytical expressions when friction coefficient is large
4087 !
4088             else
4089                egdt = dexp(-gdt)
4090                pfric_vec(i) = egdt
4091                vfric_vec(i) = dexp(-0.5d0*gdt)*d_time
4092                afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time
4093                prand_vec(i) = afric_vec(i)
4094                vrand_vec2(i) = vfric_vec(i)
4095 !
4096 ! Compute the scaling factors of random terms for the nonzero friction case
4097 !
4098 !               ktm = 0.5d0*d_time/fricgam(i)
4099 !               psig = dsqrt(ktm*pterm) / fricgam(i)
4100 !               vsig = dsqrt(ktm*vterm)
4101 !               prand_vec(i) = psig*afric_vec(i)
4102 !               vrand_vec2(i) = vsig*vfric_vec(i)
4103             end if
4104       end do
4105       if (lprn) then
4106       write (iout,*) &
4107         "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",&
4108         " vrand_vec2"
4109       do i=1,dimen
4110         write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),&
4111             afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i)
4112       enddo
4113       endif
4114 !
4115 ! Transform from the eigenspace of mass-scaled friction matrix to UNRES variables
4116 !
4117       call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat)
4118       call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat)
4119       call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat)
4120       call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat)
4121       call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2)
4122 #ifdef MPI
4123       t_sdsetup=t_sdsetup+MPI_Wtime()
4124 #else
4125       t_sdsetup=t_sdsetup+tcpu()-tt0
4126 #endif
4127       return
4128       end subroutine sd_verlet_ciccotti_setup
4129 !-----------------------------------------------------------------------------
4130       subroutine sd_verlet1_ciccotti
4131
4132 ! Applying stochastic velocity Verlet algorithm - step 1 to velocities
4133 !      implicit real*8 (a-h,o-z)
4134       use energy_data
4135 !      include 'DIMENSIONS'
4136 #ifdef MPI
4137       include 'mpif.h'
4138 #endif
4139 !      include 'COMMON.CONTROL'
4140 !      include 'COMMON.VAR'
4141 !      include 'COMMON.MD'
4142 !#ifndef LANG0
4143 !      include 'COMMON.LANGEVIN'
4144 !#else
4145 !      include 'COMMON.LANGEVIN.lang0'
4146 !#endif
4147 !      include 'COMMON.CHAIN'
4148 !      include 'COMMON.DERIV'
4149 !      include 'COMMON.GEO'
4150 !      include 'COMMON.LOCAL'
4151 !      include 'COMMON.INTERACT'
4152 !      include 'COMMON.IOUNITS'
4153 !      include 'COMMON.NAMES'
4154 !el      real(kind=8),dimension(6*nres) :: stochforcvec !(MAXRES6) maxres6=6*maxres
4155 !el      common /stochcalc/ stochforcvec
4156       logical :: lprn = .false.
4157       real(kind=8) :: ddt1,ddt2
4158       integer :: i,j,ind,inres
4159 !      write (iout,*) "dc_old"
4160 !      do i=0,nres
4161 !        write (iout,'(i5,3f10.5,5x,3f10.5)')
4162 !     &   i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3)
4163 !      enddo
4164       do j=1,3
4165         dc_work(j)=dc_old(j,0)
4166         d_t_work(j)=d_t_old(j,0)
4167         d_a_work(j)=d_a_old(j,0)
4168       enddo
4169       ind=3
4170       do i=nnt,nct-1
4171         do j=1,3
4172           dc_work(ind+j)=dc_old(j,i)
4173           d_t_work(ind+j)=d_t_old(j,i)
4174           d_a_work(ind+j)=d_a_old(j,i)
4175         enddo
4176         ind=ind+3
4177       enddo
4178       do i=nnt,nct
4179         if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
4180           do j=1,3
4181             dc_work(ind+j)=dc_old(j,i+nres)
4182             d_t_work(ind+j)=d_t_old(j,i+nres)
4183             d_a_work(ind+j)=d_a_old(j,i+nres)
4184           enddo
4185           ind=ind+3
4186         endif
4187       enddo
4188
4189 #ifndef LANG0
4190       if (lprn) then
4191       write (iout,*) &
4192         "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",&
4193         " vrand_mat2"
4194       do i=1,dimen
4195         do j=1,dimen
4196                   write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),&
4197                     vfric_mat(i,j),afric_mat(i,j),&
4198             prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j)
4199         enddo
4200       enddo
4201       endif
4202       do i=1,dimen
4203         ddt1=0.0d0
4204         ddt2=0.0d0
4205         do j=1,dimen
4206           dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) &
4207             +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j)
4208           ddt1=ddt1+pfric_mat(i,j)*d_t_work(j)
4209           ddt2=ddt2+vfric_mat(i,j)*d_a_work(j)
4210         enddo
4211         d_t_work_new(i)=ddt1+0.5d0*ddt2
4212         d_t_work(i)=ddt1+ddt2
4213       enddo
4214 #endif
4215       do j=1,3
4216         dc(j,0)=dc_work(j)
4217         d_t(j,0)=d_t_work(j)
4218       enddo
4219       ind=3
4220       do i=nnt,nct-1
4221         do j=1,3
4222           dc(j,i)=dc_work(ind+j)
4223           d_t(j,i)=d_t_work(ind+j)
4224         enddo
4225         ind=ind+3
4226       enddo
4227       do i=nnt,nct
4228          mnum=molnum(i)
4229 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
4230          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4231           .and.(mnum.lt.4)) then
4232           inres=i+nres
4233           do j=1,3
4234             dc(j,inres)=dc_work(ind+j)
4235             d_t(j,inres)=d_t_work(ind+j)
4236           enddo
4237           ind=ind+3
4238         endif
4239       enddo
4240       return
4241       end subroutine sd_verlet1_ciccotti
4242 !-----------------------------------------------------------------------------
4243       subroutine sd_verlet2_ciccotti
4244
4245 !  Calculating the adjusted velocities for accelerations
4246       use energy_data
4247 !      implicit real*8 (a-h,o-z)
4248 !      include 'DIMENSIONS'
4249 !      include 'COMMON.CONTROL'
4250 !      include 'COMMON.VAR'
4251 !      include 'COMMON.MD'
4252 !#ifndef LANG0
4253 !      include 'COMMON.LANGEVIN'
4254 !#else
4255 !      include 'COMMON.LANGEVIN.lang0'
4256 !#endif
4257 !      include 'COMMON.CHAIN'
4258 !      include 'COMMON.DERIV'
4259 !      include 'COMMON.GEO'
4260 !      include 'COMMON.LOCAL'
4261 !      include 'COMMON.INTERACT'
4262 !      include 'COMMON.IOUNITS'
4263 !      include 'COMMON.NAMES'
4264 !el      real(kind=8),dimension(6*nres) :: stochforcvec,stochforcvecV   !(MAXRES6) maxres6=6*maxres
4265        real(kind=8),dimension(6*nres) :: stochforcvecV  !(MAXRES6) maxres6=6*maxres
4266 !el      common /stochcalc/ stochforcvec
4267       real(kind=8) :: ddt1,ddt2
4268       integer :: i,j,ind,inres
4269 !
4270 ! Compute the stochastic forces which contribute to velocity change
4271 !
4272       call stochastic_force(stochforcvecV)
4273 #ifndef LANG0
4274       do i=1,dimen
4275         ddt1=0.0d0
4276         ddt2=0.0d0
4277         do j=1,dimen
4278
4279           ddt1=ddt1+vfric_mat(i,j)*d_a_work(j)
4280 !          ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j)
4281           ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j)
4282         enddo
4283         d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2
4284       enddo
4285 #endif
4286       do j=1,3
4287         d_t(j,0)=d_t_work(j)
4288       enddo
4289       ind=3
4290       do i=nnt,nct-1
4291         do j=1,3
4292           d_t(j,i)=d_t_work(ind+j)
4293         enddo
4294         ind=ind+3
4295       enddo
4296       do i=nnt,nct
4297          mnum=molnum(i)
4298          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4299           .and.(mnum.lt.4))
4300 !        if (itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
4301           inres=i+nres
4302           do j=1,3
4303             d_t(j,inres)=d_t_work(ind+j)
4304           enddo
4305           ind=ind+3
4306         endif
4307       enddo
4308       return
4309       end subroutine sd_verlet2_ciccotti
4310 #endif
4311 !-----------------------------------------------------------------------------
4312 ! moments.f
4313 !-----------------------------------------------------------------------------
4314 #ifdef FIVEDIAG
4315       subroutine inertia_tensor
4316       use comm_gucio
4317       use energy_data
4318       real(kind=8) Im(3,3),Imcp(3,3),pr(3),M_SC,&
4319       eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3),&
4320       vpp(3,0:MAXRES),vs_p(3),pr1(3,3),&
4321       pr2(3,3),pp(3),incr(3),v(3),mag,mag2,M_PEP
4322       integer iti,inres,i,j,k,mnum,mnum1
4323       do i=1,3
4324         do j=1,3
4325           Im(i,j)=0.0d0
4326           pr1(i,j)=0.0d0
4327           pr2(i,j)=0.0d0
4328         enddo
4329         L(i)=0.0d0
4330         cm(i)=0.0d0
4331         vrot(i)=0.0d0
4332       enddo
4333         M_PEP=0.0d0
4334
4335 !c   caulating the center of the mass of the protein
4336       do i=nnt,nct-1
4337         mnum=molnum(i)
4338         mnum1=molnum(i+1)
4339         if (itype(i,mnum).eq.ntyp1_molec(mnum)&
4340          .or. itype(i+1,mnum1).eq.ntyp1_molec(mnum1)) cycle
4341 !          if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4342           if (mnum.ge.5) mp(mnum)=0.0d0
4343           M_PEP=M_PEP+mp(mnum)
4344
4345         do j=1,3
4346           cm(j)=cm(j)+(c(j,i)+0.5d0*dc(j,i))*mp(mnum)
4347         enddo
4348       enddo
4349 !      do j=1,3
4350 !       cm(j)=mp*cm(j)
4351 !      enddo
4352       M_SC=0.0d0
4353       do i=nnt,nct
4354         mnum=molnum(i)
4355         mnum1=molnum(i+1)
4356          iti=iabs(itype(i,mnum))
4357          if (iti.eq.ntyp1_molec(mnum)) cycle
4358          M_SC=M_SC+msc(iabs(iti),mnum)
4359          inres=i+nres
4360          do j=1,3
4361           cm(j)=cm(j)+msc(iabs(iti),mnum)*c(j,inres)
4362          enddo
4363       enddo
4364       do j=1,3
4365         cm(j)=cm(j)/(M_SC+M_PEP)
4366       enddo
4367       do i=nnt,nct-1
4368         mnum=molnum(i)
4369         mnum1=molnum(i+1)
4370 !        if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4371           if (mnum.ge.5) mp(mnum)=0.0d0
4372         if (itype(i,mnum).eq.ntyp1_molec(mnum)&
4373          .or. itype(i+1,mnum1).eq.ntyp1_molec(mnum1)) cycle
4374         do j=1,3
4375           pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
4376         enddo
4377         Im(1,1)=Im(1,1)+mp(mnum)*(pr(2)*pr(2)+pr(3)*pr(3))
4378         Im(1,2)=Im(1,2)-mp(mnum)*pr(1)*pr(2)
4379         Im(1,3)=Im(1,3)-mp(mnum)*pr(1)*pr(3)
4380         Im(2,3)=Im(2,3)-mp(mnum)*pr(2)*pr(3)
4381         Im(2,2)=Im(2,2)+mp(mnum)*(pr(3)*pr(3)+pr(1)*pr(1))
4382         Im(3,3)=Im(3,3)+mp(mnum)*(pr(1)*pr(1)+pr(2)*pr(2))
4383       enddo
4384
4385       do i=nnt,nct
4386         mnum=molnum(i)
4387         iti=iabs(itype(i,mnum))
4388         if (iti.eq.ntyp1_molec(mnum)) cycle
4389         inres=i+nres
4390         do j=1,3
4391           pr(j)=c(j,inres)-cm(j)
4392         enddo
4393         Im(1,1)=Im(1,1)+msc(iabs(iti),mnum)*(pr(2)*pr(2)+pr(3)*pr(3))
4394         Im(1,2)=Im(1,2)-msc(iabs(iti),mnum)*pr(1)*pr(2)
4395         Im(1,3)=Im(1,3)-msc(iabs(iti),mnum)*pr(1)*pr(3)
4396         Im(2,3)=Im(2,3)-msc(iabs(iti),mnum)*pr(2)*pr(3)
4397         Im(2,2)=Im(2,2)+msc(iabs(iti),mnum)*(pr(3)*pr(3)+pr(1)*pr(1))
4398         Im(3,3)=Im(3,3)+msc(iabs(iti),mnum)*(pr(1)*pr(1)+pr(2)*pr(2))
4399       enddo
4400       do i=nnt,nct-1
4401         mnum=molnum(i)
4402         mnum1=molnum(i+1)
4403         if (itype(i,mnum).eq.ntyp1_molec(mnum)&
4404         .or. itype(i+1,mnum1).eq.ntyp1_molec(mnum1)) cycle
4405         Im(1,1)=Im(1,1)+Ip(mnum)*(1-dc_norm(1,i)*dc_norm(1,i))*&
4406         vbld(i+1)*vbld(i+1)*0.25d0
4407         Im(1,2)=Im(1,2)+Ip(mnum)*(-dc_norm(1,i)*dc_norm(2,i))*&
4408         vbld(i+1)*vbld(i+1)*0.25d0
4409         Im(1,3)=Im(1,3)+Ip(mnum)*(-dc_norm(1,i)*dc_norm(3,i))*&
4410         vbld(i+1)*vbld(i+1)*0.25d0
4411         Im(2,3)=Im(2,3)+Ip(mnum)*(-dc_norm(2,i)*dc_norm(3,i))*&
4412         vbld(i+1)*vbld(i+1)*0.25d0
4413         Im(2,2)=Im(2,2)+Ip(mnum)*(1-dc_norm(2,i)*dc_norm(2,i))*&
4414         vbld(i+1)*vbld(i+1)*0.25d0
4415         Im(3,3)=Im(3,3)+Ip(mnum)*(1-dc_norm(3,i)*dc_norm(3,i))*&
4416         vbld(i+1)*vbld(i+1)*0.25d0
4417       enddo
4418       do i=nnt,nct
4419         mnum=molnum(i)
4420         mnum1=molnum(i+1)
4421         iti=iabs(itype(i,mnum))
4422         if (iti.ne.10 .and. iti.ne.ntyp1_molec(mnum).and.mnum.le.2) then
4423           inres=i+nres
4424           Im(1,1)=Im(1,1)+Isc(iti,mnum)*(1-dc_norm(1,inres)*&
4425           dc_norm(1,inres))*vbld(inres)*vbld(inres)
4426           Im(1,2)=Im(1,2)-Isc(iti,mnum)*(dc_norm(1,inres)*&
4427           dc_norm(2,inres))*vbld(inres)*vbld(inres)
4428           Im(1,3)=Im(1,3)-Isc(iti,mnum)*(dc_norm(1,inres)*&
4429           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4430           Im(2,3)=Im(2,3)-Isc(iti,mnum)*(dc_norm(2,inres)*&
4431           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4432           Im(2,2)=Im(2,2)+Isc(iti,mnum)*(1-dc_norm(2,inres)*&
4433           dc_norm(2,inres))*vbld(inres)*vbld(inres)
4434           Im(3,3)=Im(3,3)+Isc(iti,mnum)*(1-dc_norm(3,inres)*&
4435           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4436         endif
4437       enddo
4438
4439       call angmom(cm,L)
4440       Im(2,1)=Im(1,2)
4441       Im(3,1)=Im(1,3)
4442       Im(3,2)=Im(2,3)
4443
4444 !c  Copng the Im matrix for the djacob subroutine
4445       do i=1,3
4446         do j=1,3
4447           Imcp(i,j)=Im(i,j)
4448           Id(i,j)=0.0d0
4449         enddo
4450       enddo
4451 !c   Finding the eigenvectors and eignvalues of the inertia tensor
4452       call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval)
4453       do i=1,3
4454         if (dabs(eigval(i)).gt.1.0d-15) then
4455           Id(i,i)=1.0d0/eigval(i)
4456         else
4457           Id(i,i)=0.0d0
4458         endif
4459       enddo
4460       do i=1,3
4461         do j=1,3
4462           Imcp(i,j)=eigvec(j,i)
4463         enddo
4464       enddo
4465       do i=1,3
4466         do j=1,3
4467           do k=1,3
4468              pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j)
4469           enddo
4470         enddo
4471       enddo
4472       do i=1,3
4473         do j=1,3
4474           do k=1,3
4475             pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j)
4476           enddo
4477         enddo
4478       enddo
4479 !c  Calculating the total rotational velocity of the molecule
4480       do i=1,3
4481         do j=1,3
4482           vrot(i)=vrot(i)+pr2(i,j)*L(j)
4483         enddo
4484       enddo
4485       do i=nnt,nct-1
4486         mnum=molnum(i)
4487         mnum1=molnum(i+1)
4488 !        write (iout,*) itype(i+1,mnum1),itype(i,mnum)
4489         if (itype(i+1,mnum1).ne.ntyp1_molec(mnum1) &
4490         .and. itype(i,mnum).eq.ntyp1_molec(mnum) .or.&
4491            itype(i,mnum).ne.ntyp1_molec(mnum) &
4492          .and. itype(i+1,mnum1).eq.ntyp1_molec(mnum1)) cycle
4493         call vecpr(vrot(1),dc(1,i),vp)
4494         do j=1,3
4495           d_t(j,i)=d_t(j,i)-vp(j)
4496         enddo
4497       enddo
4498       do i=nnt,nct
4499       mnum=molnum(i)
4500         if(itype(i,1).ne.10 .and.itype(i,mnum).ne.ntyp1_molec(mnum)&
4501          .and.mnum.le.2) then
4502           inres=i+nres
4503           call vecpr(vrot(1),dc(1,inres),vp)
4504           do j=1,3
4505             d_t(j,inres)=d_t(j,inres)-vp(j)
4506           enddo
4507         endif
4508       enddo
4509       call angmom(cm,L)
4510       return
4511       end subroutine inertia_tensor
4512 !------------------------------------------------------------
4513       subroutine angmom(cm,L)
4514       implicit none
4515       double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3),&
4516        pp(3),mscab
4517       integer iti,inres,i,j,mnum,mnum1
4518 !c  Calculate the angular momentum
4519       do j=1,3
4520          L(j)=0.0d0
4521       enddo
4522       do j=1,3
4523          incr(j)=d_t(j,0)
4524       enddo
4525       do i=nnt,nct-1
4526         mnum=molnum(i)
4527         mnum1=molnum(i+1)
4528 !        if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4529           if (mnum.ge.5) mp(mnum)=0.0d0
4530         if (itype(i,mnum).eq.ntyp1_molec(mnum)&
4531         .or. itype(i+1,mnum1).eq.ntyp1_molec(mnum1)) cycle
4532         do j=1,3
4533           pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
4534         enddo
4535         do j=1,3
4536           v(j)=incr(j)+0.5d0*d_t(j,i)
4537         enddo
4538         do j=1,3
4539           incr(j)=incr(j)+d_t(j,i)
4540         enddo
4541         call vecpr(pr(1),v(1),vp)
4542         do j=1,3
4543           L(j)=L(j)+mp(mnum)*vp(j)
4544         enddo
4545         do j=1,3
4546           pr(j)=0.5d0*dc(j,i)
4547           pp(j)=0.5d0*d_t(j,i)
4548         enddo
4549         call vecpr(pr(1),pp(1),vp)
4550         do j=1,3
4551           L(j)=L(j)+Ip(mnum)*vp(j)
4552         enddo
4553       enddo
4554       do j=1,3
4555         incr(j)=d_t(j,0)
4556       enddo
4557       do i=nnt,nct
4558         mnum=molnum(i)
4559         iti=iabs(itype(i,mnum))
4560         inres=i+nres
4561         do j=1,3
4562           pr(j)=c(j,inres)-cm(j)
4563         enddo
4564         if (itype(i,1).ne.10 .and.itype(i,mnum).ne.ntyp1_molec(mnum)&
4565         .and.mnum.le.2) then
4566           do j=1,3
4567             v(j)=incr(j)+d_t(j,inres)
4568           enddo
4569         else
4570           do j=1,3
4571             v(j)=incr(j)
4572           enddo
4573         endif
4574         call vecpr(pr(1),v(1),vp)
4575 !c          write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3),
4576 !c      &     " v",(v(j),j=1,3)," vp",(vp(j),j=1,3)
4577 !        if (mnum.gt.4) then
4578 !         mscab=0.0d0
4579 !        else
4580          mscab=msc(iti,mnum)
4581 !        endif
4582         do j=1,3
4583           L(j)=L(j)+mscab*vp(j)
4584         enddo
4585 !c          write (iout,*) "L",(l(j),j=1,3)
4586         if (itype(i,1).ne.10 .and.itype(i,mnum).ne.ntyp1_molec(mnum)&
4587         .and.mnum.le.2) then
4588          do j=1,3
4589             v(j)=incr(j)+d_t(j,inres)
4590           enddo
4591           call vecpr(dc(1,inres),d_t(1,inres),vp)
4592           do j=1,3
4593             L(j)=L(j)+Isc(iti,mnum)*vp(j)
4594           enddo
4595         endif
4596         do j=1,3
4597             incr(j)=incr(j)+d_t(j,i)
4598         enddo
4599       enddo
4600       return
4601       end subroutine angmom
4602 !---------------------------------------------------------------
4603       subroutine vcm_vel(vcm)
4604        double precision vcm(3),vv(3),summas,amas
4605        integer i,j,mnum,mnum1
4606        do j=1,3
4607          vcm(j)=0.0d0
4608          vv(j)=d_t(j,0)
4609        enddo
4610        summas=0.0d0
4611        do i=nnt,nct
4612          mnum=molnum(i)
4613          if ((mnum.ge.5).or.(mnum.eq.3))&
4614          mp(mnum)=msc(itype(i,mnum),mnum)
4615          if (i.lt.nct) then
4616            summas=summas+mp(mnum)
4617            do j=1,3
4618              vcm(j)=vcm(j)+mp(mnum)*(vv(j)+0.5d0*d_t(j,i))
4619            enddo
4620          endif
4621          if (mnum.ne.4) then
4622          amas=msc(iabs(itype(i,mnum)),mnum)
4623          else
4624          amas=0.0d0
4625          endif
4626 !         amas=msc(iabs(itype(i)))
4627          summas=summas+amas
4628 !         if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then
4629          if (itype(i,mnum).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4630           .and.(mnum.lt.4)) then
4631          do j=1,3
4632              vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres))
4633            enddo
4634          else
4635            do j=1,3
4636              vcm(j)=vcm(j)+amas*vv(j)
4637            enddo
4638          endif
4639          do j=1,3
4640            vv(j)=vv(j)+d_t(j,i)
4641          enddo
4642        enddo
4643 !c       write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas
4644        do j=1,3
4645          vcm(j)=vcm(j)/summas
4646        enddo
4647        return
4648        end subroutine vcm_vel
4649 #else
4650       subroutine inertia_tensor
4651
4652 ! Calculating the intertia tensor for the entire protein in order to
4653 ! remove the perpendicular components of velocity matrix which cause
4654 ! the molecule to rotate.
4655       use comm_gucio
4656       use energy_data
4657 !       implicit real*8 (a-h,o-z)
4658 !       include 'DIMENSIONS'
4659 !       include 'COMMON.CONTROL'
4660 !       include 'COMMON.VAR'
4661 !       include 'COMMON.MD'
4662 !       include 'COMMON.CHAIN'
4663 !       include 'COMMON.DERIV'
4664 !       include 'COMMON.GEO'
4665 !       include 'COMMON.LOCAL'
4666 !       include 'COMMON.INTERACT'
4667 !       include 'COMMON.IOUNITS'
4668 !       include 'COMMON.NAMES'
4669
4670       real(kind=8),dimension(3,3) :: Im,Imcp,eigvec,Id
4671       real(kind=8),dimension(3) :: pr,eigval,L,vp,vrot
4672       real(kind=8) :: M_SC,mag,mag2,M_PEP
4673       real(kind=8),dimension(3,0:nres) :: vpp   !(3,0:MAXRES)
4674       real(kind=8),dimension(3) :: vs_p,pp,incr,v
4675       real(kind=8),dimension(3,3) :: pr1,pr2
4676
4677 !el      common /gucio/ cm
4678       integer :: iti,inres,i,j,k,mnum
4679         do i=1,3
4680            do j=1,3
4681              Im(i,j)=0.0d0
4682              pr1(i,j)=0.0d0
4683              pr2(i,j)=0.0d0
4684            enddo
4685            L(i)=0.0d0
4686            cm(i)=0.0d0
4687            vrot(i)=0.0d0
4688         enddo
4689 !   calculating the center of the mass of the protein
4690         M_PEP=0.0d0
4691         do i=nnt,nct-1
4692           mnum=molnum(i)
4693           if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4694           write(iout,*) "WTF",itype(i,mnum),i,mnum,mp(mnum)
4695 !          if (itype(i,mnum).eq.ntyp1_molec(mnum)) cycle
4696           M_PEP=M_PEP+mp(mnum)
4697
4698           do j=1,3
4699             cm(j)=cm(j)+(c(j,i)+0.5d0*dc(j,i))*mp(mnum)
4700           enddo
4701         enddo
4702 !        do j=1,3
4703 !         cm(j)=mp(1)*cm(j)
4704 !        enddo
4705         M_SC=0.0d0
4706         do i=nnt,nct
4707            mnum=molnum(i)
4708            if (mnum.ge.5) cycle
4709            iti=iabs(itype(i,mnum))
4710            M_SC=M_SC+msc(iabs(iti),mnum)
4711            inres=i+nres
4712            do j=1,3
4713             cm(j)=cm(j)+msc(iabs(iti),mnum)*c(j,inres)
4714            enddo
4715         enddo
4716         do j=1,3
4717           cm(j)=cm(j)/(M_SC+M_PEP)
4718         enddo
4719 !        write(iout,*) "Center of mass:",cm
4720         do i=nnt,nct-1
4721            mnum=molnum(i)
4722           if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4723           do j=1,3
4724             pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
4725           enddo
4726           Im(1,1)=Im(1,1)+mp(mnum)*(pr(2)*pr(2)+pr(3)*pr(3))
4727           Im(1,2)=Im(1,2)-mp(mnum)*pr(1)*pr(2)
4728           Im(1,3)=Im(1,3)-mp(mnum)*pr(1)*pr(3)
4729           Im(2,3)=Im(2,3)-mp(mnum)*pr(2)*pr(3)
4730           Im(2,2)=Im(2,2)+mp(mnum)*(pr(3)*pr(3)+pr(1)*pr(1))
4731           Im(3,3)=Im(3,3)+mp(mnum)*(pr(1)*pr(1)+pr(2)*pr(2))
4732         enddo
4733
4734 !        write(iout,*) "The angular momentum before msc add"
4735 !       do i=1,3
4736 !       write (iout,*) (Im(i,j),j=1,3)
4737 !       enddo
4738
4739         do i=nnt,nct
4740            mnum=molnum(i)
4741            iti=iabs(itype(i,mnum))
4742            if (mnum.ge.5) cycle
4743            inres=i+nres
4744            do j=1,3
4745              pr(j)=c(j,inres)-cm(j)
4746            enddo
4747           Im(1,1)=Im(1,1)+msc(iabs(iti),mnum)*(pr(2)*pr(2)+pr(3)*pr(3))
4748           Im(1,2)=Im(1,2)-msc(iabs(iti),mnum)*pr(1)*pr(2)
4749           Im(1,3)=Im(1,3)-msc(iabs(iti),mnum)*pr(1)*pr(3)
4750           Im(2,3)=Im(2,3)-msc(iabs(iti),mnum)*pr(2)*pr(3)
4751           Im(2,2)=Im(2,2)+msc(iabs(iti),mnum)*(pr(3)*pr(3)+pr(1)*pr(1))
4752           Im(3,3)=Im(3,3)+msc(iabs(iti),mnum)*(pr(1)*pr(1)+pr(2)*pr(2))
4753         enddo
4754 !        write(iout,*) "The angular momentum before Ip add"
4755 !       do i=1,3
4756 !       write (iout,*) (Im(i,j),j=1,3)
4757 !       enddo
4758
4759         do i=nnt,nct-1
4760            mnum=molnum(i)
4761           Im(1,1)=Im(1,1)+Ip(mnum)*(1-dc_norm(1,i)*dc_norm(1,i))* &
4762           vbld(i+1)*vbld(i+1)*0.25d0
4763           Im(1,2)=Im(1,2)+Ip(mnum)*(-dc_norm(1,i)*dc_norm(2,i))* &
4764           vbld(i+1)*vbld(i+1)*0.25d0
4765           Im(1,3)=Im(1,3)+Ip(mnum)*(-dc_norm(1,i)*dc_norm(3,i))* &
4766           vbld(i+1)*vbld(i+1)*0.25d0
4767           Im(2,3)=Im(2,3)+Ip(mnum)*(-dc_norm(2,i)*dc_norm(3,i))* &
4768           vbld(i+1)*vbld(i+1)*0.25d0
4769           Im(2,2)=Im(2,2)+Ip(mnum)*(1-dc_norm(2,i)*dc_norm(2,i))* &
4770           vbld(i+1)*vbld(i+1)*0.25d0
4771           Im(3,3)=Im(3,3)+Ip(mnum)*(1-dc_norm(3,i)*dc_norm(3,i))* &
4772           vbld(i+1)*vbld(i+1)*0.25d0
4773         enddo
4774 !        write(iout,*) "The angular momentum before Isc add"
4775 !       do i=1,3
4776 !       write (iout,*) (Im(i,j),j=1,3)
4777 !       enddo
4778
4779
4780         do i=nnt,nct
4781               mnum=molnum(i)
4782 !         if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)) then
4783          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4784           .and.(mnum.lt.4)) then
4785            iti=iabs(itype(i,mnum))
4786            inres=i+nres
4787           Im(1,1)=Im(1,1)+Isc(iti,mnum)*(1-dc_norm(1,inres)* &
4788           dc_norm(1,inres))*vbld(inres)*vbld(inres)
4789           Im(1,2)=Im(1,2)-Isc(iti,mnum)*(dc_norm(1,inres)* &
4790           dc_norm(2,inres))*vbld(inres)*vbld(inres)
4791           Im(1,3)=Im(1,3)-Isc(iti,mnum)*(dc_norm(1,inres)* &
4792           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4793           Im(2,3)=Im(2,3)-Isc(iti,mnum)*(dc_norm(2,inres)* &
4794           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4795           Im(2,2)=Im(2,2)+Isc(iti,mnum)*(1-dc_norm(2,inres)* &
4796           dc_norm(2,inres))*vbld(inres)*vbld(inres)
4797           Im(3,3)=Im(3,3)+Isc(iti,mnum)*(1-dc_norm(3,inres)* &
4798           dc_norm(3,inres))*vbld(inres)*vbld(inres)
4799          endif
4800         enddo
4801
4802 !        write(iout,*) "The angular momentum before agnom:"
4803 !       do i=1,3
4804 !       write (iout,*) (Im(i,j),j=1,3)
4805 !       enddo
4806
4807         call angmom(cm,L)
4808 !        write(iout,*) "The angular momentum before adjustment:"
4809 !        write(iout,*) (L(j),j=1,3)
4810 !       do i=1,3
4811 !       write (iout,*) (Im(i,j),j=1,3)
4812 !       enddo
4813         Im(2,1)=Im(1,2)
4814         Im(3,1)=Im(1,3)
4815         Im(3,2)=Im(2,3)
4816
4817 !  Copying the Im matrix for the djacob subroutine
4818         do i=1,3
4819           do j=1,3
4820             Imcp(i,j)=Im(i,j)
4821             Id(i,j)=0.0d0
4822           enddo
4823         enddo
4824
4825 !   Finding the eigenvectors and eignvalues of the inertia tensor
4826        call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval)
4827 !       write (iout,*) "Eigenvalues & Eigenvectors"
4828 !       write (iout,'(5x,3f10.5)') (eigval(i),i=1,3)
4829 !       write (iout,*)
4830 !       do i=1,3
4831 !         write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3)
4832 !       enddo
4833 !   Constructing the diagonalized matrix
4834        do i=1,3
4835          if (dabs(eigval(i)).gt.1.0d-15) then
4836            Id(i,i)=1.0d0/eigval(i)
4837          else
4838            Id(i,i)=0.0d0
4839          endif
4840        enddo
4841         do i=1,3
4842            do j=1,3
4843               Imcp(i,j)=eigvec(j,i)
4844            enddo
4845         enddo
4846         do i=1,3
4847            do j=1,3
4848               do k=1,3
4849                  pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j)
4850               enddo
4851            enddo
4852         enddo
4853         do i=1,3
4854            do j=1,3
4855               do k=1,3
4856                  pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j)
4857               enddo
4858            enddo
4859         enddo
4860 !  Calculating the total rotational velocity of the molecule
4861        do i=1,3
4862          do j=1,3
4863            vrot(i)=vrot(i)+pr2(i,j)*L(j)
4864          enddo
4865        enddo
4866 !   Resetting the velocities
4867        do i=nnt,nct-1
4868          call vecpr(vrot(1),dc(1,i),vp)
4869          do j=1,3
4870 !           print *,"HERE2",d_t(j,i),vp(j)
4871            d_t(j,i)=d_t(j,i)-vp(j)
4872 !           print *,"HERE2",d_t(j,i),vp(j)
4873           enddo
4874         enddo
4875         do i=nnt,nct
4876               mnum=molnum(i)
4877          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4878           .and.(mnum.lt.4)) then
4879 !         if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)) then
4880 !       if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
4881            inres=i+nres
4882            call vecpr(vrot(1),dc(1,inres),vp)
4883            do j=1,3
4884              d_t(j,inres)=d_t(j,inres)-vp(j)
4885            enddo
4886         endif
4887        enddo
4888        call angmom(cm,L)
4889 !       write(iout,*) "The angular momentum after adjustment:"
4890 !       write(iout,*) (L(j),j=1,3)
4891
4892       return
4893       end subroutine inertia_tensor
4894 !-----------------------------------------------------------------------------
4895       subroutine angmom(cm,L)
4896
4897       use energy_data
4898 !       implicit real*8 (a-h,o-z)
4899 !       include 'DIMENSIONS'
4900 !       include 'COMMON.CONTROL'
4901 !       include 'COMMON.VAR'
4902 !       include 'COMMON.MD'
4903 !       include 'COMMON.CHAIN'
4904 !       include 'COMMON.DERIV'
4905 !       include 'COMMON.GEO'
4906 !       include 'COMMON.LOCAL'
4907 !       include 'COMMON.INTERACT'
4908 !       include 'COMMON.IOUNITS'
4909 !       include 'COMMON.NAMES'
4910       real(kind=8) :: mscab
4911       real(kind=8),dimension(3) :: L,cm,pr,vp,vrot,incr,v,pp
4912       integer :: iti,inres,i,j,mnum
4913 !  Calculate the angular momentum
4914        do j=1,3
4915           L(j)=0.0d0
4916        enddo
4917        do j=1,3
4918           incr(j)=d_t(j,0)
4919        enddo
4920        do i=nnt,nct-1
4921           mnum=molnum(i)
4922           if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
4923           do j=1,3
4924             pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
4925           enddo
4926           do j=1,3
4927             v(j)=incr(j)+0.5d0*d_t(j,i)
4928           enddo
4929           do j=1,3
4930             incr(j)=incr(j)+d_t(j,i)
4931           enddo
4932           call vecpr(pr(1),v(1),vp)
4933           do j=1,3
4934             L(j)=L(j)+mp(mnum)*vp(j)
4935 !            print *,"HERE3",J,i,L(j),mp(mnum),Ip(mnum),mnum
4936           enddo
4937           do j=1,3
4938              pr(j)=0.5d0*dc(j,i)
4939              pp(j)=0.5d0*d_t(j,i)
4940           enddo
4941          call vecpr(pr(1),pp(1),vp)
4942 !         print *,vp,"vp"
4943          do j=1,3
4944              L(j)=L(j)+Ip(mnum)*vp(j)
4945           enddo
4946         enddo
4947         do j=1,3
4948           incr(j)=d_t(j,0)
4949         enddo
4950         do i=nnt,nct
4951           mnum=molnum(i)
4952          iti=iabs(itype(i,mnum))
4953          inres=i+nres
4954         if (mnum.gt.4) then
4955          mscab=0.0d0
4956         else
4957          mscab=msc(iti,mnum)
4958         endif
4959          do j=1,3
4960            pr(j)=c(j,inres)-cm(j)
4961          enddo
4962          !endif
4963          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4964           .and.(mnum.lt.4)) then
4965            do j=1,3
4966              v(j)=incr(j)+d_t(j,inres)
4967            enddo
4968          else
4969            do j=1,3
4970              v(j)=incr(j)
4971            enddo
4972          endif
4973 !         print *,i,pr,"pr",v
4974          call vecpr(pr(1),v(1),vp)
4975 !         write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3),&
4976 !           " v",(v(j),j=1,3)," vp",(vp(j),j=1,3)
4977          do j=1,3
4978             L(j)=L(j)+mscab*vp(j)
4979          enddo
4980 !         write (iout,*) "L",(l(j),j=1,3)
4981 !          print *,"L",(l(j),j=1,3),i,vp(1)
4982
4983          if (itype(i,mnum).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
4984           .and.(mnum.lt.4)) then
4985            do j=1,3
4986             v(j)=incr(j)+d_t(j,inres)
4987            enddo
4988            call vecpr(dc(1,inres),d_t(1,inres),vp)
4989            do j=1,3
4990              L(j)=L(j)+Isc(iti,mnum)*vp(j)
4991           enddo
4992          endif
4993          do j=1,3
4994              incr(j)=incr(j)+d_t(j,i)
4995          enddo
4996        enddo
4997       return
4998       end subroutine angmom
4999 !-----------------------------------------------------------------------------
5000       subroutine vcm_vel(vcm)
5001
5002       use energy_data
5003 !       implicit real*8 (a-h,o-z)
5004 !       include 'DIMENSIONS'
5005 !       include 'COMMON.VAR'
5006 !       include 'COMMON.MD'
5007 !       include 'COMMON.CHAIN'
5008 !       include 'COMMON.DERIV'
5009 !       include 'COMMON.GEO'
5010 !       include 'COMMON.LOCAL'
5011 !       include 'COMMON.INTERACT'
5012 !       include 'COMMON.IOUNITS'
5013        real(kind=8),dimension(3) :: vcm,vv
5014        real(kind=8) :: summas,amas
5015        integer :: i,j,mnum
5016
5017        do j=1,3
5018          vcm(j)=0.0d0
5019          vv(j)=d_t(j,0)
5020        enddo
5021        summas=0.0d0
5022        do i=nnt,nct
5023          mnum=molnum(i)
5024          if (mnum.ge.5) mp(mnum)=msc(itype(i,mnum),mnum)
5025          if (i.lt.nct) then
5026            summas=summas+mp(mnum)
5027            do j=1,3
5028              vcm(j)=vcm(j)+mp(mnum)*(vv(j)+0.5d0*d_t(j,i))
5029 !             print *,i,j,vv(j),d_t(j,i)
5030            enddo
5031          endif
5032          if (mnum.ne.4) then
5033          amas=msc(iabs(itype(i,mnum)),mnum)
5034          else
5035          amas=0.0d0
5036          endif
5037          summas=summas+amas
5038          if (itype(i,mnum).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5039           .and.(mnum.lt.4)) then
5040            do j=1,3
5041              vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres))
5042            enddo
5043          else
5044            do j=1,3
5045              vcm(j)=vcm(j)+amas*vv(j)
5046            enddo
5047          endif
5048          do j=1,3
5049            vv(j)=vv(j)+d_t(j,i)
5050          enddo
5051        enddo
5052 !       write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas
5053        do j=1,3
5054          vcm(j)=vcm(j)/summas
5055        enddo
5056       return
5057       end subroutine vcm_vel
5058 #endif
5059 !-----------------------------------------------------------------------------
5060 ! rattle.F
5061 !-----------------------------------------------------------------------------
5062       subroutine rattle1
5063 ! RATTLE algorithm for velocity Verlet - step 1, UNRES
5064 ! AL 9/24/04
5065       use comm_przech
5066       use energy_data
5067 !      implicit real*8 (a-h,o-z)
5068 !      include 'DIMENSIONS'
5069 #ifdef RATTLE
5070 !      include 'COMMON.CONTROL'
5071 !      include 'COMMON.VAR'
5072 !      include 'COMMON.MD'
5073 !#ifndef LANG0
5074 !      include 'COMMON.LANGEVIN'
5075 !#else
5076 !      include 'COMMON.LANGEVIN.lang0'
5077 !#endif
5078 !      include 'COMMON.CHAIN'
5079 !      include 'COMMON.DERIV'
5080 !      include 'COMMON.GEO'
5081 !      include 'COMMON.LOCAL'
5082 !      include 'COMMON.INTERACT'
5083 !      include 'COMMON.IOUNITS'
5084 !      include 'COMMON.NAMES'
5085 !      include 'COMMON.TIME1'
5086 !el      real(kind=8) :: gginv(2*nres,2*nres),&
5087 !el       gdc(3,2*nres,2*nres)
5088       real(kind=8) :: dC_uncor(3,2*nres)        !,&
5089 !el      real(kind=8) :: Cmat(2*nres,2*nres)
5090       real(kind=8) :: x(2*nres),xcorr(3,2*nres)         !maxres2=2*maxres
5091 !el      common /przechowalnia/ GGinv,gdc,Cmat,nbond
5092 !el      common /przechowalnia/ nbond
5093       integer :: max_rattle = 5
5094       logical :: lprn = .false., lprn1 = .false., not_done
5095       real(kind=8) :: tol_rattle = 1.0d-5
5096
5097       integer :: ii,i,j,jj,l,ind,ind1,nres2
5098       nres2=2*nres
5099
5100 !el /common/ przechowalnia
5101
5102       if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2))
5103       if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2))
5104       if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2))
5105 !el--------
5106       if (lprn) write (iout,*) "RATTLE1"
5107       nbond=nct-nnt
5108       do i=nnt,nct
5109        mnum=molnum(i)
5110          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5111           .and.(mnum.lt.4)) nbond=nbond+1
5112       enddo
5113 ! Make a folded form of the Ginv-matrix
5114       ind=0
5115       ii=0
5116       do i=nnt,nct-1
5117         ii=ii+1
5118         do j=1,3
5119           ind=ind+1
5120           ind1=0
5121           jj=0
5122           do k=nnt,nct-1
5123             jj=jj+1
5124             do l=1,3
5125               ind1=ind1+1
5126               if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
5127             enddo
5128           enddo
5129           do k=nnt,nct
5130           mnum=molnum(k)
5131          if (itype(k,1).ne.10 .and. itype(k,mnum).ne.ntyp1_molec(mnum)&
5132           .and.(mnum.lt.4)) then
5133               jj=jj+1
5134               do l=1,3
5135                 ind1=ind1+1
5136                 if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
5137               enddo
5138             endif
5139           enddo
5140         enddo
5141       enddo
5142       do i=nnt,nct
5143          mnum=molnum(i)
5144          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5145           .and.(mnum.lt.4))
5146           ii=ii+1
5147           do j=1,3
5148             ind=ind+1
5149             ind1=0
5150             jj=0
5151             do k=nnt,nct-1
5152               jj=jj+1
5153               do l=1,3
5154                 ind1=ind1+1
5155                 if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
5156               enddo
5157             enddo
5158             do k=nnt,nct
5159               if (itype(k,1).ne.10) then
5160                 jj=jj+1
5161                 do l=1,3
5162                   ind1=ind1+1
5163                   if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
5164                 enddo
5165               endif
5166             enddo
5167           enddo
5168         endif
5169       enddo
5170       if (lprn1) then
5171         write (iout,*) "Matrix GGinv"
5172         call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv)
5173       endif
5174       not_done=.true.
5175       iter=0
5176       do while (not_done)
5177       iter=iter+1
5178       if (iter.gt.max_rattle) then
5179         write (iout,*) "Error - too many iterations in RATTLE."
5180         stop
5181       endif
5182 ! Calculate the matrix C = GG**(-1) dC_old o dC
5183       ind1=0
5184       do i=nnt,nct-1
5185         ind1=ind1+1
5186         do j=1,3
5187           dC_uncor(j,ind1)=dC(j,i)
5188         enddo
5189       enddo
5190       do i=nnt,nct
5191         if (itype(i,1).ne.10) then
5192           ind1=ind1+1
5193           do j=1,3
5194             dC_uncor(j,ind1)=dC(j,i+nres)
5195           enddo
5196         endif
5197       enddo
5198       do i=1,nbond
5199         ind=0
5200         do k=nnt,nct-1
5201           ind=ind+1
5202           do j=1,3
5203             gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k)
5204           enddo
5205         enddo
5206         do k=nnt,nct
5207           if (itype(k,1).ne.10) then
5208             ind=ind+1
5209             do j=1,3
5210               gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres)
5211             enddo
5212           endif
5213         enddo
5214       enddo
5215 ! Calculate deviations from standard virtual-bond lengths
5216       ind=0
5217       do i=nnt,nct-1
5218         ind=ind+1
5219         x(ind)=vbld(i+1)**2-vbl**2
5220       enddo
5221       do i=nnt,nct
5222         if (itype(i,1).ne.10) then
5223           ind=ind+1
5224           x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i,1))**2
5225         endif
5226       enddo
5227       if (lprn) then
5228         write (iout,*) "Coordinates and violations"
5229         do i=1,nbond
5230           write(iout,'(i5,3f10.5,5x,e15.5)') &
5231            i,(dC_uncor(j,i),j=1,3),x(i)
5232         enddo
5233         write (iout,*) "Velocities and violations"
5234         ind=0
5235         do i=nnt,nct-1
5236           ind=ind+1
5237           write (iout,'(2i5,3f10.5,5x,e15.5)') &
5238            i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
5239         enddo
5240         do i=nnt,nct
5241           mnum=molnum(i)
5242          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5243           .and.(mnum.lt.4)) then
5244
5245             ind=ind+1
5246             write (iout,'(2i5,3f10.5,5x,e15.5)') &
5247              i+nres,ind,(d_t_new(j,i+nres),j=1,3),&
5248              scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
5249           endif
5250         enddo
5251 !        write (iout,*) "gdc"
5252 !        do i=1,nbond
5253 !          write (iout,*) "i",i
5254 !          do j=1,nbond
5255 !            write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
5256 !          enddo
5257 !        enddo
5258       endif
5259       xmax=dabs(x(1))
5260       do i=2,nbond
5261         if (dabs(x(i)).gt.xmax) then
5262           xmax=dabs(x(i))
5263         endif
5264       enddo
5265       if (xmax.lt.tol_rattle) then
5266         not_done=.false.
5267         goto 100
5268       endif
5269 ! Calculate the matrix of the system of equations
5270       do i=1,nbond
5271         do j=1,nbond
5272           Cmat(i,j)=0.0d0
5273           do k=1,3
5274             Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j)
5275           enddo
5276         enddo
5277       enddo
5278       if (lprn1) then
5279         write (iout,*) "Matrix Cmat"
5280         call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
5281       endif
5282       call gauss(Cmat,X,MAXRES2,nbond,1,*10)
5283 ! Add constraint term to positions
5284       ind=0
5285       do i=nnt,nct-1
5286         ind=ind+1
5287         do j=1,3
5288           xx=0.0d0
5289           do ii=1,nbond
5290             xx = xx+x(ii)*gdc(j,ind,ii)
5291           enddo
5292           xx=0.5d0*xx
5293           dC(j,i)=dC(j,i)-xx
5294           d_t_new(j,i)=d_t_new(j,i)-xx/d_time
5295         enddo
5296       enddo
5297       do i=nnt,nct
5298         if (itype(i,1).ne.10) then
5299           ind=ind+1
5300           do j=1,3
5301             xx=0.0d0
5302             do ii=1,nbond
5303               xx = xx+x(ii)*gdc(j,ind,ii)
5304             enddo
5305             xx=0.5d0*xx
5306             dC(j,i+nres)=dC(j,i+nres)-xx
5307             d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time
5308           enddo
5309         endif
5310       enddo
5311 ! Rebuild the chain using the new coordinates
5312       call chainbuild_cart
5313       if (lprn) then
5314         write (iout,*) "New coordinates, Lagrange multipliers,",&
5315         " and differences between actual and standard bond lengths"
5316         ind=0
5317         do i=nnt,nct-1
5318           ind=ind+1
5319           xx=vbld(i+1)**2-vbl**2
5320           write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
5321               i,(dC(j,i),j=1,3),x(ind),xx
5322         enddo
5323         do i=nnt,nct
5324          mnum=molnum(i)
5325          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5326           .and.(mnum.lt.4))
5327             ind=ind+1
5328             xx=vbld(i+nres)**2-vbldsc0(1,itype(i,1))**2
5329             write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
5330              i,(dC(j,i+nres),j=1,3),x(ind),xx
5331           endif
5332         enddo
5333         write (iout,*) "Velocities and violations"
5334         ind=0
5335         do i=nnt,nct-1
5336           ind=ind+1
5337           write (iout,'(2i5,3f10.5,5x,e15.5)') &
5338            i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
5339         enddo
5340         do i=nnt,nct
5341           if (itype(i,1).ne.10) then
5342             ind=ind+1
5343             write (iout,'(2i5,3f10.5,5x,e15.5)') &
5344              i+nres,ind,(d_t_new(j,i+nres),j=1,3),&
5345              scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
5346           endif
5347         enddo
5348       endif
5349       enddo
5350   100 continue
5351       return
5352    10 write (iout,*) "Error - singularity in solving the system",&
5353        " of equations for Lagrange multipliers."
5354       stop
5355 #else
5356       write (iout,*) &
5357        "RATTLE inactive; use -DRATTLE switch at compile time."
5358       stop
5359 #endif
5360       end subroutine rattle1
5361 !-----------------------------------------------------------------------------
5362       subroutine rattle2
5363 ! RATTLE algorithm for velocity Verlet - step 2, UNRES
5364 ! AL 9/24/04
5365       use comm_przech
5366       use energy_data
5367 !      implicit real*8 (a-h,o-z)
5368 !      include 'DIMENSIONS'
5369 #ifdef RATTLE
5370 !      include 'COMMON.CONTROL'
5371 !      include 'COMMON.VAR'
5372 !      include 'COMMON.MD'
5373 !#ifndef LANG0
5374 !      include 'COMMON.LANGEVIN'
5375 !#else
5376 !      include 'COMMON.LANGEVIN.lang0'
5377 !#endif
5378 !      include 'COMMON.CHAIN'
5379 !      include 'COMMON.DERIV'
5380 !      include 'COMMON.GEO'
5381 !      include 'COMMON.LOCAL'
5382 !      include 'COMMON.INTERACT'
5383 !      include 'COMMON.IOUNITS'
5384 !      include 'COMMON.NAMES'
5385 !      include 'COMMON.TIME1'
5386 !el      real(kind=8) :: gginv(2*nres,2*nres),&
5387 !el       gdc(3,2*nres,2*nres)
5388       real(kind=8) :: dC_uncor(3,2*nres)        !,&
5389 !el       Cmat(2*nres,2*nres)
5390       real(kind=8) :: x(2*nres)         !maxres2=2*maxres
5391 !el      common /przechowalnia/ GGinv,gdc,Cmat,nbond
5392 !el      common /przechowalnia/ nbond
5393       integer :: max_rattle = 5
5394       logical :: lprn = .false., lprn1 = .false., not_done
5395       real(kind=8) :: tol_rattle = 1.0d-5
5396       integer :: nres2
5397       nres2=2*nres
5398
5399 !el /common/ przechowalnia
5400       if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2))
5401       if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2))
5402       if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2))
5403 !el--------
5404       if (lprn) write (iout,*) "RATTLE2"
5405       if (lprn) write (iout,*) "Velocity correction"
5406 ! Calculate the matrix G dC
5407       do i=1,nbond
5408         ind=0
5409         do k=nnt,nct-1
5410           ind=ind+1
5411           do j=1,3
5412             gdc(j,i,ind)=GGinv(i,ind)*dC(j,k)
5413           enddo
5414         enddo
5415         do k=nnt,nct
5416          mnum=molnum(i)
5417          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5418           .and.(mnum.lt.4)) then
5419             ind=ind+1
5420             do j=1,3
5421               gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres)
5422             enddo
5423           endif
5424         enddo
5425       enddo
5426 !      if (lprn) then
5427 !        write (iout,*) "gdc"
5428 !        do i=1,nbond
5429 !          write (iout,*) "i",i
5430 !          do j=1,nbond
5431 !            write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
5432 !          enddo
5433 !        enddo
5434 !      endif
5435 ! Calculate the matrix of the system of equations
5436       ind=0
5437       do i=nnt,nct-1
5438         ind=ind+1
5439         do j=1,nbond
5440           Cmat(ind,j)=0.0d0
5441           do k=1,3
5442             Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j)
5443           enddo
5444         enddo
5445       enddo
5446       do i=nnt,nct
5447          mnum=molnum(i)
5448          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5449           .and.(mnum.lt.4)) then
5450           ind=ind+1
5451           do j=1,nbond
5452             Cmat(ind,j)=0.0d0
5453             do k=1,3
5454               Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j)
5455             enddo
5456           enddo
5457         endif
5458       enddo
5459 ! Calculate the scalar product dC o d_t_new
5460       ind=0
5461       do i=nnt,nct-1
5462         ind=ind+1
5463         x(ind)=scalar(d_t(1,i),dC(1,i))
5464       enddo
5465       do i=nnt,nct
5466          mnum=molnum(i)
5467          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5468           .and.(mnum.lt.4)) then
5469           ind=ind+1
5470           x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres))
5471         endif
5472       enddo
5473       if (lprn) then
5474         write (iout,*) "Velocities and violations"
5475         ind=0
5476         do i=nnt,nct-1
5477           ind=ind+1
5478           write (iout,'(2i5,3f10.5,5x,e15.5)') &
5479            i,ind,(d_t(j,i),j=1,3),x(ind)
5480         enddo
5481         do i=nnt,nct
5482          mnum=molnum(i)
5483          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5484           .and.(mnum.lt.4)) then
5485             ind=ind+1
5486             write (iout,'(2i5,3f10.5,5x,e15.5)') &
5487              i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind)
5488           endif
5489         enddo
5490       endif
5491       xmax=dabs(x(1))
5492       do i=2,nbond
5493         if (dabs(x(i)).gt.xmax) then
5494           xmax=dabs(x(i))
5495         endif
5496       enddo
5497       if (xmax.lt.tol_rattle) then
5498         not_done=.false.
5499         goto 100
5500       endif
5501       if (lprn1) then
5502         write (iout,*) "Matrix Cmat"
5503         call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
5504       endif
5505       call gauss(Cmat,X,MAXRES2,nbond,1,*10)
5506 ! Add constraint term to velocities
5507       ind=0
5508       do i=nnt,nct-1
5509         ind=ind+1
5510         do j=1,3
5511           xx=0.0d0
5512           do ii=1,nbond
5513             xx = xx+x(ii)*gdc(j,ind,ii)
5514           enddo
5515           d_t(j,i)=d_t(j,i)-xx
5516         enddo
5517       enddo
5518       do i=nnt,nct
5519          mnum=molnum(i)
5520          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5521           .and.(mnum.lt.4)) then
5522           ind=ind+1
5523           do j=1,3
5524             xx=0.0d0
5525             do ii=1,nbond
5526               xx = xx+x(ii)*gdc(j,ind,ii)
5527             enddo
5528             d_t(j,i+nres)=d_t(j,i+nres)-xx
5529           enddo
5530         endif
5531       enddo
5532       if (lprn) then
5533         write (iout,*) &
5534           "New velocities, Lagrange multipliers violations"
5535         ind=0
5536         do i=nnt,nct-1
5537           ind=ind+1
5538           if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') &
5539              i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i))
5540         enddo
5541         do i=nnt,nct
5542          mnum=molnum(i)
5543          if (itype(i,1).ne.10 .and. itype(i,mnum).ne.ntyp1_molec(mnum)&
5544           .and.(mnum.lt.4))
5545             ind=ind+1
5546             write (iout,'(2i5,3f10.5,5x,2e15.5)') &
5547               i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind),&
5548               scalar(d_t(1,i+nres),dC(1,i+nres))
5549           endif
5550         enddo
5551       endif
5552   100 continue
5553       return
5554    10 write (iout,*) "Error - singularity in solving the system",&
5555        " of equations for Lagrange multipliers."
5556       stop
5557 #else
5558       write (iout,*) &
5559        "RATTLE inactive; use -DRATTLE option at compile time."
5560       stop
5561 #endif
5562       end subroutine rattle2
5563 !-----------------------------------------------------------------------------
5564       subroutine rattle_brown
5565 ! RATTLE/LINCS algorithm for Brownian dynamics, UNRES
5566 ! AL 9/24/04
5567       use comm_przech
5568       use energy_data
5569 !      implicit real*8 (a-h,o-z)
5570 !      include 'DIMENSIONS'
5571 #ifdef RATTLE
5572 !      include 'COMMON.CONTROL'
5573 !      include 'COMMON.VAR'
5574 !      include 'COMMON.MD'
5575 !#ifndef LANG0
5576 !      include 'COMMON.LANGEVIN'
5577 !#else
5578 !      include 'COMMON.LANGEVIN.lang0'
5579 !#endif
5580 !      include 'COMMON.CHAIN'
5581 !      include 'COMMON.DERIV'
5582 !      include 'COMMON.GEO'
5583 !      include 'COMMON.LOCAL'
5584 !      include 'COMMON.INTERACT'
5585 !      include 'COMMON.IOUNITS'
5586 !      include 'COMMON.NAMES'
5587 !      include 'COMMON.TIME1'
5588 !el      real(kind=8) :: gginv(2*nres,2*nres),&
5589 !el       gdc(3,2*nres,2*nres)
5590       real(kind=8) :: dC_uncor(3,2*nres)        !,&
5591 !el      real(kind=8) :: Cmat(2*nres,2*nres)
5592       real(kind=8) :: x(2*nres)         !maxres2=2*maxres
5593 !el      common /przechowalnia/ GGinv,gdc,Cmat,nbond
5594 !el      common /przechowalnia/ nbond
5595       integer :: max_rattle = 5
5596       logical :: lprn = .false., lprn1 = .false., not_done
5597       real(kind=8) :: tol_rattle = 1.0d-5
5598       integer :: nres2
5599       nres2=2*nres
5600
5601 !el /common/ przechowalnia
5602       if(.not.allocated(GGinv)) allocate(GGinv(nres2,nres2))
5603       if(.not.allocated(gdc)) allocate(gdc(3,nres2,nres2))
5604       if(.not.allocated(Cmat)) allocate(Cmat(nres2,nres2))
5605 !el--------
5606
5607       if (lprn) write (iout,*) "RATTLE_BROWN"
5608       nbond=nct-nnt
5609       do i=nnt,nct
5610         if (itype(i,1).ne.10) nbond=nbond+1
5611       enddo
5612 ! Make a folded form of the Ginv-matrix
5613       ind=0
5614       ii=0
5615       do i=nnt,nct-1
5616         ii=ii+1
5617         do j=1,3
5618           ind=ind+1
5619           ind1=0
5620           jj=0
5621           do k=nnt,nct-1
5622             jj=jj+1
5623             do l=1,3
5624               ind1=ind1+1
5625               if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
5626             enddo
5627           enddo
5628           do k=nnt,nct
5629             if (itype(k,1).ne.10) then
5630               jj=jj+1
5631               do l=1,3
5632                 ind1=ind1+1
5633                 if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
5634               enddo
5635             endif
5636           enddo
5637         enddo
5638       enddo
5639       do i=nnt,nct
5640         if (itype(i,1).ne.10) then
5641           ii=ii+1
5642           do j=1,3
5643             ind=ind+1
5644             ind1=0
5645             jj=0
5646             do k=nnt,nct-1
5647               jj=jj+1
5648               do l=1,3
5649                 ind1=ind1+1
5650                 if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
5651               enddo
5652             enddo
5653             do k=nnt,nct
5654               if (itype(k,1).ne.10) then
5655                 jj=jj+1
5656                 do l=1,3
5657                   ind1=ind1+1
5658                   if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1)
5659                 enddo
5660               endif
5661             enddo
5662           enddo
5663         endif
5664       enddo
5665       if (lprn1) then
5666         write (iout,*) "Matrix GGinv"
5667         call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv)
5668       endif
5669       not_done=.true.
5670       iter=0
5671       do while (not_done)
5672       iter=iter+1
5673       if (iter.gt.max_rattle) then
5674         write (iout,*) "Error - too many iterations in RATTLE."
5675         stop
5676       endif
5677 ! Calculate the matrix C = GG**(-1) dC_old o dC
5678       ind1=0
5679       do i=nnt,nct-1
5680         ind1=ind1+1
5681         do j=1,3
5682           dC_uncor(j,ind1)=dC(j,i)
5683         enddo
5684       enddo
5685       do i=nnt,nct
5686         if (itype(i,1).ne.10) then
5687           ind1=ind1+1
5688           do j=1,3
5689             dC_uncor(j,ind1)=dC(j,i+nres)
5690           enddo
5691         endif
5692       enddo
5693       do i=1,nbond
5694         ind=0
5695         do k=nnt,nct-1
5696           ind=ind+1
5697           do j=1,3
5698             gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k)
5699           enddo
5700         enddo
5701         do k=nnt,nct
5702           if (itype(k,1).ne.10) then
5703             ind=ind+1
5704             do j=1,3
5705               gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres)
5706             enddo
5707           endif
5708         enddo
5709       enddo
5710 ! Calculate deviations from standard virtual-bond lengths
5711       ind=0
5712       do i=nnt,nct-1
5713         ind=ind+1
5714         x(ind)=vbld(i+1)**2-vbl**2
5715       enddo
5716       do i=nnt,nct
5717         if (itype(i,1).ne.10) then
5718           ind=ind+1
5719           x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i,1))**2
5720         endif
5721       enddo
5722       if (lprn) then
5723         write (iout,*) "Coordinates and violations"
5724         do i=1,nbond
5725           write(iout,'(i5,3f10.5,5x,e15.5)') &
5726            i,(dC_uncor(j,i),j=1,3),x(i)
5727         enddo
5728         write (iout,*) "Velocities and violations"
5729         ind=0
5730         do i=nnt,nct-1
5731           ind=ind+1
5732           write (iout,'(2i5,3f10.5,5x,e15.5)') &
5733            i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i))
5734         enddo
5735         do i=nnt,nct
5736           if (itype(i,1).ne.10) then
5737             ind=ind+1
5738             write (iout,'(2i5,3f10.5,5x,e15.5)') &
5739              i+nres,ind,(d_t(j,i+nres),j=1,3),&
5740              scalar(d_t(1,i+nres),dC_old(1,i+nres))
5741           endif
5742         enddo
5743         write (iout,*) "gdc"
5744         do i=1,nbond
5745           write (iout,*) "i",i
5746           do j=1,nbond
5747             write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
5748           enddo
5749         enddo
5750       endif
5751       xmax=dabs(x(1))
5752       do i=2,nbond
5753         if (dabs(x(i)).gt.xmax) then
5754           xmax=dabs(x(i))
5755         endif
5756       enddo
5757       if (xmax.lt.tol_rattle) then
5758         not_done=.false.
5759         goto 100
5760       endif
5761 ! Calculate the matrix of the system of equations
5762       do i=1,nbond
5763         do j=1,nbond
5764           Cmat(i,j)=0.0d0
5765           do k=1,3
5766             Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j)
5767           enddo
5768         enddo
5769       enddo
5770       if (lprn1) then
5771         write (iout,*) "Matrix Cmat"
5772         call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
5773       endif
5774       call gauss(Cmat,X,MAXRES2,nbond,1,*10)
5775 ! Add constraint term to positions
5776       ind=0
5777       do i=nnt,nct-1
5778         ind=ind+1
5779         do j=1,3
5780           xx=0.0d0
5781           do ii=1,nbond
5782             xx = xx+x(ii)*gdc(j,ind,ii)
5783           enddo
5784           xx=-0.5d0*xx
5785           d_t(j,i)=d_t(j,i)+xx/d_time
5786           dC(j,i)=dC(j,i)+xx
5787         enddo
5788       enddo
5789       do i=nnt,nct
5790         if (itype(i,1).ne.10) then
5791           ind=ind+1
5792           do j=1,3
5793             xx=0.0d0
5794             do ii=1,nbond
5795               xx = xx+x(ii)*gdc(j,ind,ii)
5796             enddo
5797             xx=-0.5d0*xx
5798             d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time
5799             dC(j,i+nres)=dC(j,i+nres)+xx
5800           enddo
5801         endif
5802       enddo
5803 ! Rebuild the chain using the new coordinates
5804       call chainbuild_cart
5805       if (lprn) then
5806         write (iout,*) "New coordinates, Lagrange multipliers,",&
5807         " and differences between actual and standard bond lengths"
5808         ind=0
5809         do i=nnt,nct-1
5810           ind=ind+1
5811           xx=vbld(i+1)**2-vbl**2
5812           write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
5813               i,(dC(j,i),j=1,3),x(ind),xx
5814         enddo
5815         do i=nnt,nct
5816           if (itype(i,1).ne.10) then
5817             ind=ind+1
5818             xx=vbld(i+nres)**2-vbldsc0(1,itype(i,1))**2
5819             write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') &
5820              i,(dC(j,i+nres),j=1,3),x(ind),xx
5821           endif
5822         enddo
5823         write (iout,*) "Velocities and violations"
5824         ind=0
5825         do i=nnt,nct-1
5826           ind=ind+1
5827           write (iout,'(2i5,3f10.5,5x,e15.5)') &
5828            i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
5829         enddo
5830         do i=nnt,nct
5831           if (itype(i,1).ne.10) then
5832             ind=ind+1
5833             write (iout,'(2i5,3f10.5,5x,e15.5)') &
5834              i+nres,ind,(d_t_new(j,i+nres),j=1,3),&
5835              scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
5836           endif
5837         enddo
5838       endif
5839       enddo
5840   100 continue
5841       return
5842    10 write (iout,*) "Error - singularity in solving the system",&
5843        " of equations for Lagrange multipliers."
5844       stop
5845 #else
5846       write (iout,*) &
5847        "RATTLE inactive; use -DRATTLE option at compile time"
5848       stop
5849 #endif
5850       end subroutine rattle_brown
5851 !-----------------------------------------------------------------------------
5852 ! stochfric.F
5853 !-----------------------------------------------------------------------------
5854       subroutine friction_force
5855
5856       use energy_data
5857       use REMD_data
5858       use comm_syfek
5859 !      implicit real*8 (a-h,o-z)
5860 !      include 'DIMENSIONS'
5861 !      include 'COMMON.VAR'
5862 !      include 'COMMON.CHAIN'
5863 !      include 'COMMON.DERIV'
5864 !      include 'COMMON.GEO'
5865 !      include 'COMMON.LOCAL'
5866 !      include 'COMMON.INTERACT'
5867 !      include 'COMMON.MD'
5868 !#ifndef LANG0
5869 !      include 'COMMON.LANGEVIN'
5870 !#else
5871 !      include 'COMMON.LANGEVIN.lang0'
5872 !#endif
5873 !      include 'COMMON.IOUNITS'
5874 !el      real(kind=8),dimension(6*nres) :: gamvec       !(MAXRES6) maxres6=6*maxres
5875 !el      common /syfek/ gamvec
5876 #ifdef FIVEDIAG
5877       integer iposc,ichain,n,innt,inct
5878       double precision rs(nres*2)
5879       real(kind=8) ::v_work(3,6*nres),vvec(2*nres)
5880 #else
5881       real(kind=8) :: v_work(6*nres)
5882 #endif
5883
5884       real(kind=8) :: vv(3),vvtot(3,nres)!,v_work(6*nres) !,&
5885 !el       ginvfric(2*nres,2*nres)       !maxres2=2*maxres
5886 !el      common /przechowalnia/ ginvfric
5887
5888       logical :: lprn, checkmode
5889       integer :: i,j,ind,k,nres2,nres6,mnum
5890       nres2=2*nres
5891       nres6=6*nres
5892       lprn=.false.
5893       checkmode=.false.
5894 !      if (large) lprn=.true.
5895 !      if (large) checkmode=.true.
5896 #ifdef FIVEDIAG
5897 !c Here accelerations due to friction forces are computed right after forces.
5898       d_t_work(:6*nres)=0.0d0
5899       do j=1,3
5900         v_work(j,1)=d_t(j,0)
5901         v_work(j,nnt)=d_t(j,0)
5902       enddo
5903       do i=nnt+1,nct
5904         do j=1,3
5905           v_work(j,i)=v_work(j,i-1)+d_t(j,i-1)
5906         enddo
5907       enddo
5908       do i=nnt,nct
5909         mnum=molnum(i)
5910         if (iabs(itype(i,1)).ne.10 .and. iabs(itype(i,mnum)).ne.ntyp1_molec(mnum).and.mnum.lt.3) then
5911           do j=1,3
5912             v_work(j,i+nres)=v_work(j,i)+d_t(j,i+nres)
5913           enddo
5914         endif
5915       enddo
5916 #ifdef DEBUG
5917       write (iout,*) "v_work"
5918       do i=1,2*nres
5919         write (iout,'(i5,3f10.5)') i,(v_work(j,i),j=1,3)
5920       enddo
5921 #endif
5922       do j=1,3
5923         ind=0
5924         do ichain=1,nchain
5925           n=dimen_chain(ichain)
5926           iposc=iposd_chain(ichain)
5927 !c          write (iout,*) "friction_force j",j," ichain",ichain,
5928 !c     &       " n",n," iposc",iposc,iposc+n-1
5929           innt=chain_border(1,ichain)
5930           inct=chain_border(2,ichain)
5931 !c diagnostics
5932 !c          innt=chain_border(1,1)
5933 !c          inct=chain_border(2,1)
5934           do i=innt,inct
5935             vvec(ind+1)=v_work(j,i)
5936             ind=ind+1
5937 !            if (iabs(itype(i)).ne.10) then
5938         if (iabs(itype(i,1)).ne.10 .and. iabs(itype(i,mnum)).ne.ntyp1_molec(mnum).and.mnum.lt.3) then
5939               vvec(ind+1)=v_work(j,i+nres)
5940               ind=ind+1
5941             endif
5942           enddo
5943 #ifdef DEBUG
5944           write (iout,*) "vvec ind",ind," n",n
5945           write (iout,'(f10.5)') (vvec(i),i=iposc,ind)
5946 #endif
5947 !c          write (iout,*) "chain",i," ind",ind," n",n
5948 #ifdef TIMING
5949 #ifdef MPI
5950           time01=MPI_Wtime()
5951 #else
5952           time01=tcpu()
5953 #endif
5954 #endif
5955 !          if (large) print *,"before fivediagmult"
5956           call fivediagmult(n,DMfric(iposc),DU1fric(iposc),&
5957           DU2fric(iposc),vvec(iposc),rs)
5958 !          if (large) print *,"after fivediagmult"
5959
5960 #ifdef TIMING
5961 #ifdef MPI
5962           time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01
5963 #else
5964           time_fricmatmult=time_fricmatmult+tcpu()-time01
5965 #endif
5966 #endif
5967 #ifdef DEBUG
5968           write (iout,*) "rs"
5969           write (iout,'(f10.5)') (rs(i),i=1,n)
5970 #endif
5971           do i=iposc,iposc+n-1
5972 !           write (iout,*) "ichain",ichain," i",i," j",j,&
5973 !            "index",3*(i-1)+j,"rs",rs(i-iposc+1)
5974             fric_work(3*(i-1)+j)=-rs(i-iposc+1)
5975           enddo
5976         enddo
5977       enddo
5978 #ifdef DEBUG
5979       write (iout,*) "Vector fric_work dimen3",dimen3
5980       write (iout,'(3f10.5)') (fric_work(j),j=1,dimen3)
5981 #endif
5982 #else
5983       if(.not.allocated(gamvec)) allocate(gamvec(nres6)) !(MAXRES6)
5984       if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres
5985       do i=0,nres2
5986         do j=1,3
5987           friction(j,i)=0.0d0
5988         enddo
5989       enddo
5990
5991       do j=1,3
5992         d_t_work(j)=d_t(j,0)
5993       enddo
5994       ind=3
5995       do i=nnt,nct-1
5996         do j=1,3
5997           d_t_work(ind+j)=d_t(j,i)
5998         enddo
5999         ind=ind+3
6000       enddo
6001       do i=nnt,nct
6002         mnum=molnum(i)
6003         if ((itype(i,1).ne.10).and.(itype(i,mnum).ne.ntyp1_molec(mnum))&
6004         .and.(mnum.lt.4)) then
6005           do j=1,3
6006             d_t_work(ind+j)=d_t(j,i+nres)
6007           enddo
6008           ind=ind+3
6009         endif
6010       enddo
6011
6012       call fricmat_mult(d_t_work,fric_work)
6013
6014       if (.not.checkmode) return
6015
6016       if (lprn) then
6017         write (iout,*) "d_t_work and fric_work"
6018         do i=1,3*dimen
6019           write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i)
6020         enddo
6021       endif
6022       do j=1,3
6023         friction(j,0)=fric_work(j)
6024       enddo
6025       ind=3
6026       do i=nnt,nct-1
6027         do j=1,3
6028           friction(j,i)=fric_work(ind+j)
6029         enddo
6030         ind=ind+3
6031       enddo
6032       do i=nnt,nct
6033         mnum=molnum(i)
6034         if ((itype(i,1).ne.10).and.(itype(i,mnum).ne.ntyp1_molec(mnum))&
6035         .and.(mnum.lt.4)) then
6036 !        if ((itype(i,1).ne.10).and.(itype(i,1).ne.ntyp1)) then
6037           do j=1,3
6038             friction(j,i+nres)=fric_work(ind+j)
6039           enddo
6040           ind=ind+3
6041         endif
6042       enddo
6043       if (lprn) then
6044         write(iout,*) "Friction backbone"
6045         do i=0,nct-1
6046           write(iout,'(i5,3e15.5,5x,3e15.5)') &
6047            i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3)
6048         enddo
6049         write(iout,*) "Friction side chain"
6050         do i=nnt,nct
6051           write(iout,'(i5,3e15.5,5x,3e15.5)') &
6052            i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3)
6053         enddo
6054       endif
6055       if (lprn) then
6056         do j=1,3
6057           vv(j)=d_t(j,0)
6058         enddo
6059         do i=nnt,nct
6060           do j=1,3
6061             vvtot(j,i)=vv(j)+0.5d0*d_t(j,i)
6062             vvtot(j,i+nres)=vv(j)+d_t(j,i+nres)
6063             vv(j)=vv(j)+d_t(j,i)
6064           enddo
6065         enddo
6066         write (iout,*) "vvtot backbone and sidechain"
6067         do i=nnt,nct
6068           write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3),&
6069            (vvtot(j,i+nres),j=1,3)
6070         enddo
6071         ind=0
6072         do i=nnt,nct-1
6073           do j=1,3
6074             v_work(ind+j)=vvtot(j,i)
6075           enddo
6076           ind=ind+3
6077         enddo
6078         do i=nnt,nct
6079           do j=1,3
6080             v_work(ind+j)=vvtot(j,i+nres)
6081           enddo
6082           ind=ind+3
6083         enddo
6084         write (iout,*) "v_work gamvec and site-based friction forces"
6085         do i=1,dimen1
6086           write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i),&
6087             gamvec(i)*v_work(i)
6088         enddo
6089 !        do i=1,dimen
6090 !          fric_work1(i)=0.0d0
6091 !          do j=1,dimen1
6092 !            fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j)
6093 !          enddo
6094 !        enddo
6095 !        write (iout,*) "fric_work and fric_work1"
6096 !        do i=1,dimen
6097 !          write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i)
6098 !        enddo
6099         do i=1,dimen
6100           do j=1,dimen
6101             ginvfric(i,j)=0.0d0
6102             do k=1,dimen
6103               ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j)
6104             enddo
6105           enddo
6106         enddo
6107         write (iout,*) "ginvfric"
6108         do i=1,dimen
6109           write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen)
6110         enddo
6111         write (iout,*) "symmetry check"
6112         do i=1,dimen
6113           do j=1,i-1
6114             write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i)
6115           enddo
6116         enddo
6117       endif
6118 #endif
6119       return
6120       end subroutine friction_force
6121 !-----------------------------------------------------------------------------
6122       subroutine setup_fricmat
6123
6124 !     use MPI
6125       use energy_data
6126       use control_data, only:time_Bcast
6127       use control, only:tcpu
6128       use comm_syfek
6129 !      implicit real*8 (a-h,o-z)
6130 #ifdef MPI
6131       use MPI_data
6132       include 'mpif.h'
6133       real(kind=8) :: time00
6134 #endif
6135 !      include 'DIMENSIONS'
6136 !      include 'COMMON.VAR'
6137 !      include 'COMMON.CHAIN'
6138 !      include 'COMMON.DERIV'
6139 !      include 'COMMON.GEO'
6140 !      include 'COMMON.LOCAL'
6141 !      include 'COMMON.INTERACT'
6142 !      include 'COMMON.MD'
6143 !      include 'COMMON.SETUP'
6144 !      include 'COMMON.TIME1'
6145 !      integer licznik /0/
6146 !      save licznik
6147 !#ifndef LANG0
6148 !      include 'COMMON.LANGEVIN'
6149 !#else
6150 !      include 'COMMON.LANGEVIN.lang0'
6151 !#endif
6152 !      include 'COMMON.IOUNITS'
6153       integer :: IERROR
6154       integer :: i,j,ind,ind1,m,ichain,innt,inct
6155       logical :: lprn = .false.
6156       real(kind=8) :: dtdi !el ,gamvec(2*nres)
6157 !el      real(kind=8),dimension(2*nres,2*nres) :: ginvfric,fcopy
6158 !      real(kind=8),allocatable,dimension(:,:) :: fcopy
6159 !el      real(kind=8),dimension(2*nres*(2*nres+1)/2) :: Ghalf   !(mmaxres2) (mmaxres2=(maxres2*(maxres2+1)/2))
6160 !el      common /syfek/ gamvec
6161       real(kind=8) :: work(8*2*nres)
6162       integer :: iwork(2*nres)
6163 !el      common /przechowalnia/ ginvfric,Ghalf,fcopy
6164       integer :: ii,iti,k,l,nzero,nres2,nres6,ierr,mnum
6165       nres2=2*nres
6166       nres6=6*nres
6167 #ifdef MPI
6168 #ifndef FIVEDIAG
6169       if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2))
6170        if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) !maxres2=2*maxres
6171       if (fg_rank.ne.king) goto 10
6172 #endif
6173 #endif
6174 !      nres2=2*nres
6175 !      nres6=6*nres
6176
6177       if(.not.allocated(gamvec)) allocate(gamvec(nres2)) !(MAXRES2)
6178 #ifndef FIVEDIAG
6179       if(.not.allocated(ginvfric)) allocate(ginvfric(nres2,nres2)) !maxres2=2*maxres
6180        if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2)) !maxres2=2*maxres
6181 !el      allocate(fcopy(nres2,nres2)) !maxres2=2*maxres
6182       if(.not.allocated(Ghalf)) allocate(Ghalf(nres2*(nres2+1)/2)) !maxres2=2*maxres
6183
6184       if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2))
6185 #endif
6186 #ifdef FIVEDIAG
6187       if (.not.allocated(DMfric)) allocate(DMfric(nres2))
6188       if (.not.allocated(DU1fric)) allocate(DU1fric(nres2))
6189       if (.not.allocated(DU2fric)) allocate(DU2fric(nres2))
6190 !  Load the friction coefficients corresponding to peptide groups
6191       ind1=0
6192       do i=nnt,nct-1
6193         mnum=molnum(i)
6194         ind1=ind1+1
6195         gamvec(ind1)=gamp(mnum)
6196       enddo
6197 !HERE TEST
6198       if (molnum(nct).eq.5) then
6199         mnum=molnum(i)
6200         ind1=ind1+1
6201         gamvec(ind1)=gamp(mnum)
6202       endif
6203 !  Load the friction coefficients corresponding to side chains
6204       m=nct-nnt
6205       ind=0
6206       do j=1,2
6207       gamsc(ntyp1_molec(j),j)=1.0d0
6208       enddo
6209       do i=nnt,nct
6210         mnum=molnum(i)
6211         ind=ind+1
6212         ii = ind+m
6213         iti=itype(i,mnum)
6214         gamvec(ii)=gamsc(iabs(iti),mnum)
6215       enddo
6216       if (surfarea) call sdarea(gamvec)
6217       DMfric=0.0d0
6218       DU1fric=0.0d0
6219       DU2fric=0.0d0
6220       ind=1
6221       do ichain=1,nchain
6222         innt=chain_border(1,ichain)
6223         inct=chain_border(2,ichain)
6224 !c        write (iout,*) "ichain",ichain," innt",innt," inct",inct
6225 !c DMfric part
6226         mnum=molnum(innt)
6227         DMfric(ind)=gamvec(innt-nnt+1)/4
6228         if (iabs(itype(innt,1)).eq.10.or.mnum.gt.2) then
6229           DMfric(ind)=DMfric(ind)+gamvec(m+innt-nnt+1)
6230           ind=ind+1
6231         else
6232           DMfric(ind+1)=gamvec(m+innt-nnt+1)
6233           ind=ind+2
6234         endif
6235 !c        write (iout,*) "DMfric init ind",ind
6236 !c DMfric
6237         do i=innt+1,inct-1
6238            mnum=molnum(i)
6239           DMfric(ind)=gamvec(i-nnt+1)/2
6240           if (iabs(itype(i,1)).eq.10.or.mnum.gt.2) then
6241             DMfric(ind)=DMfric(ind)+gamvec(m+i-nnt+1)
6242             ind=ind+1
6243           else
6244             DMfric(ind+1)=gamvec(m+i-nnt+1)
6245             ind=ind+2
6246           endif
6247         enddo
6248 !c        write (iout,*) "DMfric endloop ind",ind
6249         if (inct.gt.innt) then
6250           DMfric(ind)=gamvec(inct-1-nnt+1)/4
6251           mnum=molnum(inct)
6252           if (iabs(itype(inct,1)).eq.10.or.mnum.gt.2) then
6253             DMfric(ind)=DMfric(ind)+gamvec(inct+m-nnt+1)
6254             ind=ind+1
6255           else
6256             DMfric(ind+1)=gamvec(inct+m-nnt+1)
6257             ind=ind+2
6258           endif
6259         endif
6260 !c        write (iout,*) "DMfric end ind",ind
6261       enddo
6262 !c DU1fric part
6263       do ichain=1,nchain
6264       mnum=molnum(i)
6265
6266         ind=iposd_chain(ichain)
6267         innt=chain_border(1,ichain)
6268         inct=chain_border(2,ichain)
6269         do i=innt,inct
6270           if (iabs(itype(i,1)).ne.10.and.mnum.le.2) then
6271             ind=ind+2
6272           else
6273             DU1fric(ind)=gamvec(i-nnt+1)/4
6274             ind=ind+1
6275           endif
6276         enddo
6277       enddo
6278 !c DU2fric part
6279       do ichain=1,nchain
6280       mnum=molnum(i)
6281         ind=iposd_chain(ichain)
6282         innt=chain_border(1,ichain)
6283         inct=chain_border(2,ichain)
6284         do i=innt,inct-1
6285           if (iabs(itype(i,1)).ne.10.and.mnum.le.2) then
6286             DU2fric(ind)=gamvec(i-nnt+1)/4
6287             DU2fric(ind+1)=0.0d0
6288             ind=ind+2
6289           else
6290             DU2fric(ind)=0.0d0
6291             ind=ind+1
6292           endif
6293         enddo
6294       enddo
6295       if (lprn) then
6296       write(iout,*)"The upper part of the five-diagonal friction matrix"
6297       do ichain=1,nchain
6298         write (iout,'(a,i5)') 'Chain',ichain
6299         innt=iposd_chain(ichain)
6300         inct=iposd_chain(ichain)+dimen_chain(ichain)-1
6301         do i=innt,inct
6302           if (i.lt.inct-1) then
6303             write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i),DU1fric(i),&
6304             DU2fric(i)
6305           else if (i.eq.inct-1) then
6306             write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i),DU1fric(i)
6307           else
6308             write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i)
6309           endif
6310         enddo
6311       enddo
6312       endif
6313    10 continue
6314 #else
6315
6316
6317 !  Zeroing out fricmat
6318       do i=1,dimen
6319         do j=1,dimen
6320           fricmat(i,j)=0.0d0
6321         enddo
6322       enddo
6323 !  Load the friction coefficients corresponding to peptide groups
6324       ind1=0
6325       do i=nnt,nct-1
6326         mnum=molnum(i)
6327         ind1=ind1+1
6328         gamvec(ind1)=gamp(mnum)
6329       enddo
6330 !HERE TEST
6331       if (molnum(nct).eq.5) then
6332         mnum=molnum(i)
6333         ind1=ind1+1
6334         gamvec(ind1)=gamp(mnum)
6335       endif
6336 !  Load the friction coefficients corresponding to side chains
6337       m=nct-nnt
6338       ind=0
6339       do j=1,2
6340       gamsc(ntyp1_molec(j),j)=1.0d0
6341       enddo
6342       do i=nnt,nct
6343         mnum=molnum(i)
6344         ind=ind+1
6345         ii = ind+m
6346         iti=itype(i,mnum)
6347         gamvec(ii)=gamsc(iabs(iti),mnum)
6348       enddo
6349       if (surfarea) call sdarea(gamvec)
6350 !      if (lprn) then
6351 !        write (iout,*) "Matrix A and vector gamma"
6352 !        do i=1,dimen1
6353 !          write (iout,'(i2,$)') i
6354 !          do j=1,dimen
6355 !            write (iout,'(f4.1,$)') A(i,j)
6356 !          enddo
6357 !          write (iout,'(f8.3)') gamvec(i)
6358 !        enddo
6359 !      endif
6360       if (lprn) then
6361         write (iout,*) "Vector gamvec"
6362         do i=1,dimen1
6363           write (iout,'(i5,f10.5)') i, gamvec(i)
6364         enddo
6365       endif
6366
6367 ! The friction matrix
6368       do k=1,dimen
6369        do i=1,dimen
6370          dtdi=0.0d0
6371          do j=1,dimen1
6372            dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j)
6373          enddo
6374          fricmat(k,i)=dtdi
6375        enddo
6376       enddo
6377
6378       if (lprn) then
6379         write (iout,'(//a)') "Matrix fricmat"
6380         call matout2(dimen,dimen,nres2,nres2,fricmat)
6381       endif
6382       if (lang.eq.2 .or. lang.eq.3) then
6383 ! Mass-scale the friction matrix if non-direct integration will be performed
6384       do i=1,dimen
6385         do j=1,dimen
6386           Ginvfric(i,j)=0.0d0
6387           do k=1,dimen
6388             do l=1,dimen
6389               Ginvfric(i,j)=Ginvfric(i,j)+ &
6390                 Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l)
6391             enddo
6392           enddo
6393         enddo
6394       enddo
6395 ! Diagonalize the friction matrix
6396       ind=0
6397       do i=1,dimen
6398         do j=1,i
6399           ind=ind+1
6400           Ghalf(ind)=Ginvfric(i,j)
6401         enddo
6402       enddo
6403       call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,&
6404         ierr,iwork)
6405       if (lprn) then
6406         write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",&
6407           " mass-scaled friction matrix"
6408         call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam)
6409       endif
6410 ! Precompute matrices for tinker stochastic integrator
6411 #ifndef LANG0
6412       do i=1,dimen
6413         do j=1,dimen
6414           mt1(i,j)=0.0d0
6415           mt2(i,j)=0.0d0
6416           do k=1,dimen
6417             mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j)
6418             mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j)
6419           enddo
6420           mt3(j,i)=mt1(i,j)
6421         enddo
6422       enddo
6423 #endif
6424       else if (lang.eq.4) then
6425 ! Diagonalize the friction matrix
6426       ind=0
6427       do i=1,dimen
6428         do j=1,i
6429           ind=ind+1
6430           Ghalf(ind)=fricmat(i,j)
6431         enddo
6432       enddo
6433       call gldiag(nres2,dimen,dimen,Ghalf,work,fricgam,fricvec,&
6434         ierr,iwork)
6435       if (lprn) then
6436         write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",&
6437           " friction matrix"
6438         call eigout(dimen,dimen,nres2,nres2,fricvec,fricgam)
6439       endif
6440 ! Determine the number of zero eigenvalues of the friction matrix
6441       nzero=max0(dimen-dimen1,0)
6442 !      do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen)
6443 !        nzero=nzero+1
6444 !      enddo
6445       write (iout,*) "Number of zero eigenvalues:",nzero
6446       do i=1,dimen
6447         do j=1,dimen
6448           fricmat(i,j)=0.0d0
6449           do k=nzero+1,dimen
6450             fricmat(i,j)=fricmat(i,j) &
6451               +fricvec(i,k)*fricvec(j,k)/fricgam(k)
6452           enddo
6453         enddo
6454       enddo
6455       if (lprn) then
6456         write (iout,'(//a)') "Generalized inverse of fricmat"
6457         call matout(dimen,dimen,nres6,nres6,fricmat)
6458       endif
6459       endif
6460 #ifdef MPI
6461   10  continue
6462       if (nfgtasks.gt.1) then
6463         if (fg_rank.eq.0) then
6464 ! The matching BROADCAST for fg processors is called in ERGASTULUM
6465 #ifdef MPI
6466           time00=MPI_Wtime()
6467 #else
6468           time00=tcpu()
6469 #endif
6470           call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR)
6471 #ifdef MPI
6472           time_Bcast=time_Bcast+MPI_Wtime()-time00
6473 #else
6474           time_Bcast=time_Bcast+tcpu()-time00
6475 #endif
6476 !          print *,"Processor",myrank,
6477 !     &       " BROADCAST iorder in SETUP_FRICMAT"
6478         endif
6479 !       licznik=licznik+1
6480         write (iout,*) "setup_fricmat licznik"!,licznik !sp
6481 #ifdef MPI
6482         time00=MPI_Wtime()
6483 #else
6484         time00=tcpu()
6485 #endif
6486 ! Scatter the friction matrix
6487         call MPI_Scatterv(fricmat(1,1),nginv_counts(0),&
6488           nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1),&
6489           myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
6490 #ifdef TIMING
6491 #ifdef MPI
6492         time_scatter=time_scatter+MPI_Wtime()-time00
6493         time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00
6494 #else
6495         time_scatter=time_scatter+tcpu()-time00
6496         time_scatter_fmat=time_scatter_fmat+tcpu()-time00
6497 #endif
6498 #endif
6499         do i=1,dimen
6500           do j=1,2*my_ng_count
6501             fricmat(j,i)=fcopy(i,j)
6502           enddo
6503         enddo
6504 !        write (iout,*) "My chunk of fricmat"
6505 !        call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy)
6506       endif
6507 #endif
6508 #endif
6509       return
6510       end subroutine setup_fricmat
6511 !-----------------------------------------------------------------------------
6512       subroutine stochastic_force(stochforcvec)
6513
6514       use energy_data
6515       use random, only:anorm_distr
6516 !      implicit real*8 (a-h,o-z)
6517 !      include 'DIMENSIONS'
6518       use control, only: tcpu
6519       use control_data
6520 #ifdef MPI
6521       include 'mpif.h'
6522 #endif
6523 !      include 'COMMON.VAR'
6524 !      include 'COMMON.CHAIN'
6525 !      include 'COMMON.DERIV'
6526 !      include 'COMMON.GEO'
6527 !      include 'COMMON.LOCAL'
6528 !      include 'COMMON.INTERACT'
6529 !      include 'COMMON.MD'
6530 !      include 'COMMON.TIME1'
6531 !#ifndef LANG0
6532 !      include 'COMMON.LANGEVIN'
6533 !#else
6534 !      include 'COMMON.LANGEVIN.lang0'
6535 !#endif
6536 !      include 'COMMON.IOUNITS'
6537
6538       real(kind=8) :: x,sig,lowb,highb
6539       real(kind=8) :: ff(3),force(3,0:2*nres),zeta2,lowb2
6540       real(kind=8) :: highb2,sig2,forcvec(6*nres),stochforcvec(6*nres)
6541       real(kind=8) :: time00
6542       logical :: lprn = .false.
6543       integer :: i,j,ind,mnum
6544 #ifdef FIVEDIAG
6545       integer ichain,innt,inct,iposc
6546 #endif
6547
6548       do i=0,2*nres
6549         do j=1,3
6550           stochforc(j,i)=0.0d0
6551         enddo
6552       enddo
6553       x=0.0d0
6554
6555 #ifdef MPI
6556       time00=MPI_Wtime()
6557 #else
6558       time00=tcpu()
6559 #endif
6560 ! Compute the stochastic forces acting on bodies. Store in force.
6561       do i=nnt,nct-1
6562         sig=stdforcp(i)
6563         lowb=-5*sig
6564         highb=5*sig
6565         do j=1,3
6566           force(j,i)=anorm_distr(x,sig,lowb,highb)
6567         enddo
6568       enddo
6569       do i=nnt,nct
6570         sig2=stdforcsc(i)
6571         lowb2=-5*sig2
6572         highb2=5*sig2
6573         do j=1,3
6574           force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2)
6575         enddo
6576       enddo
6577 #ifdef MPI
6578       time_fsample=time_fsample+MPI_Wtime()-time00
6579 #else
6580       time_fsample=time_fsample+tcpu()-time00
6581 #endif
6582 #ifdef FIVEDIAG
6583       ind=0
6584       do ichain=1,nchain
6585         innt=chain_border(1,ichain)
6586         inct=chain_border(2,ichain)
6587         iposc=iposd_chain(ichain)
6588 !c for debugging only
6589 !c        innt=chain_border(1,1)
6590 !c        inct=chain_border(2,1)
6591 !c        iposc=iposd_chain(1)
6592 !c        write (iout,*)"stochastic_force ichain=",ichain," innt",innt,
6593 !c     &    " inct",inct," iposc",iposc
6594         do j=1,3
6595           stochforcvec(ind+j)=0.5d0*force(j,innt)
6596         enddo
6597         if (iabs(itype(innt,molnum(innt))).eq.10.or.molnum(innt).ge.3) then
6598           do j=1,3
6599             stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,innt+nres)
6600           enddo
6601           ind=ind+3
6602         else
6603           ind=ind+3
6604           do j=1,3
6605             stochforcvec(ind+j)=force(j,innt+nres)
6606           enddo
6607           ind=ind+3
6608         endif
6609         do i=innt+1,inct-1
6610           do j=1,3
6611             stochforcvec(ind+j)=0.5d0*(force(j,i)+force(j,i-1))
6612           enddo
6613           if (iabs(itype(i,1).eq.10).or.molnum(i).ge.3) then
6614             do j=1,3
6615               stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,i+nres)
6616             enddo
6617             ind=ind+3
6618           else
6619             ind=ind+3
6620             do j=1,3
6621               stochforcvec(ind+j)=force(j,i+nres)
6622             enddo
6623             ind=ind+3
6624           endif
6625         enddo
6626         do j=1,3
6627           stochforcvec(ind+j)=0.5d0*force(j,inct-1)
6628         enddo
6629         if (iabs(itype(inct,molnum(inct))).eq.10.or.molnum(inct).ge.3) then
6630           do j=1,3
6631             stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,inct+nres)
6632           enddo
6633           ind=ind+3
6634         else
6635           ind=ind+3
6636           do j=1,3
6637             stochforcvec(ind+j)=force(j,inct+nres)
6638           enddo
6639           ind=ind+3
6640         endif
6641 !c        write (iout,*) "chain",ichain," ind",ind
6642       enddo
6643 #ifdef DEBUG
6644       write (iout,*) "stochforcvec"
6645       write (iout,'(3f10.5)') (stochforcvec(j),j=1,ind)
6646 #endif
6647 #else
6648 ! Compute the stochastic forces acting on virtual-bond vectors.
6649       do j=1,3
6650         ff(j)=0.0d0
6651       enddo
6652       do i=nct-1,nnt,-1
6653         do j=1,3
6654           stochforc(j,i)=ff(j)+0.5d0*force(j,i)
6655         enddo
6656         do j=1,3
6657           ff(j)=ff(j)+force(j,i)
6658         enddo
6659 !        if (itype(i+1,1).ne.ntyp1) then
6660          mnum=molnum(i)
6661          if (itype(i+1,mnum).ne.ntyp1_molec(mnum)) then
6662           do j=1,3
6663             stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1)
6664             ff(j)=ff(j)+force(j,i+nres+1)
6665           enddo
6666         endif
6667       enddo
6668       do j=1,3
6669         stochforc(j,0)=ff(j)+force(j,nnt+nres)
6670       enddo
6671       do i=nnt,nct
6672         mnum=molnum(i)
6673         if ((itype(i,1).ne.10).and.(itype(i,mnum).ne.ntyp1_molec(mnum))&
6674         .and.(mnum.lt.4)) then
6675 !        if ((itype(i,1).ne.10).and.(itype(i,1).ne.ntyp1)) then
6676           do j=1,3
6677             stochforc(j,i+nres)=force(j,i+nres)
6678           enddo
6679         endif
6680       enddo
6681
6682       do j=1,3
6683         stochforcvec(j)=stochforc(j,0)
6684       enddo
6685       ind=3
6686       do i=nnt,nct-1
6687         do j=1,3
6688           stochforcvec(ind+j)=stochforc(j,i)
6689         enddo
6690         ind=ind+3
6691       enddo
6692       do i=nnt,nct
6693         mnum=molnum(i)
6694         if ((itype(i,1).ne.10).and.(itype(i,mnum).ne.ntyp1_molec(mnum))&
6695         .and.(mnum.lt.4)) then
6696 !        if ((itype(i,1).ne.10).and.(itype(i,1).ne.ntyp1)) then
6697           do j=1,3
6698             stochforcvec(ind+j)=stochforc(j,i+nres)
6699           enddo
6700           ind=ind+3
6701         endif
6702       enddo
6703       if (lprn) then
6704         write (iout,*) "stochforcvec"
6705         do i=1,3*dimen
6706           write(iout,'(i5,e15.5)') i,stochforcvec(i)
6707         enddo
6708         write(iout,*) "Stochastic forces backbone"
6709         do i=0,nct-1
6710           write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3)
6711         enddo
6712         write(iout,*) "Stochastic forces side chain"
6713         do i=nnt,nct
6714           write(iout,'(i5,3e15.5)') &
6715             i,(stochforc(j,i+nres),j=1,3)
6716         enddo
6717       endif
6718
6719       if (lprn) then
6720
6721       ind=0
6722       do i=nnt,nct-1
6723         write (iout,*) i,ind
6724         do j=1,3
6725           forcvec(ind+j)=force(j,i)
6726         enddo
6727         ind=ind+3
6728       enddo
6729       do i=nnt,nct
6730         write (iout,*) i,ind
6731         do j=1,3
6732           forcvec(j+ind)=force(j,i+nres)
6733         enddo
6734         ind=ind+3
6735       enddo
6736
6737       write (iout,*) "forcvec"
6738       ind=0
6739       do i=nnt,nct-1
6740         do j=1,3
6741           write (iout,'(2i3,2f10.5)') i,j,force(j,i),&
6742             forcvec(ind+j)
6743         enddo
6744         ind=ind+3
6745       enddo
6746       do i=nnt,nct
6747         do j=1,3
6748           write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres),&
6749            forcvec(ind+j)
6750         enddo
6751         ind=ind+3
6752       enddo
6753
6754       endif
6755 #endif
6756       return
6757       end subroutine stochastic_force
6758 !-----------------------------------------------------------------------------
6759       subroutine sdarea(gamvec)
6760 !
6761 ! Scale the friction coefficients according to solvent accessible surface areas
6762 ! Code adapted from TINKER
6763 ! AL 9/3/04
6764 !
6765       use energy_data
6766 !      implicit real*8 (a-h,o-z)
6767 !      include 'DIMENSIONS'
6768 !      include 'COMMON.CONTROL'
6769 !      include 'COMMON.VAR'
6770 !      include 'COMMON.MD'
6771 !#ifndef LANG0
6772 !      include 'COMMON.LANGEVIN'
6773 !#else
6774 !      include 'COMMON.LANGEVIN.lang0'
6775 !#endif
6776 !      include 'COMMON.CHAIN'
6777 !      include 'COMMON.DERIV'
6778 !      include 'COMMON.GEO'
6779 !      include 'COMMON.LOCAL'
6780 !      include 'COMMON.INTERACT'
6781 !      include 'COMMON.IOUNITS'
6782 !      include 'COMMON.NAMES'
6783       real(kind=8),dimension(2*nres) :: radius,gamvec   !(maxres2)
6784       real(kind=8),parameter :: twosix = 1.122462048309372981d0
6785       logical :: lprn = .false.
6786       real(kind=8) :: probe,area,ratio
6787       integer :: i,j,ind,iti,mnum
6788 !
6789 !     determine new friction coefficients every few SD steps
6790 !
6791 !     set the atomic radii to estimates of sigma values
6792 !
6793 !      print *,"Entered sdarea"
6794       probe = 0.0d0
6795
6796       do i=1,2*nres
6797         radius(i)=0.0d0
6798       enddo
6799 !  Load peptide group radii
6800       do i=nnt,nct-1
6801         mnum=molnum(i)
6802         radius(i)=pstok(mnum)
6803       enddo
6804 !  Load side chain radii
6805       do i=nnt,nct
6806         mnum=molnum(i)
6807         iti=itype(i,mnum)
6808         radius(i+nres)=restok(iti,mnum)
6809       enddo
6810 !      do i=1,2*nres
6811 !        write (iout,*) "i",i," radius",radius(i)
6812 !      enddo
6813       do i = 1, 2*nres
6814          radius(i) = radius(i) / twosix
6815          if (radius(i) .ne. 0.0d0)  radius(i) = radius(i) + probe
6816       end do
6817 !
6818 !     scale atomic friction coefficients by accessible area
6819 !
6820       if (lprn) write (iout,*) &
6821         "Original gammas, surface areas, scaling factors, new gammas, ",&
6822         "std's of stochastic forces"
6823       ind=0
6824       do i=nnt,nct-1
6825         if (radius(i).gt.0.0d0) then
6826           call surfatom (i,area,radius)
6827           ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1)
6828           if (lprn) write (iout,'(i5,3f10.5,$)') &
6829             i,gamvec(ind+1),area,ratio
6830           do j=1,3
6831             ind=ind+1
6832             gamvec(ind) = ratio * gamvec(ind)
6833           enddo
6834           mnum=molnum(i)
6835           stdforcp(i)=stdfp(mnum)*dsqrt(gamvec(ind))
6836           if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i)
6837         endif
6838       enddo
6839       do i=nnt,nct
6840         if (radius(i+nres).gt.0.0d0) then
6841           call surfatom (i+nres,area,radius)
6842           ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1)
6843           if (lprn) write (iout,'(i5,3f10.5,$)') &
6844             i,gamvec(ind+1),area,ratio
6845           do j=1,3
6846             ind=ind+1
6847             gamvec(ind) = ratio * gamvec(ind)
6848           enddo
6849           mnum=molnum(i)
6850           stdforcsc(i)=stdfsc(itype(i,mnum),mnum)*dsqrt(gamvec(ind))
6851           if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i)
6852         endif
6853       enddo
6854
6855       return
6856       end subroutine sdarea
6857 !-----------------------------------------------------------------------------
6858 ! surfatom.f
6859 !-----------------------------------------------------------------------------
6860 !
6861 !
6862 !     ###################################################
6863 !     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
6864 !     ##              All Rights Reserved              ##
6865 !     ###################################################
6866 !
6867 !     ################################################################
6868 !     ##                                                            ##
6869 !     ##  subroutine surfatom  --  exposed surface area of an atom  ##
6870 !     ##                                                            ##
6871 !     ################################################################
6872 !
6873 !
6874 !     "surfatom" performs an analytical computation of the surface
6875 !     area of a specified atom; a simplified version of "surface"
6876 !
6877 !     literature references:
6878 !
6879 !     T. J. Richmond, "Solvent Accessible Surface Area and
6880 !     Excluded Volume in Proteins", Journal of Molecular Biology,
6881 !     178, 63-89 (1984)
6882 !
6883 !     L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
6884 !     Applied to Molecular Dynamics of Proteins in Solution",
6885 !     Protein Science, 1, 227-235 (1992)
6886 !
6887 !     variables and parameters:
6888 !
6889 !     ir       number of atom for which area is desired
6890 !     area     accessible surface area of the atom
6891 !     radius   radii of each of the individual atoms
6892 !
6893 !
6894       subroutine surfatom(ir,area,radius)
6895
6896 !      implicit real*8 (a-h,o-z)
6897 !      include 'DIMENSIONS'
6898 !      include 'sizes.i'
6899 !      include 'COMMON.GEO'
6900 !      include 'COMMON.IOUNITS'
6901 !      integer :: nres,
6902       integer :: nsup,nstart_sup
6903 !      double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm
6904 !      common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2),
6905 !     & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2),
6906 !     & dc_work(MAXRES6),nres,nres0
6907       integer,parameter :: maxarc=300
6908       integer :: i,j,k,m
6909       integer :: ii,ib,jb
6910       integer :: io,ir
6911       integer :: mi,ni,narc
6912       integer :: key(maxarc)
6913       integer :: intag(maxarc)
6914       integer :: intag1(maxarc)
6915       real(kind=8) :: area,arcsum
6916       real(kind=8) :: arclen,exang
6917       real(kind=8) :: delta,delta2
6918       real(kind=8) :: eps,rmove
6919       real(kind=8) :: xr,yr,zr
6920       real(kind=8) :: rr,rrsq
6921       real(kind=8) :: rplus,rminus
6922       real(kind=8) :: axx,axy,axz
6923       real(kind=8) :: ayx,ayy
6924       real(kind=8) :: azx,azy,azz
6925       real(kind=8) :: uxj,uyj,uzj
6926       real(kind=8) :: tx,ty,tz
6927       real(kind=8) :: txb,tyb,td
6928       real(kind=8) :: tr2,tr,txr,tyr
6929       real(kind=8) :: tk1,tk2
6930       real(kind=8) :: thec,the,t,tb
6931       real(kind=8) :: txk,tyk,tzk
6932       real(kind=8) :: t1,ti,tf,tt
6933       real(kind=8) :: txj,tyj,tzj
6934       real(kind=8) :: ccsq,cc,xysq
6935       real(kind=8) :: bsqk,bk,cosine
6936       real(kind=8) :: dsqj,gi,pix2
6937       real(kind=8) :: therk,dk,gk
6938       real(kind=8) :: risqk,rik
6939       real(kind=8) :: radius(2*nres)    !(maxatm) (maxatm=maxres2)
6940       real(kind=8) :: ri(maxarc),risq(maxarc)
6941       real(kind=8) :: ux(maxarc),uy(maxarc),uz(maxarc)
6942       real(kind=8) :: xc(maxarc),yc(maxarc),zc(maxarc)
6943       real(kind=8) :: xc1(maxarc),yc1(maxarc),zc1(maxarc)
6944       real(kind=8) :: dsq(maxarc),bsq(maxarc)
6945       real(kind=8) :: dsq1(maxarc),bsq1(maxarc)
6946       real(kind=8) :: arci(maxarc),arcf(maxarc)
6947       real(kind=8) :: ex(maxarc),lt(maxarc),gr(maxarc)
6948       real(kind=8) :: b(maxarc),b1(maxarc),bg(maxarc)
6949       real(kind=8) :: kent(maxarc),kout(maxarc)
6950       real(kind=8) :: ther(maxarc)
6951       logical :: moved,top
6952       logical :: omit(maxarc)
6953 !
6954 !      include 'sizes.i'
6955 !      maxatm = 2*nres  !maxres2 maxres2=2*maxres
6956 !      maxlight = 8*maxatm
6957 !      maxbnd = 2*maxatm
6958 !      maxang = 3*maxatm
6959 !      maxtors = 4*maxatm
6960 !
6961 !     zero out the surface area for the sphere of interest
6962 !
6963       area = 0.0d0
6964 !      write (2,*) "ir",ir," radius",radius(ir)
6965       if (radius(ir) .eq. 0.0d0)  return
6966 !
6967 !     set the overlap significance and connectivity shift
6968 !
6969       pix2 = 2.0d0 * pi
6970       delta = 1.0d-8
6971       delta2 = delta * delta
6972       eps = 1.0d-8
6973       moved = .false.
6974       rmove = 1.0d-8
6975 !
6976 !     store coordinates and radius of the sphere of interest
6977 !
6978       xr = c(1,ir)
6979       yr = c(2,ir)
6980       zr = c(3,ir)
6981       rr = radius(ir)
6982       rrsq = rr * rr
6983 !
6984 !     initialize values of some counters and summations
6985 !
6986    10 continue
6987       io = 0
6988       jb = 0
6989       ib = 0
6990       arclen = 0.0d0
6991       exang = 0.0d0
6992 !
6993 !     test each sphere to see if it overlaps the sphere of interest
6994 !
6995       do i = 1, 2*nres
6996          if (i.eq.ir .or. radius(i).eq.0.0d0)  goto 30
6997          rplus = rr + radius(i)
6998          tx = c(1,i) - xr
6999          if (abs(tx) .ge. rplus)  goto 30
7000          ty = c(2,i) - yr
7001          if (abs(ty) .ge. rplus)  goto 30
7002          tz = c(3,i) - zr
7003          if (abs(tz) .ge. rplus)  goto 30
7004 !
7005 !     check for sphere overlap by testing distance against radii
7006 !
7007          xysq = tx*tx + ty*ty
7008          if (xysq .lt. delta2) then
7009             tx = delta
7010             ty = 0.0d0
7011             xysq = delta2
7012          end if
7013          ccsq = xysq + tz*tz
7014          cc = sqrt(ccsq)
7015          if (rplus-cc .le. delta)  goto 30
7016          rminus = rr - radius(i)
7017 !
7018 !     check to see if sphere of interest is completely buried
7019 !
7020          if (cc-abs(rminus) .le. delta) then
7021             if (rminus .le. 0.0d0)  goto 170
7022             goto 30
7023          end if
7024 !
7025 !     check for too many overlaps with sphere of interest
7026 !
7027          if (io .ge. maxarc) then
7028             write (iout,20)
7029    20       format (/,' SURFATOM  --  Increase the Value of MAXARC')
7030             stop
7031          end if
7032 !
7033 !     get overlap between current sphere and sphere of interest
7034 !
7035          io = io + 1
7036          xc1(io) = tx
7037          yc1(io) = ty
7038          zc1(io) = tz
7039          dsq1(io) = xysq
7040          bsq1(io) = ccsq
7041          b1(io) = cc
7042          gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io))
7043          intag1(io) = i
7044          omit(io) = .false.
7045    30    continue
7046       end do
7047 !
7048 !     case where no other spheres overlap the sphere of interest
7049 !
7050       if (io .eq. 0) then
7051          area = 4.0d0 * pi * rrsq
7052          return
7053       end if
7054 !
7055 !     case where only one sphere overlaps the sphere of interest
7056 !
7057       if (io .eq. 1) then
7058          area = pix2 * (1.0d0 + gr(1))
7059          area = mod(area,4.0d0*pi) * rrsq
7060          return
7061       end if
7062 !
7063 !     case where many spheres intersect the sphere of interest;
7064 !     sort the intersecting spheres by their degree of overlap
7065 !
7066       call sort2 (io,gr,key)
7067       do i = 1, io
7068          k = key(i)
7069          intag(i) = intag1(k)
7070          xc(i) = xc1(k)
7071          yc(i) = yc1(k)
7072          zc(i) = zc1(k)
7073          dsq(i) = dsq1(k)
7074          b(i) = b1(k)
7075          bsq(i) = bsq1(k)
7076       end do
7077 !
7078 !     get radius of each overlap circle on surface of the sphere
7079 !
7080       do i = 1, io
7081          gi = gr(i) * rr
7082          bg(i) = b(i) * gi
7083          risq(i) = rrsq - gi*gi
7084          ri(i) = sqrt(risq(i))
7085          ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i))))
7086       end do
7087 !
7088 !     find boundary of inaccessible area on sphere of interest
7089 !
7090       do k = 1, io-1
7091          if (.not. omit(k)) then
7092             txk = xc(k)
7093             tyk = yc(k)
7094             tzk = zc(k)
7095             bk = b(k)
7096             therk = ther(k)
7097 !
7098 !     check to see if J circle is intersecting K circle;
7099 !     get distance between circle centers and sum of radii
7100 !
7101             do j = k+1, io
7102                if (omit(j))  goto 60
7103                cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
7104                cc = acos(min(1.0d0,max(-1.0d0,cc)))
7105                td = therk + ther(j)
7106 !
7107 !     check to see if circles enclose separate regions
7108 !
7109                if (cc .ge. td)  goto 60
7110 !
7111 !     check for circle J completely inside circle K
7112 !
7113                if (cc+ther(j) .lt. therk)  goto 40
7114 !
7115 !     check for circles that are essentially parallel
7116 !
7117                if (cc .gt. delta)  goto 50
7118    40          continue
7119                omit(j) = .true.
7120                goto 60
7121 !
7122 !     check to see if sphere of interest is completely buried
7123 !
7124    50          continue
7125                if (pix2-cc .le. td)  goto 170
7126    60          continue
7127             end do
7128          end if
7129       end do
7130 !
7131 !     find T value of circle intersections
7132 !
7133       do k = 1, io
7134          if (omit(k))  goto 110
7135          omit(k) = .true.
7136          narc = 0
7137          top = .false.
7138          txk = xc(k)
7139          tyk = yc(k)
7140          tzk = zc(k)
7141          dk = sqrt(dsq(k))
7142          bsqk = bsq(k)
7143          bk = b(k)
7144          gk = gr(k) * rr
7145          risqk = risq(k)
7146          rik = ri(k)
7147          therk = ther(k)
7148 !
7149 !     rotation matrix elements
7150 !
7151          t1 = tzk / (bk*dk)
7152          axx = txk * t1
7153          axy = tyk * t1
7154          axz = dk / bk
7155          ayx = tyk / dk
7156          ayy = txk / dk
7157          azx = txk / bk
7158          azy = tyk / bk
7159          azz = tzk / bk
7160          do j = 1, io
7161             if (.not. omit(j)) then
7162                txj = xc(j)
7163                tyj = yc(j)
7164                tzj = zc(j)
7165 !
7166 !     rotate spheres so K vector colinear with z-axis
7167 !
7168                uxj = txj*axx + tyj*axy - tzj*axz
7169                uyj = tyj*ayy - txj*ayx
7170                uzj = txj*azx + tyj*azy + tzj*azz
7171                cosine = min(1.0d0,max(-1.0d0,uzj/b(j)))
7172                if (acos(cosine) .lt. therk+ther(j)) then
7173                   dsqj = uxj*uxj + uyj*uyj
7174                   tb = uzj*gk - bg(j)
7175                   txb = uxj * tb
7176                   tyb = uyj * tb
7177                   td = rik * dsqj
7178                   tr2 = risqk*dsqj - tb*tb
7179                   tr2 = max(eps,tr2)
7180                   tr = sqrt(tr2)
7181                   txr = uxj * tr
7182                   tyr = uyj * tr
7183 !
7184 !     get T values of intersection for K circle
7185 !
7186                   tb = (txb+tyr) / td
7187                   tb = min(1.0d0,max(-1.0d0,tb))
7188                   tk1 = acos(tb)
7189                   if (tyb-txr .lt. 0.0d0)  tk1 = pix2 - tk1
7190                   tb = (txb-tyr) / td
7191                   tb = min(1.0d0,max(-1.0d0,tb))
7192                   tk2 = acos(tb)
7193                   if (tyb+txr .lt. 0.0d0)  tk2 = pix2 - tk2
7194                   thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j))
7195                   if (abs(thec) .lt. 1.0d0) then
7196                      the = -acos(thec)
7197                   else if (thec .ge. 1.0d0) then
7198                      the = 0.0d0
7199                   else if (thec .le. -1.0d0) then
7200                      the = -pi
7201                   end if
7202 !
7203 !     see if "tk1" is entry or exit point; check t=0 point;
7204 !     "ti" is exit point, "tf" is entry point
7205 !
7206                   cosine = min(1.0d0,max(-1.0d0, &
7207                                   (uzj*gk-uxj*rik)/(b(j)*rr)))
7208                   if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then
7209                      ti = tk2
7210                      tf = tk1
7211                   else
7212                      ti = tk2
7213                      tf = tk1
7214                   end if
7215                   narc = narc + 1
7216                   if (narc .ge. maxarc) then
7217                      write (iout,70)
7218    70                format (/,' SURFATOM  --  Increase the Value',&
7219                                 ' of MAXARC')
7220                      stop
7221                   end if
7222                   if (tf .le. ti) then
7223                      arcf(narc) = tf
7224                      arci(narc) = 0.0d0
7225                      tf = pix2
7226                      lt(narc) = j
7227                      ex(narc) = the
7228                      top = .true.
7229                      narc = narc + 1
7230                   end if
7231                   arcf(narc) = tf
7232                   arci(narc) = ti
7233                   lt(narc) = j
7234                   ex(narc) = the
7235                   ux(j) = uxj
7236                   uy(j) = uyj
7237                   uz(j) = uzj
7238                end if
7239             end if
7240          end do
7241          omit(k) = .false.
7242 !
7243 !     special case; K circle without intersections
7244 !
7245          if (narc .le. 0)  goto 90
7246 !
7247 !     general case; sum up arclength and set connectivity code
7248 !
7249          call sort2 (narc,arci,key)
7250          arcsum = arci(1)
7251          mi = key(1)
7252          t = arcf(mi)
7253          ni = mi
7254          if (narc .gt. 1) then
7255             do j = 2, narc
7256                m = key(j)
7257                if (t .lt. arci(j)) then
7258                   arcsum = arcsum + arci(j) - t
7259                   exang = exang + ex(ni)
7260                   jb = jb + 1
7261                   if (jb .ge. maxarc) then
7262                      write (iout,80)
7263    80                format (/,' SURFATOM  --  Increase the Value',&
7264                                 ' of MAXARC')
7265                      stop
7266                   end if
7267                   i = lt(ni)
7268                   kent(jb) = maxarc*i + k
7269                   i = lt(m)
7270                   kout(jb) = maxarc*k + i
7271                end if
7272                tt = arcf(m)
7273                if (tt .ge. t) then
7274                   t = tt
7275                   ni = m
7276                end if
7277             end do
7278          end if
7279          arcsum = arcsum + pix2 - t
7280          if (.not. top) then
7281             exang = exang + ex(ni)
7282             jb = jb + 1
7283             i = lt(ni)
7284             kent(jb) = maxarc*i + k
7285             i = lt(mi)
7286             kout(jb) = maxarc*k + i
7287          end if
7288          goto 100
7289    90    continue
7290          arcsum = pix2
7291          ib = ib + 1
7292   100    continue
7293          arclen = arclen + gr(k)*arcsum
7294   110    continue
7295       end do
7296       if (arclen .eq. 0.0d0)  goto 170
7297       if (jb .eq. 0)  goto 150
7298 !
7299 !     find number of independent boundaries and check connectivity
7300 !
7301       j = 0
7302       do k = 1, jb
7303          if (kout(k) .ne. 0) then
7304             i = k
7305   120       continue
7306             m = kout(i)
7307             kout(i) = 0
7308             j = j + 1
7309             do ii = 1, jb
7310                if (m .eq. kent(ii)) then
7311                   if (ii .eq. k) then
7312                      ib = ib + 1
7313                      if (j .eq. jb)  goto 150
7314                      goto 130
7315                   end if
7316                   i = ii
7317                   goto 120
7318                end if
7319             end do
7320   130       continue
7321          end if
7322       end do
7323       ib = ib + 1
7324 !
7325 !     attempt to fix connectivity error by moving atom slightly
7326 !
7327       if (moved) then
7328          write (iout,140)  ir
7329   140    format (/,' SURFATOM  --  Connectivity Error at Atom',i6)
7330       else
7331          moved = .true.
7332          xr = xr + rmove
7333          yr = yr + rmove
7334          zr = zr + rmove
7335          goto 10
7336       end if
7337 !
7338 !     compute the exposed surface area for the sphere of interest
7339 !
7340   150 continue
7341       area = ib*pix2 + exang + arclen
7342       area = mod(area,4.0d0*pi) * rrsq
7343 !
7344 !     attempt to fix negative area by moving atom slightly
7345 !
7346       if (area .lt. 0.0d0) then
7347          if (moved) then
7348             write (iout,160)  ir
7349   160       format (/,' SURFATOM  --  Negative Area at Atom',i6)
7350          else
7351             moved = .true.
7352             xr = xr + rmove
7353             yr = yr + rmove
7354             zr = zr + rmove
7355             goto 10
7356          end if
7357       end if
7358   170 continue
7359       return
7360       end subroutine surfatom
7361 !----------------------------------------------------------------
7362 !----------------------------------------------------------------
7363       subroutine alloc_MD_arrays
7364 !EL Allocation of arrays used by MD module
7365
7366       integer :: nres2,nres6
7367       nres2=nres*2
7368       nres6=nres*6
7369 !----------------------
7370 #ifndef LANG0
7371 ! commom.langevin
7372 !      common /langforc/
7373       allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2)
7374       allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6)
7375       if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2))
7376       allocate(fricvec(nres2,nres2))
7377       allocate(pfric_mat(nres2,nres2),vfric_mat(nres2,nres2))
7378       allocate(afric_mat(nres2,nres2),prand_mat(nres2,nres2))
7379       allocate(vrand_mat1(nres2,nres2),vrand_mat2(nres2,nres2)) !(MAXRES2,MAXRES2)
7380       allocate(pfric0_mat(nres2,nres2,0:maxflag_stoch))
7381       allocate(afric0_mat(nres2,nres2,0:maxflag_stoch))
7382       allocate(vfric0_mat(nres2,nres2,0:maxflag_stoch))
7383       allocate(prand0_mat(nres2,nres2,0:maxflag_stoch))
7384       allocate(vrand0_mat1(nres2,nres2,0:maxflag_stoch))
7385       allocate(vrand0_mat2(nres2,nres2,0:maxflag_stoch)) !(MAXRES2,MAXRES2,0:maxflag_stoch)
7386       allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch)
7387 !      common /langmat/
7388       allocate(mt1(nres2,nres2),mt2(nres2,nres2),mt3(nres2,nres2)) !(maxres2,maxres2)
7389 !----------------------
7390 #else
7391 ! commom.langevin.lang0
7392 !      common /langforc/
7393       allocate(friction(3,0:nres2),stochforc(3,0:nres2)) !(3,0:MAXRES2)
7394 #ifndef FIVEDIAG
7395       if(.not.allocated(fricmat)) allocate(fricmat(nres2,nres2))
7396       allocate(fricvec(nres2,nres2)) !(MAXRES2,MAXRES2)
7397 #endif
7398       allocate(fric_work(nres6),stoch_work(nres6),fricgam(nres6)) !(MAXRES6)
7399       allocate(flag_stoch(0:maxflag_stoch)) !(0:maxflag_stoch)
7400 #endif
7401 #ifndef FIVEDIAG
7402       if(.not.allocated(fcopy)) allocate(fcopy(nres2,nres2))
7403 #endif
7404 !----------------------
7405 ! commom.hairpin in CSA module
7406 !----------------------
7407 ! common.mce in MCM_MD module
7408 !----------------------
7409 ! common.MD
7410 !      common /mdgrad/ in module.energy
7411 !      common /back_constr/ in module.energy
7412 !      common /qmeas/ in module.energy
7413 !      common /mdpar/
7414 !      common /MDcalc/
7415       allocate(potEcomp(0:n_ene+4)) !(0:n_ene+4)
7416 !      common /lagrange/
7417       allocate(d_t(3,0:nres2),d_a(3,0:nres2),d_t_old(3,0:nres2)) !(3,0:MAXRES2)
7418       allocate(d_a_work(nres6)) !(6*MAXRES)
7419 #ifdef FIVEDIAG
7420       allocate(DM(nres2),DU1(nres2),DU2(nres2))
7421       allocate(DMorig(nres2),DU1orig(nres2),DU2orig(nres2))
7422 !#ifdef DEBUG
7423       allocate(Gvec(1300,1300))!maximum number of protein in one chain
7424 !#endif
7425 #else
7426       write (iout,*) "Before A Allocation",nfgtasks-1
7427       call flush(iout)
7428       allocate(Gmat(nres2,nres2),A(nres2,nres2))
7429       if(.not.allocated(Ginv)) allocate(Ginv(nres2,nres2)) !in control: ergastulum
7430       allocate(Gsqrp(nres2,nres2),Gsqrm(nres2,nres2),Gvec(nres2,nres2)) !(maxres2,maxres2)
7431 #endif
7432       allocate(Geigen(nres2)) !(maxres2)
7433       if(.not.allocated(vtot)) allocate(vtot(nres2)) !(maxres2)
7434 !      common /inertia/ in io_conf: parmread
7435 !      real(kind=8),dimension(:),allocatable :: ISC,msc !(ntyp+1)
7436 !      common /langevin/in io read_MDpar
7437 !      real(kind=8),dimension(:),allocatable :: gamsc !(ntyp1)
7438 !      real(kind=8),dimension(:),allocatable :: stdfsc !(ntyp)
7439 ! in io_conf: parmread
7440 !      real(kind=8),dimension(:),allocatable :: restok !(ntyp+1)
7441 !      common /mdpmpi/ in control: ergastulum
7442       if(.not.allocated(ng_start)) allocate(ng_start(0:nfgtasks-1))
7443       if(.not.allocated(ng_counts)) allocate(ng_counts(0:nfgtasks-1))
7444       if(.not.allocated(nginv_counts)) allocate(nginv_counts(0:nfgtasks-1)) !(0:MaxProcs-1)
7445       if(.not.allocated(nginv_start)) allocate(nginv_start(0:nfgtasks)) !(0:MaxProcs)
7446 !----------------------
7447 ! common.muca in read_muca
7448 !      common /double_muca/
7449 !      real(kind=8) :: elow,ehigh,factor,hbin,factor_min
7450 !      real(kind=8),dimension(:),allocatable :: emuca,nemuca,&
7451 !       nemuca2,hist !(4*maxres)
7452 !      common /integer_muca/
7453 !      integer :: nmuca,imtime,muca_smooth
7454 !      common /mucarem/
7455 !      real(kind=8),dimension(:),allocatable :: elowi,ehighi !(maxprocs)
7456 !----------------------
7457 ! common.MD
7458 !      common /mdgrad/ in module.energy
7459 !      common /back_constr/ in module.energy
7460 !      common /qmeas/ in module.energy
7461 !      common /mdpar/
7462 !      common /MDcalc/
7463 !      common /lagrange/
7464       allocate(d_t_work(nres6),d_t_work_new(nres6),d_af_work(nres6))
7465       allocate(d_as_work(nres6),kinetic_force(nres6)) !(MAXRES6)
7466       allocate(d_t_new(3,0:nres2),d_a_old(3,0:nres2),d_a_short(3,0:nres2)) !,d_a !(3,0:MAXRES2)
7467       allocate(stdforcp(nres),stdforcsc(nres)) !(MAXRES)
7468 !----------------------
7469 !      COMMON /BANII/ D
7470       allocate(D_ban(nres6))    !(MAXRES6) maxres6=6*maxres
7471 !      common /stochcalc/ stochforcvec
7472       allocate(stochforcvec(nres6))     !(MAXRES6) maxres6=6*maxres
7473 !----------------------
7474       return
7475       end subroutine alloc_MD_arrays
7476 !-----------------------------------------------------------------------------
7477 !-----------------------------------------------------------------------------
7478       end module MDyn