source/unres/MD.F90

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