source/unres/MD.F90

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