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