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