source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 !-----------------------------------------------------------------------------
  33 ! commom.calc common/calc/
  34 !-----------------------------------------------------------------------------
  35 ! commom.contacts
  36 !      common /contacts/
  37 ! Change 12/1/95 - common block CONTACTS1 included.
  38 !      common /contacts1/
  39       integer,dimension(:),allocatable :: num_cont      !(maxres)
  40       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  41       real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres)
  42       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  43 !
  44 ! 12/26/95 - H-bonding contacts
  45 !      common /contacts_hb/
  46       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  47        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  48       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  49         ees0m,d_cont    !(maxconts,maxres)
  50       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  51       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  52 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  53 !         interactions
  54 ! 7/25/08 commented out; not needed when cumulants used
  55 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  56 !  common /dipint/
  57       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  58          dipderg        !(4,maxconts,maxres)
  59       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  60 ! 10/30/99 Added other pre-computed vectors and matrices needed
  61 !          to calculate three - six-order el-loc correlation terms
  62 ! common /rotat/
  63       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  64       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  65        obrot2_der       !(2,maxres)
  66 !
  67 ! This common block contains vectors and matrices dependent on a single
  68 ! amino-acid residue.
  69 !      common /precomp1/
  70       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  71        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  72       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  73        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  74 ! This common block contains vectors and matrices dependent on two
  75 ! consecutive amino-acid residues.
  76 !      common /precomp2/
  77       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  78        CUgb2,CUgb2der   !(2,maxres)
  79       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  80        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  81       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  82        DtUg2EUgder      !(2,2,2,maxres)
  83 !      common /rotat_old/
  84       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  85        costab2,sintab2  !(maxres)
  86 ! This common block contains dipole-interaction matrices and their
  87 ! Cartesian derivatives.
  88 !      common /dipmat/
  89       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  90       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  91 !      common /diploc/
  92       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  93        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  94       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
  95        ADtEA1derg,AEAb2derg
  96       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
  97        AECAderx,ADtEAderx,ADtEA1derx
  98       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
  99       real(kind=8),dimension(3,2) :: g_contij
 100       real(kind=8) :: ekont
 101 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 102 !   RE: Parallelization of 4th and higher order loc-el correlations
 103 !      common /contdistrib/
 104       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 105 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 106 !-----------------------------------------------------------------------------
 107 ! commom.deriv;
 108 !      common /derivat/
 109 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 110 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 111 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 112       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 113         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 114         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 115         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres)
 116 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 117       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 118         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 119       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 120         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 121         g_corr6_loc     !(maxvar)
 122       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 123       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 124 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 125       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 126 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 127 !      integer :: nfl,icg
 128 !      common /deriv_loc/
 129       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 130 !      common /deriv_scloc/
 131       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 132        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 133        dZZ_XYZtab       !(3,maxres)
 134 !-----------------------------------------------------------------------------
 135 ! common.maxgrad
 136 !      common /maxgrad/
 137       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 138        gradb_max,ghpbc_max,&
 139        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 140        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 141        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 142        gsccorx_max,gsclocx_max
 143 !-----------------------------------------------------------------------------
 144 ! common.MD
 145 !      common /back_constr/
 146       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 147       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 148 !      common /qmeas/
 149       real(kind=8) :: Ucdfrag,Ucdpair
 150       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 151        dqwol,dxqwol     !(3,0:MAXRES)
 152 !-----------------------------------------------------------------------------
 153 ! common.sbridge
 154 !      common /dyn_ssbond/
 155       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 156 !-----------------------------------------------------------------------------
 157 ! common.sccor
 158 ! Parameters of the SCCOR term
 159 !      common/sccor/
 160       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 161        dcosomicron,domicron     !(3,3,3,maxres2)
 162 !-----------------------------------------------------------------------------
 163 ! common.vectors
 164 !      common /vectors/
 165       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 166       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 167 !-----------------------------------------------------------------------------
 168 ! common /przechowalnia/
 169       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 170       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 171 !-----------------------------------------------------------------------------
 172 !-----------------------------------------------------------------------------
 173 !
 174 !
 175 !-----------------------------------------------------------------------------
 176       contains
 177 !-----------------------------------------------------------------------------
 178 ! energy_p_new_barrier.F
 179 !-----------------------------------------------------------------------------
 180       subroutine etotal(energia)
 181 !      implicit real*8 (a-h,o-z)
 182 !      include 'DIMENSIONS'
 183       use MD_data
 184 #ifndef ISNAN
 185       external proc_proc
 186 #ifdef WINPGI
 187 !MS$ATTRIBUTES C ::  proc_proc
 188 #endif
 189 #endif
 190 #ifdef MPI
 191       include "mpif.h"
 192 #endif
 193 !      include 'COMMON.SETUP'
 194 !      include 'COMMON.IOUNITS'
 195       real(kind=8),dimension(0:n_ene) :: energia
 196 !      include 'COMMON.LOCAL'
 197 !      include 'COMMON.FFIELD'
 198 !      include 'COMMON.DERIV'
 199 !      include 'COMMON.INTERACT'
 200 !      include 'COMMON.SBRIDGE'
 201 !      include 'COMMON.CHAIN'
 202 !      include 'COMMON.VAR'
 203 !      include 'COMMON.MD'
 204 !      include 'COMMON.CONTROL'
 205 !      include 'COMMON.TIME1'
 206       real(kind=8) :: time00
 207 !el local variables
 208       integer :: n_corr,n_corr1,ierror
 209       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 210       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 211       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe
 212       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 213
 214 #ifdef MPI
 215       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 216 ! shielding effect varibles for MPI
 217 !      real(kind=8)   fac_shieldbuf(maxres),
 218 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 219 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 220 !     & grad_shieldbuf(3,-1:maxres)
 221 !       integer ishield_listbuf(maxres),
 222 !     &shield_listbuf(maxcontsshi,maxres)
 223
 224 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 225 !     & " nfgtasks",nfgtasks
 226       if (nfgtasks.gt.1) then
 227         time00=MPI_Wtime()
 228 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 229         if (fg_rank.eq.0) then
 230           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 231 !          print *,"Processor",myrank," BROADCAST iorder"
 232 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 233 ! FG slaves as WEIGHTS array.
 234           weights_(1)=wsc
 235           weights_(2)=wscp
 236           weights_(3)=welec
 237           weights_(4)=wcorr
 238           weights_(5)=wcorr5
 239           weights_(6)=wcorr6
 240           weights_(7)=wel_loc
 241           weights_(8)=wturn3
 242           weights_(9)=wturn4
 243           weights_(10)=wturn6
 244           weights_(11)=wang
 245           weights_(12)=wscloc
 246           weights_(13)=wtor
 247           weights_(14)=wtor_d
 248           weights_(15)=wstrain
 249           weights_(16)=wvdwpp
 250           weights_(17)=wbond
 251           weights_(18)=scal14
 252           weights_(21)=wsccor
 253 ! FG Master broadcasts the WEIGHTS_ array
 254           call MPI_Bcast(weights_(1),n_ene,&
 255              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 256         else
 257 ! FG slaves receive the WEIGHTS array
 258           call MPI_Bcast(weights(1),n_ene,&
 259               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 260           wsc=weights(1)
 261           wscp=weights(2)
 262           welec=weights(3)
 263           wcorr=weights(4)
 264           wcorr5=weights(5)
 265           wcorr6=weights(6)
 266           wel_loc=weights(7)
 267           wturn3=weights(8)
 268           wturn4=weights(9)
 269           wturn6=weights(10)
 270           wang=weights(11)
 271           wscloc=weights(12)
 272           wtor=weights(13)
 273           wtor_d=weights(14)
 274           wstrain=weights(15)
 275           wvdwpp=weights(16)
 276           wbond=weights(17)
 277           scal14=weights(18)
 278           wsccor=weights(21)
 279         endif
 280         time_Bcast=time_Bcast+MPI_Wtime()-time00
 281         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 282 !        call chainbuild_cart
 283       endif
 284 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 285 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 286 #else
 287 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 288 !        call int_from_cart1(.false.)
 289 !      endif
 290 #endif
 291 #ifdef TIMING
 292       time00=MPI_Wtime()
 293 #endif
 294 !
 295 ! Compute the side-chain and electrostatic interaction energy
 296 !
 297 !      goto (101,102,103,104,105,106) ipot
 298       select case(ipot)
 299 ! Lennard-Jones potential.
 300 !  101 call elj(evdw)
 301        case (1)
 302          call elj(evdw)
 303 !d    print '(a)','Exit ELJcall el'
 304 !      goto 107
 305 ! Lennard-Jones-Kihara potential (shifted).
 306 !  102 call eljk(evdw)
 307        case (2)
 308          call eljk(evdw)
 309 !      goto 107
 310 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 311 !  103 call ebp(evdw)
 312        case (3)
 313          call ebp(evdw)
 314 !      goto 107
 315 ! Gay-Berne potential (shifted LJ, angular dependence).
 316 !  104 call egb(evdw)
 317        case (4)
 318          call egb(evdw)
 319 !      goto 107
 320 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 321 !  105 call egbv(evdw)
 322        case (5)
 323          call egbv(evdw)
 324 !      goto 107
 325 ! Soft-sphere potential
 326 !  106 call e_softsphere(evdw)
 327        case (6)
 328          call e_softsphere(evdw)
 329 !
 330 ! Calculate electrostatic (H-bonding) energy of the main chain.
 331 !
 332 !  107 continue
 333        case default
 334          write(iout,*)"Wrong ipot"
 335 !         return
 336 !   50 continue
 337       end select
 338 !      continue
 339
 340 !mc
 341 !mc Sep-06: egb takes care of dynamic ss bonds too
 342 !mc
 343 !      if (dyn_ss) call dyn_set_nss
 344 !      print *,"Processor",myrank," computed USCSC"
 345 #ifdef TIMING
 346       time01=MPI_Wtime()
 347 #endif
 348       call vec_and_deriv
 349 #ifdef TIMING
 350       time_vec=time_vec+MPI_Wtime()-time01
 351 #endif
 352 !      print *,"Processor",myrank," left VEC_AND_DERIV"
 353       if (ipot.lt.6) then
 354 #ifdef SPLITELE
 355          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 356              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 357              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 358              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 359 #else
 360          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 361              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 362              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 363              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 364 #endif
 365             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 366 !        write (iout,*) "ELEC calc"
 367          else
 368             ees=0.0d0
 369             evdw1=0.0d0
 370             eel_loc=0.0d0
 371             eello_turn3=0.0d0
 372             eello_turn4=0.0d0
 373          endif
 374       else
 375 !        write (iout,*) "Soft-spheer ELEC potential"
 376         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 377          eello_turn4)
 378       endif
 379 !      print *,"Processor",myrank," computed UELEC"
 380 !
 381 ! Calculate excluded-volume interaction energy between peptide groups
 382 ! and side chains.
 383 !
 384 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 385
 386       if (ipot.lt.6) then
 387        if(wscp.gt.0d0) then
 388         call escp(evdw2,evdw2_14)
 389        else
 390         evdw2=0
 391         evdw2_14=0
 392        endif
 393       else
 394 !        write (iout,*) "Soft-sphere SCP potential"
 395         call escp_soft_sphere(evdw2,evdw2_14)
 396       endif
 397 !elwrite(iout,*) "in etotal before ebond",ipot
 398
 399 !
 400 ! Calculate the bond-stretching energy
 401 !
 402       call ebond(estr)
 403 !elwrite(iout,*) "in etotal afer ebond",ipot
 404
 405 !
 406 ! Calculate the disulfide-bridge and other energy and the contributions
 407 ! from other distance constraints.
 408 !      print *,'Calling EHPB'
 409       call edis(ehpb)
 410 !elwrite(iout,*) "in etotal afer edis",ipot
 411 !      print *,'EHPB exitted succesfully.'
 412 !
 413 ! Calculate the virtual-bond-angle energy.
 414 !
 415       if (wang.gt.0d0) then
 416         call ebend(ebe)
 417       else
 418         ebe=0
 419       endif
 420 !      print *,"Processor",myrank," computed UB"
 421 !
 422 ! Calculate the SC local energy.
 423 !
 424       call esc(escloc)
 425 !elwrite(iout,*) "in etotal afer esc",ipot
 426 !      print *,"Processor",myrank," computed USC"
 427 !
 428 ! Calculate the virtual-bond torsional energy.
 429 !
 430 !d    print *,'nterm=',nterm
 431       if (wtor.gt.0) then
 432        call etor(etors,edihcnstr)
 433       else
 434        etors=0
 435        edihcnstr=0
 436       endif
 437 !      print *,"Processor",myrank," computed Utor"
 438 !
 439 ! 6/23/01 Calculate double-torsional energy
 440 !
 441 !elwrite(iout,*) "in etotal",ipot
 442       if (wtor_d.gt.0) then
 443        call etor_d(etors_d)
 444       else
 445        etors_d=0
 446       endif
 447 !      print *,"Processor",myrank," computed Utord"
 448 !
 449 ! 21/5/07 Calculate local sicdechain correlation energy
 450 !
 451       if (wsccor.gt.0.0d0) then
 452         call eback_sc_corr(esccor)
 453       else
 454         esccor=0.0d0
 455       endif
 456 !      print *,"Processor",myrank," computed Usccorr"
 457 !
 458 ! 12/1/95 Multi-body terms
 459 !
 460       n_corr=0
 461       n_corr1=0
 462       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 463           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 464          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 465 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 466 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 467       else
 468          ecorr=0.0d0
 469          ecorr5=0.0d0
 470          ecorr6=0.0d0
 471          eturn6=0.0d0
 472       endif
 473 !elwrite(iout,*) "in etotal",ipot
 474       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 475          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 476 !d         write (iout,*) "multibody_hb ecorr",ecorr
 477       endif
 478 !elwrite(iout,*) "afeter  multibody hb"
 479
 480 !      print *,"Processor",myrank," computed Ucorr"
 481 !
 482 ! If performing constraint dynamics, call the constraint energy
 483 !  after the equilibration time
 484       if(usampl.and.totT.gt.eq_time) then
 485 !elwrite(iout,*) "afeter  multibody hb"
 486          call EconstrQ
 487 !elwrite(iout,*) "afeter  multibody hb"
 488          call Econstr_back
 489 !elwrite(iout,*) "afeter  multibody hb"
 490       else
 491          Uconst=0.0d0
 492          Uconst_back=0.0d0
 493       endif
 494 !elwrite(iout,*) "after Econstr"
 495
 496 #ifdef TIMING
 497       time_enecalc=time_enecalc+MPI_Wtime()-time00
 498 #endif
 499 !      print *,"Processor",myrank," computed Uconstr"
 500 #ifdef TIMING
 501       time00=MPI_Wtime()
 502 #endif
 503 !
 504 ! Sum the energies
 505 !
 506       energia(1)=evdw
 507 #ifdef SCP14
 508       energia(2)=evdw2-evdw2_14
 509       energia(18)=evdw2_14
 510 #else
 511       energia(2)=evdw2
 512       energia(18)=0.0d0
 513 #endif
 514 #ifdef SPLITELE
 515       energia(3)=ees
 516       energia(16)=evdw1
 517 #else
 518       energia(3)=ees+evdw1
 519       energia(16)=0.0d0
 520 #endif
 521       energia(4)=ecorr
 522       energia(5)=ecorr5
 523       energia(6)=ecorr6
 524       energia(7)=eel_loc
 525       energia(8)=eello_turn3
 526       energia(9)=eello_turn4
 527       energia(10)=eturn6
 528       energia(11)=ebe
 529       energia(12)=escloc
 530       energia(13)=etors
 531       energia(14)=etors_d
 532       energia(15)=ehpb
 533       energia(19)=edihcnstr
 534       energia(17)=estr
 535       energia(20)=Uconst+Uconst_back
 536       energia(21)=esccor
 537 !    Here are the energies showed per procesor if the are more processors
 538 !    per molecule then we sum it up in sum_energy subroutine
 539 !      print *," Processor",myrank," calls SUM_ENERGY"
 540       call sum_energy(energia,.true.)
 541       if (dyn_ss) call dyn_set_nss
 542 !      print *," Processor",myrank," left SUM_ENERGY"
 543 #ifdef TIMING
 544       time_sumene=time_sumene+MPI_Wtime()-time00
 545 #endif
 546 !el        call enerprint(energia)
 547 !elwrite(iout,*)"finish etotal"
 548       return
 549       end subroutine etotal
 550 !-----------------------------------------------------------------------------
 551       subroutine sum_energy(energia,reduce)
 552 !      implicit real*8 (a-h,o-z)
 553 !      include 'DIMENSIONS'
 554 #ifndef ISNAN
 555       external proc_proc
 556 #ifdef WINPGI
 557 !MS$ATTRIBUTES C ::  proc_proc
 558 #endif
 559 #endif
 560 #ifdef MPI
 561       include "mpif.h"
 562 #endif
 563 !      include 'COMMON.SETUP'
 564 !      include 'COMMON.IOUNITS'
 565       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 566 !      include 'COMMON.FFIELD'
 567 !      include 'COMMON.DERIV'
 568 !      include 'COMMON.INTERACT'
 569 !      include 'COMMON.SBRIDGE'
 570 !      include 'COMMON.CHAIN'
 571 !      include 'COMMON.VAR'
 572 !      include 'COMMON.CONTROL'
 573 !      include 'COMMON.TIME1'
 574       logical :: reduce
 575       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 576       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 577       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot
 578       integer :: i
 579 #ifdef MPI
 580       integer :: ierr
 581       real(kind=8) :: time00
 582       if (nfgtasks.gt.1 .and. reduce) then
 583
 584 #ifdef DEBUG
 585         write (iout,*) "energies before REDUCE"
 586         call enerprint(energia)
 587         call flush(iout)
 588 #endif
 589         do i=0,n_ene
 590           enebuff(i)=energia(i)
 591         enddo
 592         time00=MPI_Wtime()
 593         call MPI_Barrier(FG_COMM,IERR)
 594         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 595         time00=MPI_Wtime()
 596         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 597           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 598 #ifdef DEBUG
 599         write (iout,*) "energies after REDUCE"
 600         call enerprint(energia)
 601         call flush(iout)
 602 #endif
 603         time_Reduce=time_Reduce+MPI_Wtime()-time00
 604       endif
 605       if (fg_rank.eq.0) then
 606 #endif
 607       evdw=energia(1)
 608 #ifdef SCP14
 609       evdw2=energia(2)+energia(18)
 610       evdw2_14=energia(18)
 611 #else
 612       evdw2=energia(2)
 613 #endif
 614 #ifdef SPLITELE
 615       ees=energia(3)
 616       evdw1=energia(16)
 617 #else
 618       ees=energia(3)
 619       evdw1=0.0d0
 620 #endif
 621       ecorr=energia(4)
 622       ecorr5=energia(5)
 623       ecorr6=energia(6)
 624       eel_loc=energia(7)
 625       eello_turn3=energia(8)
 626       eello_turn4=energia(9)
 627       eturn6=energia(10)
 628       ebe=energia(11)
 629       escloc=energia(12)
 630       etors=energia(13)
 631       etors_d=energia(14)
 632       ehpb=energia(15)
 633       edihcnstr=energia(19)
 634       estr=energia(17)
 635       Uconst=energia(20)
 636       esccor=energia(21)
 637 #ifdef SPLITELE
 638       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 639        +wang*ebe+wtor*etors+wscloc*escloc &
 640        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 641        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 642        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 643        +wbond*estr+Uconst+wsccor*esccor
 644 #else
 645       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 646        +wang*ebe+wtor*etors+wscloc*escloc &
 647        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 648        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 649        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 650        +wbond*estr+Uconst+wsccor*esccor
 651 #endif
 652       energia(0)=etot
 653 ! detecting NaNQ
 654 #ifdef ISNAN
 655 #ifdef AIX
 656       if (isnan(etot).ne.0) energia(0)=1.0d+99
 657 #else
 658       if (isnan(etot)) energia(0)=1.0d+99
 659 #endif
 660 #else
 661       i=0
 662 #ifdef WINPGI
 663       idumm=proc_proc(etot,i)
 664 #else
 665       call proc_proc(etot,i)
 666 #endif
 667       if(i.eq.1)energia(0)=1.0d+99
 668 #endif
 669 #ifdef MPI
 670       endif
 671 #endif
 672 !      call enerprint(energia)
 673       call flush(iout)
 674       return
 675       end subroutine sum_energy
 676 !-----------------------------------------------------------------------------
 677       subroutine rescale_weights(t_bath)
 678 !      implicit real*8 (a-h,o-z)
 679 #ifdef MPI
 680       include 'mpif.h'
 681 #endif
 682 !      include 'DIMENSIONS'
 683 !      include 'COMMON.IOUNITS'
 684 !      include 'COMMON.FFIELD'
 685 !      include 'COMMON.SBRIDGE'
 686       real(kind=8) :: kfac=2.4d0
 687       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 688 !el local variables
 689       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 690       real(kind=8) :: T0=3.0d2
 691       integer :: ierror
 692 !      facT=temp0/t_bath
 693 !      facT=2*temp0/(t_bath+temp0)
 694       if (rescale_mode.eq.0) then
 695         facT(1)=1.0d0
 696         facT(2)=1.0d0
 697         facT(3)=1.0d0
 698         facT(4)=1.0d0
 699         facT(5)=1.0d0
 700         facT(6)=1.0d0
 701       else if (rescale_mode.eq.1) then
 702         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 703         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 704         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 705         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 706         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 707 #ifdef WHAM_RUN
 708 !#if defined(WHAM_RUN) || defined(CLUSTER)
 709 #if defined(FUNCTH)
 710 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 711         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 712 #elif defined(FUNCT)
 713         facT(6)=t_bath/T0
 714 #else
 715         facT(6)=1.0d0
 716 #endif
 717 #endif
 718       else if (rescale_mode.eq.2) then
 719         x=t_bath/temp0
 720         x2=x*x
 721         x3=x2*x
 722         x4=x3*x
 723         x5=x4*x
 724         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 725         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 726         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 727         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 728         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 729 #ifdef WHAM_RUN
 730 !#if defined(WHAM_RUN) || defined(CLUSTER)
 731 #if defined(FUNCTH)
 732         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 733 #elif defined(FUNCT)
 734         facT(6)=t_bath/T0
 735 #else
 736         facT(6)=1.0d0
 737 #endif
 738 #endif
 739       else
 740         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 741         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 742 #ifdef MPI
 743        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 744 #endif
 745        stop 555
 746       endif
 747       welec=weights(3)*fact(1)
 748       wcorr=weights(4)*fact(3)
 749       wcorr5=weights(5)*fact(4)
 750       wcorr6=weights(6)*fact(5)
 751       wel_loc=weights(7)*fact(2)
 752       wturn3=weights(8)*fact(2)
 753       wturn4=weights(9)*fact(3)
 754       wturn6=weights(10)*fact(5)
 755       wtor=weights(13)*fact(1)
 756       wtor_d=weights(14)*fact(2)
 757       wsccor=weights(21)*fact(1)
 758
 759       return
 760       end subroutine rescale_weights
 761 !-----------------------------------------------------------------------------
 762       subroutine enerprint(energia)
 763 !      implicit real*8 (a-h,o-z)
 764 !      include 'DIMENSIONS'
 765 !      include 'COMMON.IOUNITS'
 766 !      include 'COMMON.FFIELD'
 767 !      include 'COMMON.SBRIDGE'
 768 !      include 'COMMON.MD'
 769       real(kind=8) :: energia(0:n_ene)
 770 !el local variables
 771       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 772       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 773       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor
 774
 775       etot=energia(0)
 776       evdw=energia(1)
 777       evdw2=energia(2)
 778 #ifdef SCP14
 779       evdw2=energia(2)+energia(18)
 780 #else
 781       evdw2=energia(2)
 782 #endif
 783       ees=energia(3)
 784 #ifdef SPLITELE
 785       evdw1=energia(16)
 786 #endif
 787       ecorr=energia(4)
 788       ecorr5=energia(5)
 789       ecorr6=energia(6)
 790       eel_loc=energia(7)
 791       eello_turn3=energia(8)
 792       eello_turn4=energia(9)
 793       eello_turn6=energia(10)
 794       ebe=energia(11)
 795       escloc=energia(12)
 796       etors=energia(13)
 797       etors_d=energia(14)
 798       ehpb=energia(15)
 799       edihcnstr=energia(19)
 800       estr=energia(17)
 801       Uconst=energia(20)
 802       esccor=energia(21)
 803 #ifdef SPLITELE
 804       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 805         estr,wbond,ebe,wang,&
 806         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 807         ecorr,wcorr,&
 808         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 809         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 810         edihcnstr,ebr*nss,&
 811         Uconst,etot
 812    10 format (/'Virtual-chain energies:'// &
 813        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 814        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 815        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 816        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 817        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 818        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 819        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 820        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 821        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 822        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 823        ' (SS bridges & dist. cnstr.)'/ &
 824        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 825        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 826        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 827        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 828        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 829        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 830        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 831        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 832        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 833        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 834        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 835        'ETOT=  ',1pE16.6,' (total)')
 836 #else
 837       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 838         estr,wbond,ebe,wang,&
 839         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 840         ecorr,wcorr,&
 841         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 842         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 843         ebr*nss,Uconst,etot
 844    10 format (/'Virtual-chain energies:'// &
 845        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 846        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 847        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 848        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 849        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 850        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 851        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 852        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 853        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 854        ' (SS bridges & dist. cnstr.)'/ &
 855        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 856        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 857        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 858        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 859        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 860        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 861        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 862        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 863        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 864        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 865        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 866        'ETOT=  ',1pE16.6,' (total)')
 867 #endif
 868       return
 869       end subroutine enerprint
 870 !-----------------------------------------------------------------------------
 871       subroutine elj(evdw)
 872 !
 873 ! This subroutine calculates the interaction energy of nonbonded side chains
 874 ! assuming the LJ potential of interaction.
 875 !
 876 !      implicit real*8 (a-h,o-z)
 877 !      include 'DIMENSIONS'
 878       real(kind=8),parameter :: accur=1.0d-10
 879 !      include 'COMMON.GEO'
 880 !      include 'COMMON.VAR'
 881 !      include 'COMMON.LOCAL'
 882 !      include 'COMMON.CHAIN'
 883 !      include 'COMMON.DERIV'
 884 !      include 'COMMON.INTERACT'
 885 !      include 'COMMON.TORSION'
 886 !      include 'COMMON.SBRIDGE'
 887 !      include 'COMMON.NAMES'
 888 !      include 'COMMON.IOUNITS'
 889 !      include 'COMMON.CONTACTS'
 890       real(kind=8),dimension(3) :: gg
 891       integer :: num_conti
 892 !el local variables
 893       integer :: i,itypi,iint,j,itypi1,itypj,k
 894       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 895       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 896       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 897
 898 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 899       evdw=0.0D0
 900 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 901 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 902 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 903 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 904
 905       do i=iatsc_s,iatsc_e
 906         itypi=iabs(itype(i))
 907         if (itypi.eq.ntyp1) cycle
 908         itypi1=iabs(itype(i+1))
 909         xi=c(1,nres+i)
 910         yi=c(2,nres+i)
 911         zi=c(3,nres+i)
 912 ! Change 12/1/95
 913         num_conti=0
 914 !
 915 ! Calculate SC interaction energy.
 916 !
 917         do iint=1,nint_gr(i)
 918 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 919 !d   &                  'iend=',iend(i,iint)
 920           do j=istart(i,iint),iend(i,iint)
 921             itypj=iabs(itype(j))
 922             if (itypj.eq.ntyp1) cycle
 923             xj=c(1,nres+j)-xi
 924             yj=c(2,nres+j)-yi
 925             zj=c(3,nres+j)-zi
 926 ! Change 12/1/95 to calculate four-body interactions
 927             rij=xj*xj+yj*yj+zj*zj
 928             rrij=1.0D0/rij
 929 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 930             eps0ij=eps(itypi,itypj)
 931             fac=rrij**expon2
 932             e1=fac*fac*aa(itypi,itypj)
 933             e2=fac*bb(itypi,itypj)
 934             evdwij=e1+e2
 935 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 936 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 937 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 938 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 939 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 940 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 941             evdw=evdw+evdwij
 942 !
 943 ! Calculate the components of the gradient in DC and X
 944 !
 945             fac=-rrij*(e1+evdwij)
 946             gg(1)=xj*fac
 947             gg(2)=yj*fac
 948             gg(3)=zj*fac
 949             do k=1,3
 950               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 951               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 952               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 953               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 954             enddo
 955 !grad            do k=i,j-1
 956 !grad              do l=1,3
 957 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 958 !grad              enddo
 959 !grad            enddo
 960 !
 961 ! 12/1/95, revised on 5/20/97
 962 !
 963 ! Calculate the contact function. The ith column of the array JCONT will
 964 ! contain the numbers of atoms that make contacts with the atom I (of numbers
 965 ! greater than I). The arrays FACONT and GACONT will contain the values of
 966 ! the contact function and its derivative.
 967 !
 968 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
 969 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 970 ! Uncomment next line, if the correlation interactions are contact function only
 971             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 972               rij=dsqrt(rij)
 973               sigij=sigma(itypi,itypj)
 974               r0ij=rs0(itypi,itypj)
 975 !
 976 ! Check whether the SC's are not too far to make a contact.
 977 !
 978               rcut=1.5d0*r0ij
 979               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 980 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 981 !
 982               if (fcont.gt.0.0D0) then
 983 ! If the SC-SC distance if close to sigma, apply spline.
 984 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 985 !Adam &             fcont1,fprimcont1)
 986 !Adam           fcont1=1.0d0-fcont1
 987 !Adam           if (fcont1.gt.0.0d0) then
 988 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 989 !Adam             fcont=fcont*fcont1
 990 !Adam           endif
 991 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
 992 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
 993 !ga             do k=1,3
 994 !ga               gg(k)=gg(k)*eps0ij
 995 !ga             enddo
 996 !ga             eps0ij=-evdwij*eps0ij
 997 ! Uncomment for AL's type of SC correlation interactions.
 998 !adam           eps0ij=-evdwij
 999                 num_conti=num_conti+1
1000                 jcont(num_conti,i)=j
1001                 facont(num_conti,i)=fcont*eps0ij
1002                 fprimcont=eps0ij*fprimcont/rij
1003                 fcont=expon*fcont
1004 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1005 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1006 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1007 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1008                 gacont(1,num_conti,i)=-fprimcont*xj
1009                 gacont(2,num_conti,i)=-fprimcont*yj
1010                 gacont(3,num_conti,i)=-fprimcont*zj
1011 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1012 !d              write (iout,'(2i3,3f10.5)')
1013 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1014               endif
1015             endif
1016           enddo      ! j
1017         enddo        ! iint
1018 ! Change 12/1/95
1019         num_cont(i)=num_conti
1020       enddo          ! i
1021       do i=1,nct
1022         do j=1,3
1023           gvdwc(j,i)=expon*gvdwc(j,i)
1024           gvdwx(j,i)=expon*gvdwx(j,i)
1025         enddo
1026       enddo
1027 !******************************************************************************
1028 !
1029 !                              N O T E !!!
1030 !
1031 ! To save time, the factor of EXPON has been extracted from ALL components
1032 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1033 ! use!
1034 !
1035 !******************************************************************************
1036       return
1037       end subroutine elj
1038 !-----------------------------------------------------------------------------
1039       subroutine eljk(evdw)
1040 !
1041 ! This subroutine calculates the interaction energy of nonbonded side chains
1042 ! assuming the LJK potential of interaction.
1043 !
1044 !      implicit real*8 (a-h,o-z)
1045 !      include 'DIMENSIONS'
1046 !      include 'COMMON.GEO'
1047 !      include 'COMMON.VAR'
1048 !      include 'COMMON.LOCAL'
1049 !      include 'COMMON.CHAIN'
1050 !      include 'COMMON.DERIV'
1051 !      include 'COMMON.INTERACT'
1052 !      include 'COMMON.IOUNITS'
1053 !      include 'COMMON.NAMES'
1054       real(kind=8),dimension(3) :: gg
1055       logical :: scheck
1056 !el local variables
1057       integer :: i,iint,j,itypi,itypi1,k,itypj
1058       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1059       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1060
1061 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 !
1071 ! Calculate SC interaction energy.
1072 !
1073         do iint=1,nint_gr(i)
1074           do j=istart(i,iint),iend(i,iint)
1075             itypj=iabs(itype(j))
1076             if (itypj.eq.ntyp1) cycle
1077             xj=c(1,nres+j)-xi
1078             yj=c(2,nres+j)-yi
1079             zj=c(3,nres+j)-zi
1080             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1081             fac_augm=rrij**expon
1082             e_augm=augm(itypi,itypj)*fac_augm
1083             r_inv_ij=dsqrt(rrij)
1084             rij=1.0D0/r_inv_ij
1085             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1086             fac=r_shift_inv**expon
1087             e1=fac*fac*aa(itypi,itypj)
1088             e2=fac*bb(itypi,itypj)
1089             evdwij=e_augm+e1+e2
1090 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1091 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1092 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1093 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1094 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1095 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1096 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1097             evdw=evdw+evdwij
1098 !
1099 ! Calculate the components of the gradient in DC and X
1100 !
1101             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1102             gg(1)=xj*fac
1103             gg(2)=yj*fac
1104             gg(3)=zj*fac
1105             do k=1,3
1106               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1107               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1108               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1109               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1110             enddo
1111 !grad            do k=i,j-1
1112 !grad              do l=1,3
1113 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1114 !grad              enddo
1115 !grad            enddo
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       do i=1,nct
1120         do j=1,3
1121           gvdwc(j,i)=expon*gvdwc(j,i)
1122           gvdwx(j,i)=expon*gvdwx(j,i)
1123         enddo
1124       enddo
1125       return
1126       end subroutine eljk
1127 !-----------------------------------------------------------------------------
1128       subroutine ebp(evdw)
1129 !
1130 ! This subroutine calculates the interaction energy of nonbonded side chains
1131 ! assuming the Berne-Pechukas potential of interaction.
1132 !
1133       use comm_srutu
1134       use calc_data
1135 !      implicit real*8 (a-h,o-z)
1136 !      include 'DIMENSIONS'
1137 !      include 'COMMON.GEO'
1138 !      include 'COMMON.VAR'
1139 !      include 'COMMON.LOCAL'
1140 !      include 'COMMON.CHAIN'
1141 !      include 'COMMON.DERIV'
1142 !      include 'COMMON.NAMES'
1143 !      include 'COMMON.INTERACT'
1144 !      include 'COMMON.IOUNITS'
1145 !      include 'COMMON.CALC'
1146       use comm_srutu
1147 !el      integer :: icall
1148 !el      common /srutu/ icall
1149 !     double precision rrsave(maxdim)
1150       logical :: lprn
1151 !el local variables
1152       integer :: iint,itypi,itypi1,itypj
1153       real(kind=8) :: rrij,xi,yi,zi
1154       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1155
1156 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1157       evdw=0.0D0
1158 !     if (icall.eq.0) then
1159 !       lprn=.true.
1160 !     else
1161         lprn=.false.
1162 !     endif
1163 !el      ind=0
1164       do i=iatsc_s,iatsc_e
1165         itypi=iabs(itype(i))
1166         if (itypi.eq.ntyp1) cycle
1167         itypi1=iabs(itype(i+1))
1168         xi=c(1,nres+i)
1169         yi=c(2,nres+i)
1170         zi=c(3,nres+i)
1171         dxi=dc_norm(1,nres+i)
1172         dyi=dc_norm(2,nres+i)
1173         dzi=dc_norm(3,nres+i)
1174 !        dsci_inv=dsc_inv(itypi)
1175         dsci_inv=vbld_inv(i+nres)
1176 !
1177 ! Calculate SC interaction energy.
1178 !
1179         do iint=1,nint_gr(i)
1180           do j=istart(i,iint),iend(i,iint)
1181 !el            ind=ind+1
1182             itypj=iabs(itype(j))
1183             if (itypj.eq.ntyp1) cycle
1184 !            dscj_inv=dsc_inv(itypj)
1185             dscj_inv=vbld_inv(j+nres)
1186             chi1=chi(itypi,itypj)
1187             chi2=chi(itypj,itypi)
1188             chi12=chi1*chi2
1189             chip1=chip(itypi)
1190             chip2=chip(itypj)
1191             chip12=chip1*chip2
1192             alf1=alp(itypi)
1193             alf2=alp(itypj)
1194             alf12=0.5D0*(alf1+alf2)
1195 ! For diagnostics only!!!
1196 !           chi1=0.0D0
1197 !           chi2=0.0D0
1198 !           chi12=0.0D0
1199 !           chip1=0.0D0
1200 !           chip2=0.0D0
1201 !           chip12=0.0D0
1202 !           alf1=0.0D0
1203 !           alf2=0.0D0
1204 !           alf12=0.0D0
1205             xj=c(1,nres+j)-xi
1206             yj=c(2,nres+j)-yi
1207             zj=c(3,nres+j)-zi
1208             dxj=dc_norm(1,nres+j)
1209             dyj=dc_norm(2,nres+j)
1210             dzj=dc_norm(3,nres+j)
1211             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1212 !d          if (icall.eq.0) then
1213 !d            rrsave(ind)=rrij
1214 !d          else
1215 !d            rrij=rrsave(ind)
1216 !d          endif
1217             rij=dsqrt(rrij)
1218 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1219             call sc_angular
1220 ! Calculate whole angle-dependent part of epsilon and contributions
1221 ! to its derivatives
1222             fac=(rrij*sigsq)**expon2
1223             e1=fac*fac*aa(itypi,itypj)
1224             e2=fac*bb(itypi,itypj)
1225             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1226             eps2der=evdwij*eps3rt
1227             eps3der=evdwij*eps2rt
1228             evdwij=evdwij*eps2rt*eps3rt
1229             evdw=evdw+evdwij
1230             if (lprn) then
1231             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1232             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1233 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1234 !d     &        restyp(itypi),i,restyp(itypj),j,
1235 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1236 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1237 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1238 !d     &        evdwij
1239             endif
1240 ! Calculate gradient components.
1241             e1=e1*eps1*eps2rt**2*eps3rt**2
1242             fac=-expon*(e1+evdwij)
1243             sigder=fac/sigsq
1244             fac=rrij*fac
1245 ! Calculate radial part of the gradient
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249 ! Calculate the angular part of the gradient and sum add the contributions
1250 ! to the appropriate components of the Cartesian gradient.
1251             call sc_grad
1252           enddo      ! j
1253         enddo        ! iint
1254       enddo          ! i
1255 !     stop
1256       return
1257       end subroutine ebp
1258 !-----------------------------------------------------------------------------
1259       subroutine egb(evdw)
1260 !
1261 ! This subroutine calculates the interaction energy of nonbonded side chains
1262 ! assuming the Gay-Berne potential of interaction.
1263 !
1264       use calc_data
1265 !      implicit real*8 (a-h,o-z)
1266 !      include 'DIMENSIONS'
1267 !      include 'COMMON.GEO'
1268 !      include 'COMMON.VAR'
1269 !      include 'COMMON.LOCAL'
1270 !      include 'COMMON.CHAIN'
1271 !      include 'COMMON.DERIV'
1272 !      include 'COMMON.NAMES'
1273 !      include 'COMMON.INTERACT'
1274 !      include 'COMMON.IOUNITS'
1275 !      include 'COMMON.CALC'
1276 !      include 'COMMON.CONTROL'
1277 !      include 'COMMON.SBRIDGE'
1278       logical :: lprn
1279 !el local variables
1280       integer :: iint,itypi,itypi1,itypj,subchap
1281       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1282       real(kind=8) :: evdw,sig0ij
1283       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1284                     dist_temp, dist_init
1285       integer :: ii
1286 !cccc      energy_dec=.false.
1287 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1288       evdw=0.0D0
1289       lprn=.false.
1290 !     if (icall.eq.0) lprn=.false.
1291 !el      ind=0
1292       do i=iatsc_s,iatsc_e
1293         itypi=iabs(itype(i))
1294         if (itypi.eq.ntyp1) cycle
1295         itypi1=iabs(itype(i+1))
1296         xi=c(1,nres+i)
1297         yi=c(2,nres+i)
1298         zi=c(3,nres+i)
1299           xi=dmod(xi,boxxsize)
1300           if (xi.lt.0) xi=xi+boxxsize
1301           yi=dmod(yi,boxysize)
1302           if (yi.lt.0) yi=yi+boxysize
1303           zi=dmod(zi,boxzsize)
1304           if (zi.lt.0) zi=zi+boxzsize
1305
1306         dxi=dc_norm(1,nres+i)
1307         dyi=dc_norm(2,nres+i)
1308         dzi=dc_norm(3,nres+i)
1309 !        dsci_inv=dsc_inv(itypi)
1310         dsci_inv=vbld_inv(i+nres)
1311 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1312 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1313 !
1314 ! Calculate SC interaction energy.
1315 !
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1319               call dyn_ssbond_ene(i,j,evdwij)
1320               evdw=evdw+evdwij
1321               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1322                               'evdw',i,j,evdwij,' ss'
1323 !              if (energy_dec) write (iout,*) &
1324 !                              'evdw',i,j,evdwij,' ss'
1325             ELSE
1326 !el            ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 !            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1332 !              1.0d0/vbld(j+nres) !d
1333 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1334             sig0ij=sigma(itypi,itypj)
1335             chi1=chi(itypi,itypj)
1336             chi2=chi(itypj,itypi)
1337             chi12=chi1*chi2
1338             chip1=chip(itypi)
1339             chip2=chip(itypj)
1340             chip12=chip1*chip2
1341             alf1=alp(itypi)
1342             alf2=alp(itypj)
1343             alf12=0.5D0*(alf1+alf2)
1344 ! For diagnostics only!!!
1345 !           chi1=0.0D0
1346 !           chi2=0.0D0
1347 !           chi12=0.0D0
1348 !           chip1=0.0D0
1349 !           chip2=0.0D0
1350 !           chip12=0.0D0
1351 !           alf1=0.0D0
1352 !           alf2=0.0D0
1353 !           alf12=0.0D0
1354            xj=c(1,nres+j)
1355            yj=c(2,nres+j)
1356            zj=c(3,nres+j)
1357           xj=dmod(xj,boxxsize)
1358           if (xj.lt.0) xj=xj+boxxsize
1359           yj=dmod(yj,boxysize)
1360           if (yj.lt.0) yj=yj+boxysize
1361           zj=dmod(zj,boxzsize)
1362           if (zj.lt.0) zj=zj+boxzsize
1363       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1364       xj_safe=xj
1365       yj_safe=yj
1366       zj_safe=zj
1367       subchap=0
1368       do xshift=-1,1
1369       do yshift=-1,1
1370       do zshift=-1,1
1371           xj=xj_safe+xshift*boxxsize
1372           yj=yj_safe+yshift*boxysize
1373           zj=zj_safe+zshift*boxzsize
1374           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1375           if(dist_temp.lt.dist_init) then
1376             dist_init=dist_temp
1377             xj_temp=xj
1378             yj_temp=yj
1379             zj_temp=zj
1380             subchap=1
1381           endif
1382        enddo
1383        enddo
1384        enddo
1385        if (subchap.eq.1) then
1386           xj=xj_temp-xi
1387           yj=yj_temp-yi
1388           zj=zj_temp-zi
1389        else
1390           xj=xj_safe-xi
1391           yj=yj_safe-yi
1392           zj=zj_safe-zi
1393        endif
1394             dxj=dc_norm(1,nres+j)
1395             dyj=dc_norm(2,nres+j)
1396             dzj=dc_norm(3,nres+j)
1397 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1398 !            write (iout,*) "j",j," dc_norm",& !d
1399 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1400 !          write(iout,*)"rrij ",rrij
1401 !          write(iout,*)"xj yj zj ", xj, yj, zj
1402 !          write(iout,*)"xi yi zi ", xi, yi, zi
1403 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1404             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1405             rij=dsqrt(rrij)
1406             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1407             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1408 !            print *,sss_ele_cut,sss_ele_grad,&
1409 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1410             if (sss_ele_cut.le.0.0) cycle
1411 ! Calculate angle-dependent terms of energy and contributions to their
1412 ! derivatives.
1413             call sc_angular
1414             sigsq=1.0D0/sigsq
1415             sig=sig0ij*dsqrt(sigsq)
1416             rij_shift=1.0D0/rij-sig+sig0ij
1417 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1418 !            "sig0ij",sig0ij
1419 ! for diagnostics; uncomment
1420 !            rij_shift=1.2*sig0ij
1421 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1422             if (rij_shift.le.0.0D0) then
1423               evdw=1.0D20
1424 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1425 !d     &        restyp(itypi),i,restyp(itypj),j,
1426 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1427               return
1428             endif
1429             sigder=-sig*sigsq
1430 !---------------------------------------------------------------
1431             rij_shift=1.0D0/rij_shift
1432             fac=rij_shift**expon
1433             e1=fac*fac*aa(itypi,itypj)
1434             e2=fac*bb(itypi,itypj)
1435             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1436             eps2der=evdwij*eps3rt
1437             eps3der=evdwij*eps2rt
1438 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1439 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1440 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1441             evdwij=evdwij*eps2rt*eps3rt
1442             evdw=evdw+evdwij*sss_ele_cut
1443             if (lprn) then
1444             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1445             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1446             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1447               restyp(itypi),i,restyp(itypj),j, &
1448               epsi,sigm,chi1,chi2,chip1,chip2, &
1449               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1450               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1451               evdwij
1452             endif
1453
1454             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
1455                              'evdw',i,j,evdwij !,"egb"
1456 !            if (energy_dec) write (iout,*) &
1457 !                             'evdw',i,j,evdwij
1458
1459 ! Calculate gradient components.
1460             e1=e1*eps1*eps2rt**2*eps3rt**2
1461             fac=-expon*(e1+evdwij)*rij_shift
1462             sigder=fac*sigder
1463             fac=rij*fac
1464 !            print *,'before fac',fac,rij,evdwij
1465             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1466             /sigma(itypi,itypj)*rij
1467 !            print *,'grad part scale',fac,   &
1468 !             evdwij*sss_ele_grad/sss_ele_cut &
1469 !            /sigma(itypi,itypj)*rij
1470 !            fac=0.0d0
1471 ! Calculate the radial part of the gradient
1472             gg(1)=xj*fac
1473             gg(2)=yj*fac
1474             gg(3)=zj*fac
1475 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1476 ! Calculate angular part of the gradient.
1477             call sc_grad
1478             ENDIF    ! dyn_ss
1479           enddo      ! j
1480         enddo        ! iint
1481       enddo          ! i
1482 !      write (iout,*) "Number of loop steps in EGB:",ind
1483 !ccc      energy_dec=.false.
1484       return
1485       end subroutine egb
1486 !-----------------------------------------------------------------------------
1487       subroutine egbv(evdw)
1488 !
1489 ! This subroutine calculates the interaction energy of nonbonded side chains
1490 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1491 !
1492       use comm_srutu
1493       use calc_data
1494 !      implicit real*8 (a-h,o-z)
1495 !      include 'DIMENSIONS'
1496 !      include 'COMMON.GEO'
1497 !      include 'COMMON.VAR'
1498 !      include 'COMMON.LOCAL'
1499 !      include 'COMMON.CHAIN'
1500 !      include 'COMMON.DERIV'
1501 !      include 'COMMON.NAMES'
1502 !      include 'COMMON.INTERACT'
1503 !      include 'COMMON.IOUNITS'
1504 !      include 'COMMON.CALC'
1505       use comm_srutu
1506 !el      integer :: icall
1507 !el      common /srutu/ icall
1508       logical :: lprn
1509 !el local variables
1510       integer :: iint,itypi,itypi1,itypj
1511       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1512       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1513
1514 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       lprn=.false.
1517 !     if (icall.eq.0) lprn=.true.
1518 !el      ind=0
1519       do i=iatsc_s,iatsc_e
1520         itypi=iabs(itype(i))
1521         if (itypi.eq.ntyp1) cycle
1522         itypi1=iabs(itype(i+1))
1523         xi=c(1,nres+i)
1524         yi=c(2,nres+i)
1525         zi=c(3,nres+i)
1526         dxi=dc_norm(1,nres+i)
1527         dyi=dc_norm(2,nres+i)
1528         dzi=dc_norm(3,nres+i)
1529 !        dsci_inv=dsc_inv(itypi)
1530         dsci_inv=vbld_inv(i+nres)
1531 !
1532 ! Calculate SC interaction energy.
1533 !
1534         do iint=1,nint_gr(i)
1535           do j=istart(i,iint),iend(i,iint)
1536 !el            ind=ind+1
1537             itypj=iabs(itype(j))
1538             if (itypj.eq.ntyp1) cycle
1539 !            dscj_inv=dsc_inv(itypj)
1540             dscj_inv=vbld_inv(j+nres)
1541             sig0ij=sigma(itypi,itypj)
1542             r0ij=r0(itypi,itypj)
1543             chi1=chi(itypi,itypj)
1544             chi2=chi(itypj,itypi)
1545             chi12=chi1*chi2
1546             chip1=chip(itypi)
1547             chip2=chip(itypj)
1548             chip12=chip1*chip2
1549             alf1=alp(itypi)
1550             alf2=alp(itypj)
1551             alf12=0.5D0*(alf1+alf2)
1552 ! For diagnostics only!!!
1553 !           chi1=0.0D0
1554 !           chi2=0.0D0
1555 !           chi12=0.0D0
1556 !           chip1=0.0D0
1557 !           chip2=0.0D0
1558 !           chip12=0.0D0
1559 !           alf1=0.0D0
1560 !           alf2=0.0D0
1561 !           alf12=0.0D0
1562             xj=c(1,nres+j)-xi
1563             yj=c(2,nres+j)-yi
1564             zj=c(3,nres+j)-zi
1565             dxj=dc_norm(1,nres+j)
1566             dyj=dc_norm(2,nres+j)
1567             dzj=dc_norm(3,nres+j)
1568             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1569             rij=dsqrt(rrij)
1570 ! Calculate angle-dependent terms of energy and contributions to their
1571 ! derivatives.
1572             call sc_angular
1573             sigsq=1.0D0/sigsq
1574             sig=sig0ij*dsqrt(sigsq)
1575             rij_shift=1.0D0/rij-sig+r0ij
1576 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1577             if (rij_shift.le.0.0D0) then
1578               evdw=1.0D20
1579               return
1580             endif
1581             sigder=-sig*sigsq
1582 !---------------------------------------------------------------
1583             rij_shift=1.0D0/rij_shift
1584             fac=rij_shift**expon
1585             e1=fac*fac*aa(itypi,itypj)
1586             e2=fac*bb(itypi,itypj)
1587             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1588             eps2der=evdwij*eps3rt
1589             eps3der=evdwij*eps2rt
1590             fac_augm=rrij**expon
1591             e_augm=augm(itypi,itypj)*fac_augm
1592             evdwij=evdwij*eps2rt*eps3rt
1593             evdw=evdw+evdwij+e_augm
1594             if (lprn) then
1595             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1596             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1597             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1598               restyp(itypi),i,restyp(itypj),j,&
1599               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1600               chi1,chi2,chip1,chip2,&
1601               eps1,eps2rt**2,eps3rt**2,&
1602               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1603               evdwij+e_augm
1604             endif
1605 ! Calculate gradient components.
1606             e1=e1*eps1*eps2rt**2*eps3rt**2
1607             fac=-expon*(e1+evdwij)*rij_shift
1608             sigder=fac*sigder
1609             fac=rij*fac-2*expon*rrij*e_augm
1610 ! Calculate the radial part of the gradient
1611             gg(1)=xj*fac
1612             gg(2)=yj*fac
1613             gg(3)=zj*fac
1614 ! Calculate angular part of the gradient.
1615             call sc_grad
1616           enddo      ! j
1617         enddo        ! iint
1618       enddo          ! i
1619       end subroutine egbv
1620 !-----------------------------------------------------------------------------
1621 !el      subroutine sc_angular in module geometry
1622 !-----------------------------------------------------------------------------
1623       subroutine e_softsphere(evdw)
1624 !
1625 ! This subroutine calculates the interaction energy of nonbonded side chains
1626 ! assuming the LJ potential of interaction.
1627 !
1628 !      implicit real*8 (a-h,o-z)
1629 !      include 'DIMENSIONS'
1630       real(kind=8),parameter :: accur=1.0d-10
1631 !      include 'COMMON.GEO'
1632 !      include 'COMMON.VAR'
1633 !      include 'COMMON.LOCAL'
1634 !      include 'COMMON.CHAIN'
1635 !      include 'COMMON.DERIV'
1636 !      include 'COMMON.INTERACT'
1637 !      include 'COMMON.TORSION'
1638 !      include 'COMMON.SBRIDGE'
1639 !      include 'COMMON.NAMES'
1640 !      include 'COMMON.IOUNITS'
1641 !      include 'COMMON.CONTACTS'
1642       real(kind=8),dimension(3) :: gg
1643 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1644 !el local variables
1645       integer :: i,iint,j,itypi,itypi1,itypj,k
1646       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1647       real(kind=8) :: fac
1648
1649       evdw=0.0D0
1650       do i=iatsc_s,iatsc_e
1651         itypi=iabs(itype(i))
1652         if (itypi.eq.ntyp1) cycle
1653         itypi1=iabs(itype(i+1))
1654         xi=c(1,nres+i)
1655         yi=c(2,nres+i)
1656         zi=c(3,nres+i)
1657 !
1658 ! Calculate SC interaction energy.
1659 !
1660         do iint=1,nint_gr(i)
1661 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1662 !d   &                  'iend=',iend(i,iint)
1663           do j=istart(i,iint),iend(i,iint)
1664             itypj=iabs(itype(j))
1665             if (itypj.eq.ntyp1) cycle
1666             xj=c(1,nres+j)-xi
1667             yj=c(2,nres+j)-yi
1668             zj=c(3,nres+j)-zi
1669             rij=xj*xj+yj*yj+zj*zj
1670 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1671             r0ij=r0(itypi,itypj)
1672             r0ijsq=r0ij*r0ij
1673 !            print *,i,j,r0ij,dsqrt(rij)
1674             if (rij.lt.r0ijsq) then
1675               evdwij=0.25d0*(rij-r0ijsq)**2
1676               fac=rij-r0ijsq
1677             else
1678               evdwij=0.0d0
1679               fac=0.0d0
1680             endif
1681             evdw=evdw+evdwij
1682 !
1683 ! Calculate the components of the gradient in DC and X
1684 !
1685             gg(1)=xj*fac
1686             gg(2)=yj*fac
1687             gg(3)=zj*fac
1688             do k=1,3
1689               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1690               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1691               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1692               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1693             enddo
1694 !grad            do k=i,j-1
1695 !grad              do l=1,3
1696 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1697 !grad              enddo
1698 !grad            enddo
1699           enddo ! j
1700         enddo ! iint
1701       enddo ! i
1702       return
1703       end subroutine e_softsphere
1704 !-----------------------------------------------------------------------------
1705       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1706 !
1707 ! Soft-sphere potential of p-p interaction
1708 !
1709 !      implicit real*8 (a-h,o-z)
1710 !      include 'DIMENSIONS'
1711 !      include 'COMMON.CONTROL'
1712 !      include 'COMMON.IOUNITS'
1713 !      include 'COMMON.GEO'
1714 !      include 'COMMON.VAR'
1715 !      include 'COMMON.LOCAL'
1716 !      include 'COMMON.CHAIN'
1717 !      include 'COMMON.DERIV'
1718 !      include 'COMMON.INTERACT'
1719 !      include 'COMMON.CONTACTS'
1720 !      include 'COMMON.TORSION'
1721 !      include 'COMMON.VECTORS'
1722 !      include 'COMMON.FFIELD'
1723       real(kind=8),dimension(3) :: ggg
1724 !d      write(iout,*) 'In EELEC_soft_sphere'
1725 !el local variables
1726       integer :: i,j,k,num_conti,iteli,itelj
1727       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1728       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1729       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1730
1731       ees=0.0D0
1732       evdw1=0.0D0
1733       eel_loc=0.0d0
1734       eello_turn3=0.0d0
1735       eello_turn4=0.0d0
1736 !el      ind=0
1737       do i=iatel_s,iatel_e
1738         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1739         dxi=dc(1,i)
1740         dyi=dc(2,i)
1741         dzi=dc(3,i)
1742         xmedi=c(1,i)+0.5d0*dxi
1743         ymedi=c(2,i)+0.5d0*dyi
1744         zmedi=c(3,i)+0.5d0*dzi
1745         num_conti=0
1746 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1747         do j=ielstart(i),ielend(i)
1748           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1749 !el          ind=ind+1
1750           iteli=itel(i)
1751           itelj=itel(j)
1752           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1753           r0ij=rpp(iteli,itelj)
1754           r0ijsq=r0ij*r0ij
1755           dxj=dc(1,j)
1756           dyj=dc(2,j)
1757           dzj=dc(3,j)
1758           xj=c(1,j)+0.5D0*dxj-xmedi
1759           yj=c(2,j)+0.5D0*dyj-ymedi
1760           zj=c(3,j)+0.5D0*dzj-zmedi
1761           rij=xj*xj+yj*yj+zj*zj
1762           if (rij.lt.r0ijsq) then
1763             evdw1ij=0.25d0*(rij-r0ijsq)**2
1764             fac=rij-r0ijsq
1765           else
1766             evdw1ij=0.0d0
1767             fac=0.0d0
1768           endif
1769           evdw1=evdw1+evdw1ij
1770 !
1771 ! Calculate contributions to the Cartesian gradient.
1772 !
1773           ggg(1)=fac*xj
1774           ggg(2)=fac*yj
1775           ggg(3)=fac*zj
1776           do k=1,3
1777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1778             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1779           enddo
1780 !
1781 ! Loop over residues i+1 thru j-1.
1782 !
1783 !grad          do k=i+1,j-1
1784 !grad            do l=1,3
1785 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1786 !grad            enddo
1787 !grad          enddo
1788         enddo ! j
1789       enddo   ! i
1790 !grad      do i=nnt,nct-1
1791 !grad        do k=1,3
1792 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1793 !grad        enddo
1794 !grad        do j=i+1,nct-1
1795 !grad          do k=1,3
1796 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1797 !grad          enddo
1798 !grad        enddo
1799 !grad      enddo
1800       return
1801       end subroutine eelec_soft_sphere
1802 !-----------------------------------------------------------------------------
1803       subroutine vec_and_deriv
1804 !      implicit real*8 (a-h,o-z)
1805 !      include 'DIMENSIONS'
1806 #ifdef MPI
1807       include 'mpif.h'
1808 #endif
1809 !      include 'COMMON.IOUNITS'
1810 !      include 'COMMON.GEO'
1811 !      include 'COMMON.VAR'
1812 !      include 'COMMON.LOCAL'
1813 !      include 'COMMON.CHAIN'
1814 !      include 'COMMON.VECTORS'
1815 !      include 'COMMON.SETUP'
1816 !      include 'COMMON.TIME1'
1817       real(kind=8),dimension(3,3,2) :: uyder,uzder
1818       real(kind=8),dimension(2) :: vbld_inv_temp
1819 ! Compute the local reference systems. For reference system (i), the
1820 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1821 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1822 !el local variables
1823       integer :: i,j,k,l
1824       real(kind=8) :: facy,fac,costh
1825
1826 #ifdef PARVEC
1827       do i=ivec_start,ivec_end
1828 #else
1829       do i=1,nres-1
1830 #endif
1831           if (i.eq.nres-1) then
1832 ! Case of the last full residue
1833 ! Compute the Z-axis
1834             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1835             costh=dcos(pi-theta(nres))
1836             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1837             do k=1,3
1838               uz(k,i)=fac*uz(k,i)
1839             enddo
1840 ! Compute the derivatives of uz
1841             uzder(1,1,1)= 0.0d0
1842             uzder(2,1,1)=-dc_norm(3,i-1)
1843             uzder(3,1,1)= dc_norm(2,i-1)
1844             uzder(1,2,1)= dc_norm(3,i-1)
1845             uzder(2,2,1)= 0.0d0
1846             uzder(3,2,1)=-dc_norm(1,i-1)
1847             uzder(1,3,1)=-dc_norm(2,i-1)
1848             uzder(2,3,1)= dc_norm(1,i-1)
1849             uzder(3,3,1)= 0.0d0
1850             uzder(1,1,2)= 0.0d0
1851             uzder(2,1,2)= dc_norm(3,i)
1852             uzder(3,1,2)=-dc_norm(2,i)
1853             uzder(1,2,2)=-dc_norm(3,i)
1854             uzder(2,2,2)= 0.0d0
1855             uzder(3,2,2)= dc_norm(1,i)
1856             uzder(1,3,2)= dc_norm(2,i)
1857             uzder(2,3,2)=-dc_norm(1,i)
1858             uzder(3,3,2)= 0.0d0
1859 ! Compute the Y-axis
1860             facy=fac
1861             do k=1,3
1862               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1863             enddo
1864 ! Compute the derivatives of uy
1865             do j=1,3
1866               do k=1,3
1867                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1868                               -dc_norm(k,i)*dc_norm(j,i-1)
1869                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1870               enddo
1871               uyder(j,j,1)=uyder(j,j,1)-costh
1872               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1873             enddo
1874             do j=1,2
1875               do k=1,3
1876                 do l=1,3
1877                   uygrad(l,k,j,i)=uyder(l,k,j)
1878                   uzgrad(l,k,j,i)=uzder(l,k,j)
1879                 enddo
1880               enddo
1881             enddo
1882             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1883             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1884             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1885             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1886           else
1887 ! Other residues
1888 ! Compute the Z-axis
1889             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1890             costh=dcos(pi-theta(i+2))
1891             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1892             do k=1,3
1893               uz(k,i)=fac*uz(k,i)
1894             enddo
1895 ! Compute the derivatives of uz
1896             uzder(1,1,1)= 0.0d0
1897             uzder(2,1,1)=-dc_norm(3,i+1)
1898             uzder(3,1,1)= dc_norm(2,i+1)
1899             uzder(1,2,1)= dc_norm(3,i+1)
1900             uzder(2,2,1)= 0.0d0
1901             uzder(3,2,1)=-dc_norm(1,i+1)
1902             uzder(1,3,1)=-dc_norm(2,i+1)
1903             uzder(2,3,1)= dc_norm(1,i+1)
1904             uzder(3,3,1)= 0.0d0
1905             uzder(1,1,2)= 0.0d0
1906             uzder(2,1,2)= dc_norm(3,i)
1907             uzder(3,1,2)=-dc_norm(2,i)
1908             uzder(1,2,2)=-dc_norm(3,i)
1909             uzder(2,2,2)= 0.0d0
1910             uzder(3,2,2)= dc_norm(1,i)
1911             uzder(1,3,2)= dc_norm(2,i)
1912             uzder(2,3,2)=-dc_norm(1,i)
1913             uzder(3,3,2)= 0.0d0
1914 ! Compute the Y-axis
1915             facy=fac
1916             do k=1,3
1917               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1918             enddo
1919 ! Compute the derivatives of uy
1920             do j=1,3
1921               do k=1,3
1922                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
1923                               -dc_norm(k,i)*dc_norm(j,i+1)
1924                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1925               enddo
1926               uyder(j,j,1)=uyder(j,j,1)-costh
1927               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1928             enddo
1929             do j=1,2
1930               do k=1,3
1931                 do l=1,3
1932                   uygrad(l,k,j,i)=uyder(l,k,j)
1933                   uzgrad(l,k,j,i)=uzder(l,k,j)
1934                 enddo
1935               enddo
1936             enddo
1937             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1938             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1939             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1940             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1941           endif
1942       enddo
1943       do i=1,nres-1
1944         vbld_inv_temp(1)=vbld_inv(i+1)
1945         if (i.lt.nres-1) then
1946           vbld_inv_temp(2)=vbld_inv(i+2)
1947           else
1948           vbld_inv_temp(2)=vbld_inv(i)
1949           endif
1950         do j=1,2
1951           do k=1,3
1952             do l=1,3
1953               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1954               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1955             enddo
1956           enddo
1957         enddo
1958       enddo
1959 #if defined(PARVEC) && defined(MPI)
1960       if (nfgtasks1.gt.1) then
1961         time00=MPI_Wtime()
1962 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
1963 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
1964 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
1965         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
1966          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1967          FG_COMM1,IERR)
1968         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
1969          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
1970          FG_COMM1,IERR)
1971         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
1972          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
1973          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1974         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
1975          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
1976          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
1977         time_gather=time_gather+MPI_Wtime()-time00
1978       endif
1979 !      if (fg_rank.eq.0) then
1980 !        write (iout,*) "Arrays UY and UZ"
1981 !        do i=1,nres-1
1982 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1983 !     &     (uz(k,i),k=1,3)
1984 !        enddo
1985 !      endif
1986 #endif
1987       return
1988       end subroutine vec_and_deriv
1989 !-----------------------------------------------------------------------------
1990       subroutine check_vecgrad
1991 !      implicit real*8 (a-h,o-z)
1992 !      include 'DIMENSIONS'
1993 !      include 'COMMON.IOUNITS'
1994 !      include 'COMMON.GEO'
1995 !      include 'COMMON.VAR'
1996 !      include 'COMMON.LOCAL'
1997 !      include 'COMMON.CHAIN'
1998 !      include 'COMMON.VECTORS'
1999       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2000       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2001       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2002       real(kind=8),dimension(3) :: erij
2003       real(kind=8) :: delta=1.0d-7
2004 !el local variables
2005       integer :: i,j,k,l
2006
2007       call vec_and_deriv
2008 !d      do i=1,nres
2009 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2010 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2011 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2012 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2013 !d     &     (dc_norm(if90,i),if90=1,3)
2014 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2015 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2016 !d          write(iout,'(a)')
2017 !d      enddo
2018       do i=1,nres
2019         do j=1,2
2020           do k=1,3
2021             do l=1,3
2022               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2023               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2024             enddo
2025           enddo
2026         enddo
2027       enddo
2028       call vec_and_deriv
2029       do i=1,nres
2030         do j=1,3
2031           uyt(j,i)=uy(j,i)
2032           uzt(j,i)=uz(j,i)
2033         enddo
2034       enddo
2035       do i=1,nres
2036 !d        write (iout,*) 'i=',i
2037         do k=1,3
2038           erij(k)=dc_norm(k,i)
2039         enddo
2040         do j=1,3
2041           do k=1,3
2042             dc_norm(k,i)=erij(k)
2043           enddo
2044           dc_norm(j,i)=dc_norm(j,i)+delta
2045 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2046 !          do k=1,3
2047 !            dc_norm(k,i)=dc_norm(k,i)/fac
2048 !          enddo
2049 !          write (iout,*) (dc_norm(k,i),k=1,3)
2050 !          write (iout,*) (erij(k),k=1,3)
2051           call vec_and_deriv
2052           do k=1,3
2053             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2054             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2055             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2056             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2057           enddo
2058 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2059 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2060 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2061         enddo
2062         do k=1,3
2063           dc_norm(k,i)=erij(k)
2064         enddo
2065 !d        do k=1,3
2066 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2067 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2068 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2069 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2070 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2071 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2072 !d          write (iout,'(a)')
2073 !d        enddo
2074       enddo
2075       return
2076       end subroutine check_vecgrad
2077 !-----------------------------------------------------------------------------
2078       subroutine set_matrices
2079 !      implicit real*8 (a-h,o-z)
2080 !      include 'DIMENSIONS'
2081 #ifdef MPI
2082       include "mpif.h"
2083 !      include "COMMON.SETUP"
2084       integer :: IERR
2085       integer :: status(MPI_STATUS_SIZE)
2086 #endif
2087 !      include 'COMMON.IOUNITS'
2088 !      include 'COMMON.GEO'
2089 !      include 'COMMON.VAR'
2090 !      include 'COMMON.LOCAL'
2091 !      include 'COMMON.CHAIN'
2092 !      include 'COMMON.DERIV'
2093 !      include 'COMMON.INTERACT'
2094 !      include 'COMMON.CONTACTS'
2095 !      include 'COMMON.TORSION'
2096 !      include 'COMMON.VECTORS'
2097 !      include 'COMMON.FFIELD'
2098       real(kind=8) :: auxvec(2),auxmat(2,2)
2099       integer :: i,iti1,iti,k,l
2100       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2101
2102 !
2103 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2104 ! to calculate the el-loc multibody terms of various order.
2105 !
2106 !AL el      mu=0.0d0
2107 #ifdef PARMAT
2108       do i=ivec_start+2,ivec_end+2
2109 #else
2110       do i=3,nres+1
2111 #endif
2112         if (i .lt. nres+1) then
2113           sin1=dsin(phi(i))
2114           cos1=dcos(phi(i))
2115           sintab(i-2)=sin1
2116           costab(i-2)=cos1
2117           obrot(1,i-2)=cos1
2118           obrot(2,i-2)=sin1
2119           sin2=dsin(2*phi(i))
2120           cos2=dcos(2*phi(i))
2121           sintab2(i-2)=sin2
2122           costab2(i-2)=cos2
2123           obrot2(1,i-2)=cos2
2124           obrot2(2,i-2)=sin2
2125           Ug(1,1,i-2)=-cos1
2126           Ug(1,2,i-2)=-sin1
2127           Ug(2,1,i-2)=-sin1
2128           Ug(2,2,i-2)= cos1
2129           Ug2(1,1,i-2)=-cos2
2130           Ug2(1,2,i-2)=-sin2
2131           Ug2(2,1,i-2)=-sin2
2132           Ug2(2,2,i-2)= cos2
2133         else
2134           costab(i-2)=1.0d0
2135           sintab(i-2)=0.0d0
2136           obrot(1,i-2)=1.0d0
2137           obrot(2,i-2)=0.0d0
2138           obrot2(1,i-2)=0.0d0
2139           obrot2(2,i-2)=0.0d0
2140           Ug(1,1,i-2)=1.0d0
2141           Ug(1,2,i-2)=0.0d0
2142           Ug(2,1,i-2)=0.0d0
2143           Ug(2,2,i-2)=1.0d0
2144           Ug2(1,1,i-2)=0.0d0
2145           Ug2(1,2,i-2)=0.0d0
2146           Ug2(2,1,i-2)=0.0d0
2147           Ug2(2,2,i-2)=0.0d0
2148         endif
2149         if (i .gt. 3 .and. i .lt. nres+1) then
2150           obrot_der(1,i-2)=-sin1
2151           obrot_der(2,i-2)= cos1
2152           Ugder(1,1,i-2)= sin1
2153           Ugder(1,2,i-2)=-cos1
2154           Ugder(2,1,i-2)=-cos1
2155           Ugder(2,2,i-2)=-sin1
2156           dwacos2=cos2+cos2
2157           dwasin2=sin2+sin2
2158           obrot2_der(1,i-2)=-dwasin2
2159           obrot2_der(2,i-2)= dwacos2
2160           Ug2der(1,1,i-2)= dwasin2
2161           Ug2der(1,2,i-2)=-dwacos2
2162           Ug2der(2,1,i-2)=-dwacos2
2163           Ug2der(2,2,i-2)=-dwasin2
2164         else
2165           obrot_der(1,i-2)=0.0d0
2166           obrot_der(2,i-2)=0.0d0
2167           Ugder(1,1,i-2)=0.0d0
2168           Ugder(1,2,i-2)=0.0d0
2169           Ugder(2,1,i-2)=0.0d0
2170           Ugder(2,2,i-2)=0.0d0
2171           obrot2_der(1,i-2)=0.0d0
2172           obrot2_der(2,i-2)=0.0d0
2173           Ug2der(1,1,i-2)=0.0d0
2174           Ug2der(1,2,i-2)=0.0d0
2175           Ug2der(2,1,i-2)=0.0d0
2176           Ug2der(2,2,i-2)=0.0d0
2177         endif
2178 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2179         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2180           iti = itortyp(itype(i-2))
2181         else
2182           iti=ntortyp+1
2183         endif
2184 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2185         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2186           iti1 = itortyp(itype(i-1))
2187         else
2188           iti1=ntortyp+1
2189         endif
2190 !d        write (iout,*) '*******i',i,' iti1',iti
2191 !d        write (iout,*) 'b1',b1(:,iti)
2192 !d        write (iout,*) 'b2',b2(:,iti)
2193 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2194 !        if (i .gt. iatel_s+2) then
2195         if (i .gt. nnt+2) then
2196           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2197           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2198           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2199           then
2200           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2201           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2202           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2203           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2204           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2205           endif
2206         else
2207           do k=1,2
2208             Ub2(k,i-2)=0.0d0
2209             Ctobr(k,i-2)=0.0d0
2210             Dtobr2(k,i-2)=0.0d0
2211             do l=1,2
2212               EUg(l,k,i-2)=0.0d0
2213               CUg(l,k,i-2)=0.0d0
2214               DUg(l,k,i-2)=0.0d0
2215               DtUg2(l,k,i-2)=0.0d0
2216             enddo
2217           enddo
2218         endif
2219         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2220         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2221         do k=1,2
2222           muder(k,i-2)=Ub2der(k,i-2)
2223         enddo
2224 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2225         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2226           if (itype(i-1).le.ntyp) then
2227             iti1 = itortyp(itype(i-1))
2228           else
2229             iti1=ntortyp+1
2230           endif
2231         else
2232           iti1=ntortyp+1
2233         endif
2234         do k=1,2
2235           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2236         enddo
2237 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2238 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2239 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2240 !d        write (iout,*) 'mu1',mu1(:,i-2)
2241 !d        write (iout,*) 'mu2',mu2(:,i-2)
2242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2243         then
2244         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2245         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2246         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2247         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2248         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2249 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2250         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2251         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2252         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2253         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2254         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2255         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2256         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2257         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2258         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2259         endif
2260       enddo
2261 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2262 ! The order of matrices is from left to right.
2263       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2264       then
2265 !      do i=max0(ivec_start,2),ivec_end
2266       do i=2,nres-1
2267         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2268         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2269         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2270         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2271         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2272         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2273         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2274         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2275       enddo
2276       endif
2277 #if defined(MPI) && defined(PARMAT)
2278 #ifdef DEBUG
2279 !      if (fg_rank.eq.0) then
2280         write (iout,*) "Arrays UG and UGDER before GATHER"
2281         do i=1,nres-1
2282           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2283            ((ug(l,k,i),l=1,2),k=1,2),&
2284            ((ugder(l,k,i),l=1,2),k=1,2)
2285         enddo
2286         write (iout,*) "Arrays UG2 and UG2DER"
2287         do i=1,nres-1
2288           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2289            ((ug2(l,k,i),l=1,2),k=1,2),&
2290            ((ug2der(l,k,i),l=1,2),k=1,2)
2291         enddo
2292         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2293         do i=1,nres-1
2294           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2295            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2296            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2297         enddo
2298         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2299         do i=1,nres-1
2300           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2301            costab(i),sintab(i),costab2(i),sintab2(i)
2302         enddo
2303         write (iout,*) "Array MUDER"
2304         do i=1,nres-1
2305           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2306         enddo
2307 !      endif
2308 #endif
2309       if (nfgtasks.gt.1) then
2310         time00=MPI_Wtime()
2311 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2312 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2313 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2314 #ifdef MATGATHER
2315         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2316          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2317          FG_COMM1,IERR)
2318         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2319          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2320          FG_COMM1,IERR)
2321         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2322          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2323          FG_COMM1,IERR)
2324         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2325          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2326          FG_COMM1,IERR)
2327         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2328          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2329          FG_COMM1,IERR)
2330         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2331          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2332          FG_COMM1,IERR)
2333         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2334          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2335          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2336         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2337          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2338          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2339         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2340          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2341          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2342         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2343          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2344          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2345         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2346         then
2347         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2348          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2349          FG_COMM1,IERR)
2350         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2351          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2352          FG_COMM1,IERR)
2353         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2354          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2355          FG_COMM1,IERR)
2356        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2357          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2358          FG_COMM1,IERR)
2359         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2360          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2361          FG_COMM1,IERR)
2362         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2363          ivec_count(fg_rank1),&
2364          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2365          FG_COMM1,IERR)
2366         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2367          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2368          FG_COMM1,IERR)
2369         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2370          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2371          FG_COMM1,IERR)
2372         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2373          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2374          FG_COMM1,IERR)
2375         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2376          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2377          FG_COMM1,IERR)
2378         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2379          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2380          FG_COMM1,IERR)
2381         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2382          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2383          FG_COMM1,IERR)
2384         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2385          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2386          FG_COMM1,IERR)
2387         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2388          ivec_count(fg_rank1),&
2389          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2390          FG_COMM1,IERR)
2391         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2392          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2393          FG_COMM1,IERR)
2394        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2395          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2396          FG_COMM1,IERR)
2397         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2398          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2399          FG_COMM1,IERR)
2400        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2401          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2402          FG_COMM1,IERR)
2403         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2404          ivec_count(fg_rank1),&
2405          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2406          FG_COMM1,IERR)
2407         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2408          ivec_count(fg_rank1),&
2409          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2410          FG_COMM1,IERR)
2411         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2412          ivec_count(fg_rank1),&
2413          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2414          MPI_MAT2,FG_COMM1,IERR)
2415         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2416          ivec_count(fg_rank1),&
2417          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2418          MPI_MAT2,FG_COMM1,IERR)
2419         endif
2420 #else
2421 ! Passes matrix info through the ring
2422       isend=fg_rank1
2423       irecv=fg_rank1-1
2424       if (irecv.lt.0) irecv=nfgtasks1-1
2425       iprev=irecv
2426       inext=fg_rank1+1
2427       if (inext.ge.nfgtasks1) inext=0
2428       do i=1,nfgtasks1-1
2429 !        write (iout,*) "isend",isend," irecv",irecv
2430 !        call flush(iout)
2431         lensend=lentyp(isend)
2432         lenrecv=lentyp(irecv)
2433 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2434 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2435 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2436 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2437 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2438 !        write (iout,*) "Gather ROTAT1"
2439 !        call flush(iout)
2440 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2441 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2442 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2443 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2444 !        write (iout,*) "Gather ROTAT2"
2445 !        call flush(iout)
2446         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2447          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2448          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2449          iprev,4400+irecv,FG_COMM,status,IERR)
2450 !        write (iout,*) "Gather ROTAT_OLD"
2451 !        call flush(iout)
2452         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2453          MPI_PRECOMP11(lensend),inext,5500+isend,&
2454          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2455          iprev,5500+irecv,FG_COMM,status,IERR)
2456 !        write (iout,*) "Gather PRECOMP11"
2457 !        call flush(iout)
2458         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2459          MPI_PRECOMP12(lensend),inext,6600+isend,&
2460          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2461          iprev,6600+irecv,FG_COMM,status,IERR)
2462 !        write (iout,*) "Gather PRECOMP12"
2463 !        call flush(iout)
2464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2465         then
2466         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2467          MPI_ROTAT2(lensend),inext,7700+isend,&
2468          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2469          iprev,7700+irecv,FG_COMM,status,IERR)
2470 !        write (iout,*) "Gather PRECOMP21"
2471 !        call flush(iout)
2472         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2473          MPI_PRECOMP22(lensend),inext,8800+isend,&
2474          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2475          iprev,8800+irecv,FG_COMM,status,IERR)
2476 !        write (iout,*) "Gather PRECOMP22"
2477 !        call flush(iout)
2478         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2479          MPI_PRECOMP23(lensend),inext,9900+isend,&
2480          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2481          MPI_PRECOMP23(lenrecv),&
2482          iprev,9900+irecv,FG_COMM,status,IERR)
2483 !        write (iout,*) "Gather PRECOMP23"
2484 !        call flush(iout)
2485         endif
2486         isend=irecv
2487         irecv=irecv-1
2488         if (irecv.lt.0) irecv=nfgtasks1-1
2489       enddo
2490 #endif
2491         time_gather=time_gather+MPI_Wtime()-time00
2492       endif
2493 #ifdef DEBUG
2494 !      if (fg_rank.eq.0) then
2495         write (iout,*) "Arrays UG and UGDER"
2496         do i=1,nres-1
2497           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2498            ((ug(l,k,i),l=1,2),k=1,2),&
2499            ((ugder(l,k,i),l=1,2),k=1,2)
2500         enddo
2501         write (iout,*) "Arrays UG2 and UG2DER"
2502         do i=1,nres-1
2503           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2504            ((ug2(l,k,i),l=1,2),k=1,2),&
2505            ((ug2der(l,k,i),l=1,2),k=1,2)
2506         enddo
2507         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2508         do i=1,nres-1
2509           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2510            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2511            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2512         enddo
2513         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2514         do i=1,nres-1
2515           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2516            costab(i),sintab(i),costab2(i),sintab2(i)
2517         enddo
2518         write (iout,*) "Array MUDER"
2519         do i=1,nres-1
2520           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2521         enddo
2522 !      endif
2523 #endif
2524 #endif
2525 !d      do i=1,nres
2526 !d        iti = itortyp(itype(i))
2527 !d        write (iout,*) i
2528 !d        do j=1,2
2529 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2530 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2531 !d        enddo
2532 !d      enddo
2533       return
2534       end subroutine set_matrices
2535 !-----------------------------------------------------------------------------
2536       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2537 !
2538 ! This subroutine calculates the average interaction energy and its gradient
2539 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2540 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2541 ! The potential depends both on the distance of peptide-group centers and on
2542 ! the orientation of the CA-CA virtual bonds.
2543 !
2544       use comm_locel
2545 !      implicit real*8 (a-h,o-z)
2546 #ifdef MPI
2547       include 'mpif.h'
2548 #endif
2549 !      include 'DIMENSIONS'
2550 !      include 'COMMON.CONTROL'
2551 !      include 'COMMON.SETUP'
2552 !      include 'COMMON.IOUNITS'
2553 !      include 'COMMON.GEO'
2554 !      include 'COMMON.VAR'
2555 !      include 'COMMON.LOCAL'
2556 !      include 'COMMON.CHAIN'
2557 !      include 'COMMON.DERIV'
2558 !      include 'COMMON.INTERACT'
2559 !      include 'COMMON.CONTACTS'
2560 !      include 'COMMON.TORSION'
2561 !      include 'COMMON.VECTORS'
2562 !      include 'COMMON.FFIELD'
2563 !      include 'COMMON.TIME1'
2564       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2565       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2566       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2567 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2568       real(kind=8),dimension(4) :: muij
2569 !el      integer :: num_conti,j1,j2
2570 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2571 !el        dz_normi,xmedi,ymedi,zmedi
2572
2573 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2574 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2575 !el          num_conti,j1,j2
2576
2577 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2578 #ifdef MOMENT
2579       real(kind=8) :: scal_el=1.0d0
2580 #else
2581       real(kind=8) :: scal_el=0.5d0
2582 #endif
2583 ! 12/13/98
2584 ! 13-go grudnia roku pamietnego...
2585       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2586                                              0.0d0,1.0d0,0.0d0,&
2587                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2588 !el local variables
2589       integer :: i,k,j
2590       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2591       real(kind=8) :: fac,t_eelecij
2592
2593
2594 !d      write(iout,*) 'In EELEC'
2595 !d      do i=1,nloctyp
2596 !d        write(iout,*) 'Type',i
2597 !d        write(iout,*) 'B1',B1(:,i)
2598 !d        write(iout,*) 'B2',B2(:,i)
2599 !d        write(iout,*) 'CC',CC(:,:,i)
2600 !d        write(iout,*) 'DD',DD(:,:,i)
2601 !d        write(iout,*) 'EE',EE(:,:,i)
2602 !d      enddo
2603 !d      call check_vecgrad
2604 !d      stop
2605 !      ees=0.0d0  !AS
2606 !      evdw1=0.0d0
2607 !      eel_loc=0.0d0
2608 !      eello_turn3=0.0d0
2609 !      eello_turn4=0.0d0
2610       t_eelecij=0.0d0
2611       ees=0.0D0
2612       evdw1=0.0D0
2613       eel_loc=0.0d0
2614       eello_turn3=0.0d0
2615       eello_turn4=0.0d0
2616 !
2617
2618       if (icheckgrad.eq.1) then
2619 !el
2620 !        do i=0,2*nres+2
2621 !          dc_norm(1,i)=0.0d0
2622 !          dc_norm(2,i)=0.0d0
2623 !          dc_norm(3,i)=0.0d0
2624 !        enddo
2625         do i=1,nres-1
2626           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2627           do k=1,3
2628             dc_norm(k,i)=dc(k,i)*fac
2629           enddo
2630 !          write (iout,*) 'i',i,' fac',fac
2631         enddo
2632       endif
2633       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2634           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2635           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2636 !        call vec_and_deriv
2637 #ifdef TIMING
2638         time01=MPI_Wtime()
2639 #endif
2640         call set_matrices
2641 #ifdef TIMING
2642         time_mat=time_mat+MPI_Wtime()-time01
2643 #endif
2644       endif
2645 !d      do i=1,nres-1
2646 !d        write (iout,*) 'i=',i
2647 !d        do k=1,3
2648 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2649 !d        enddo
2650 !d        do k=1,3
2651 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2652 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2653 !d        enddo
2654 !d      enddo
2655       t_eelecij=0.0d0
2656       ees=0.0D0
2657       evdw1=0.0D0
2658       eel_loc=0.0d0
2659       eello_turn3=0.0d0
2660       eello_turn4=0.0d0
2661 !el      ind=0
2662       do i=1,nres
2663         num_cont_hb(i)=0
2664       enddo
2665 !d      print '(a)','Enter EELEC'
2666 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2667 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2668 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2669       do i=1,nres
2670         gel_loc_loc(i)=0.0d0
2671         gcorr_loc(i)=0.0d0
2672       enddo
2673 !
2674 !
2675 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2676 !
2677 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2678 !
2679
2680
2681
2682       do i=iturn3_start,iturn3_end
2683         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2684         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2685         dxi=dc(1,i)
2686         dyi=dc(2,i)
2687         dzi=dc(3,i)
2688         dx_normi=dc_norm(1,i)
2689         dy_normi=dc_norm(2,i)
2690         dz_normi=dc_norm(3,i)
2691         xmedi=c(1,i)+0.5d0*dxi
2692         ymedi=c(2,i)+0.5d0*dyi
2693         zmedi=c(3,i)+0.5d0*dzi
2694           xmedi=dmod(xmedi,boxxsize)
2695           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2696           ymedi=dmod(ymedi,boxysize)
2697           if (ymedi.lt.0) ymedi=ymedi+boxysize
2698           zmedi=dmod(zmedi,boxzsize)
2699           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2700         num_conti=0
2701         call eelecij(i,i+2,ees,evdw1,eel_loc)
2702         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2703         num_cont_hb(i)=num_conti
2704       enddo
2705       do i=iturn4_start,iturn4_end
2706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2707           .or. itype(i+3).eq.ntyp1 &
2708           .or. itype(i+4).eq.ntyp1) cycle
2709         dxi=dc(1,i)
2710         dyi=dc(2,i)
2711         dzi=dc(3,i)
2712         dx_normi=dc_norm(1,i)
2713         dy_normi=dc_norm(2,i)
2714         dz_normi=dc_norm(3,i)
2715         xmedi=c(1,i)+0.5d0*dxi
2716         ymedi=c(2,i)+0.5d0*dyi
2717         zmedi=c(3,i)+0.5d0*dzi
2718           xmedi=dmod(xmedi,boxxsize)
2719           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2720           ymedi=dmod(ymedi,boxysize)
2721           if (ymedi.lt.0) ymedi=ymedi+boxysize
2722           zmedi=dmod(zmedi,boxzsize)
2723           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2724         num_conti=num_cont_hb(i)
2725         call eelecij(i,i+3,ees,evdw1,eel_loc)
2726         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2727          call eturn4(i,eello_turn4)
2728         num_cont_hb(i)=num_conti
2729       enddo   ! i
2730 !
2731 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2732 !
2733       do i=iatel_s,iatel_e
2734         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2735         dxi=dc(1,i)
2736         dyi=dc(2,i)
2737         dzi=dc(3,i)
2738         dx_normi=dc_norm(1,i)
2739         dy_normi=dc_norm(2,i)
2740         dz_normi=dc_norm(3,i)
2741         xmedi=c(1,i)+0.5d0*dxi
2742         ymedi=c(2,i)+0.5d0*dyi
2743         zmedi=c(3,i)+0.5d0*dzi
2744           xmedi=dmod(xmedi,boxxsize)
2745           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2746           ymedi=dmod(ymedi,boxysize)
2747           if (ymedi.lt.0) ymedi=ymedi+boxysize
2748           zmedi=dmod(zmedi,boxzsize)
2749           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2750
2751 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2752         num_conti=num_cont_hb(i)
2753         do j=ielstart(i),ielend(i)
2754 !          write (iout,*) i,j,itype(i),itype(j)
2755           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2756           call eelecij(i,j,ees,evdw1,eel_loc)
2757         enddo ! j
2758         num_cont_hb(i)=num_conti
2759       enddo   ! i
2760 !      write (iout,*) "Number of loop steps in EELEC:",ind
2761 !d      do i=1,nres
2762 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2763 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2764 !d      enddo
2765 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2766 !cc      eel_loc=eel_loc+eello_turn3
2767 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2768       return
2769       end subroutine eelec
2770 !-----------------------------------------------------------------------------
2771       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2772
2773       use comm_locel
2774 !      implicit real*8 (a-h,o-z)
2775 !      include 'DIMENSIONS'
2776 #ifdef MPI
2777       include "mpif.h"
2778 #endif
2779 !      include 'COMMON.CONTROL'
2780 !      include 'COMMON.IOUNITS'
2781 !      include 'COMMON.GEO'
2782 !      include 'COMMON.VAR'
2783 !      include 'COMMON.LOCAL'
2784 !      include 'COMMON.CHAIN'
2785 !      include 'COMMON.DERIV'
2786 !      include 'COMMON.INTERACT'
2787 !      include 'COMMON.CONTACTS'
2788 !      include 'COMMON.TORSION'
2789 !      include 'COMMON.VECTORS'
2790 !      include 'COMMON.FFIELD'
2791 !      include 'COMMON.TIME1'
2792       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2793       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2794       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2795 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2796       real(kind=8),dimension(4) :: muij
2797       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2798                     dist_temp, dist_init
2799       integer xshift,yshift,zshift
2800 !el      integer :: num_conti,j1,j2
2801 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2802 !el        dz_normi,xmedi,ymedi,zmedi
2803
2804 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2805 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2806 !el          num_conti,j1,j2
2807
2808 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2809 #ifdef MOMENT
2810       real(kind=8) :: scal_el=1.0d0
2811 #else
2812       real(kind=8) :: scal_el=0.5d0
2813 #endif
2814 ! 12/13/98
2815 ! 13-go grudnia roku pamietnego...
2816       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2817                                              0.0d0,1.0d0,0.0d0,&
2818                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2819 !      integer :: maxconts=nres/4
2820 !el local variables
2821       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
2822       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2823       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2824       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2825                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2826                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2827                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2828                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2829                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2830                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2831                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2832 !      maxconts=nres/4
2833 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2834 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2835
2836 !          time00=MPI_Wtime()
2837 !d      write (iout,*) "eelecij",i,j
2838 !          ind=ind+1
2839           iteli=itel(i)
2840           itelj=itel(j)
2841           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2842           aaa=app(iteli,itelj)
2843           bbb=bpp(iteli,itelj)
2844           ael6i=ael6(iteli,itelj)
2845           ael3i=ael3(iteli,itelj)
2846           dxj=dc(1,j)
2847           dyj=dc(2,j)
2848           dzj=dc(3,j)
2849           dx_normj=dc_norm(1,j)
2850           dy_normj=dc_norm(2,j)
2851           dz_normj=dc_norm(3,j)
2852 !          xj=c(1,j)+0.5D0*dxj-xmedi
2853 !          yj=c(2,j)+0.5D0*dyj-ymedi
2854 !          zj=c(3,j)+0.5D0*dzj-zmedi
2855           xj=c(1,j)+0.5D0*dxj
2856           yj=c(2,j)+0.5D0*dyj
2857           zj=c(3,j)+0.5D0*dzj
2858           xj=mod(xj,boxxsize)
2859           if (xj.lt.0) xj=xj+boxxsize
2860           yj=mod(yj,boxysize)
2861           if (yj.lt.0) yj=yj+boxysize
2862           zj=mod(zj,boxzsize)
2863           if (zj.lt.0) zj=zj+boxzsize
2864       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2865       xj_safe=xj
2866       yj_safe=yj
2867       zj_safe=zj
2868       do xshift=-1,1
2869       do yshift=-1,1
2870       do zshift=-1,1
2871           xj=xj_safe+xshift*boxxsize
2872           yj=yj_safe+yshift*boxysize
2873           zj=zj_safe+zshift*boxzsize
2874           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2875           if(dist_temp.lt.dist_init) then
2876             dist_init=dist_temp
2877             xj_temp=xj
2878             yj_temp=yj
2879             zj_temp=zj
2880             isubchap=1
2881           endif
2882        enddo
2883        enddo
2884        enddo
2885        if (isubchap.eq.1) then
2886 !C          print *,i,j
2887           xj=xj_temp-xmedi
2888           yj=yj_temp-ymedi
2889           zj=zj_temp-zmedi
2890        else
2891           xj=xj_safe-xmedi
2892           yj=yj_safe-ymedi
2893           zj=zj_safe-zmedi
2894        endif
2895
2896           rij=xj*xj+yj*yj+zj*zj
2897           rrmij=1.0D0/rij
2898           rij=dsqrt(rij)
2899             sss_ele_cut=sscale_ele(rij)
2900             sss_ele_grad=sscagrad_ele(rij)
2901 !            print *,sss_ele_cut,sss_ele_grad,&
2902 !            (rij),r_cut_ele,rlamb_ele
2903             if (sss_ele_cut.le.0.0) go to 128
2904
2905           rmij=1.0D0/rij
2906           r3ij=rrmij*rmij
2907           r6ij=r3ij*r3ij
2908           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2909           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2910           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2911           fac=cosa-3.0D0*cosb*cosg
2912           ev1=aaa*r6ij*r6ij
2913 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2914           if (j.eq.i+2) ev1=scal_el*ev1
2915           ev2=bbb*r6ij
2916           fac3=ael6i*r6ij
2917           fac4=ael3i*r3ij
2918           evdwij=ev1+ev2
2919           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2920           el2=fac4*fac
2921           eesij=el1+el2
2922 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2923           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2924           ees=ees+eesij*sss_ele_cut
2925           evdw1=evdw1+evdwij*sss_ele_cut
2926 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2927 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2928 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2929 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2930
2931           if (energy_dec) then
2932 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2933 !                  'evdw1',i,j,evdwij,&
2934 !                  iteli,itelj,aaa,evdw1
2935               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2936               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2937           endif
2938 !
2939 ! Calculate contributions to the Cartesian gradient.
2940 !
2941 #ifdef SPLITELE
2942           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut
2943           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
2944           fac1=fac
2945           erij(1)=xj*rmij
2946           erij(2)=yj*rmij
2947           erij(3)=zj*rmij
2948 !
2949 ! Radial derivatives. First process both termini of the fragment (i,j)
2950 !
2951           ggg(1)=facel*xj
2952           ggg(2)=facel*yj
2953           ggg(3)=facel*zj
2954 !          do k=1,3
2955 !            ghalf=0.5D0*ggg(k)
2956 !            gelc(k,i)=gelc(k,i)+ghalf
2957 !            gelc(k,j)=gelc(k,j)+ghalf
2958 !          enddo
2959 ! 9/28/08 AL Gradient compotents will be summed only at the end
2960           do k=1,3
2961             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2962             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2963           enddo
2964 !
2965 ! Loop over residues i+1 thru j-1.
2966 !
2967 !grad          do k=i+1,j-1
2968 !grad            do l=1,3
2969 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2970 !grad            enddo
2971 !grad          enddo
2972           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj
2973           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj
2974           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj
2975 !          do k=1,3
2976 !            ghalf=0.5D0*ggg(k)
2977 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2978 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2979 !          enddo
2980 ! 9/28/08 AL Gradient compotents will be summed only at the end
2981           do k=1,3
2982             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2983             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2984           enddo
2985 !
2986 ! Loop over residues i+1 thru j-1.
2987 !
2988 !grad          do k=i+1,j-1
2989 !grad            do l=1,3
2990 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2991 !grad            enddo
2992 !grad          enddo
2993 #else
2994           facvdw=(ev1+evdwij)*sss_ele_cut
2995           facel=(el1+eesij)*sss_ele_cut
2996           fac1=fac
2997           fac=-3*rrmij*(facvdw+facvdw+facel)
2998           erij(1)=xj*rmij
2999           erij(2)=yj*rmij
3000           erij(3)=zj*rmij
3001 !
3002 ! Radial derivatives. First process both termini of the fragment (i,j)
3003 !
3004           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3005           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3006           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3007 !          do k=1,3
3008 !            ghalf=0.5D0*ggg(k)
3009 !            gelc(k,i)=gelc(k,i)+ghalf
3010 !            gelc(k,j)=gelc(k,j)+ghalf
3011 !          enddo
3012 ! 9/28/08 AL Gradient compotents will be summed only at the end
3013           do k=1,3
3014             gelc_long(k,j)=gelc(k,j)+ggg(k)
3015             gelc_long(k,i)=gelc(k,i)-ggg(k)
3016           enddo
3017 !
3018 ! Loop over residues i+1 thru j-1.
3019 !
3020 !grad          do k=i+1,j-1
3021 !grad            do l=1,3
3022 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3023 !grad            enddo
3024 !grad          enddo
3025 ! 9/28/08 AL Gradient compotents will be summed only at the end
3026           ggg(1)=facvdw*xj
3027           ggg(2)=facvdw*yj
3028           ggg(3)=facvdw*zj
3029           do k=1,3
3030             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3031             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3032           enddo
3033 #endif
3034 !
3035 ! Angular part
3036 !
3037           ecosa=2.0D0*fac3*fac1+fac4
3038           fac4=-3.0D0*fac4
3039           fac3=-6.0D0*fac3
3040           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3041           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3042           do k=1,3
3043             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3044             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3045           enddo
3046 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3047 !d   &          (dcosg(k),k=1,3)
3048           do k=1,3
3049             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3050           enddo
3051 !          do k=1,3
3052 !            ghalf=0.5D0*ggg(k)
3053 !            gelc(k,i)=gelc(k,i)+ghalf
3054 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3055 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3056 !            gelc(k,j)=gelc(k,j)+ghalf
3057 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3058 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3059 !          enddo
3060 !grad          do k=i+1,j-1
3061 !grad            do l=1,3
3062 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3063 !grad            enddo
3064 !grad          enddo
3065           do k=1,3
3066             gelc(k,i)=gelc(k,i) &
3067                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3068                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3069             gelc(k,j)=gelc(k,j) &
3070                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3071                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3072             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3073             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3074           enddo
3075  128      continue
3076           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3077               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3078               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3079 !
3080 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3081 !   energy of a peptide unit is assumed in the form of a second-order
3082 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3083 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3084 !   are computed for EVERY pair of non-contiguous peptide groups.
3085 !
3086           if (j.lt.nres-1) then
3087             j1=j+1
3088             j2=j-1
3089           else
3090             j1=j-1
3091             j2=j-2
3092           endif
3093           kkk=0
3094           do k=1,2
3095             do l=1,2
3096               kkk=kkk+1
3097               muij(kkk)=mu(k,i)*mu(l,j)
3098             enddo
3099           enddo
3100 !d         write (iout,*) 'EELEC: i',i,' j',j
3101 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3102 !d          write(iout,*) 'muij',muij
3103           ury=scalar(uy(1,i),erij)
3104           urz=scalar(uz(1,i),erij)
3105           vry=scalar(uy(1,j),erij)
3106           vrz=scalar(uz(1,j),erij)
3107           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3108           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3109           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3110           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3111           fac=dsqrt(-ael6i)*r3ij
3112           a22=a22*fac
3113           a23=a23*fac
3114           a32=a32*fac
3115           a33=a33*fac
3116 !d          write (iout,'(4i5,4f10.5)')
3117 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3118 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3119 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3120 !d     &      uy(:,j),uz(:,j)
3121 !d          write (iout,'(4f10.5)')
3122 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3123 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3124 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3125 !d           write (iout,'(9f10.5/)')
3126 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3127 ! Derivatives of the elements of A in virtual-bond vectors
3128           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3129           do k=1,3
3130             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3131             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3132             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3133             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3134             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3135             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3136             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3137             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3138             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3139             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3140             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3141             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3142           enddo
3143 ! Compute radial contributions to the gradient
3144           facr=-3.0d0*rrmij
3145           a22der=a22*facr
3146           a23der=a23*facr
3147           a32der=a32*facr
3148           a33der=a33*facr
3149           agg(1,1)=a22der*xj
3150           agg(2,1)=a22der*yj
3151           agg(3,1)=a22der*zj
3152           agg(1,2)=a23der*xj
3153           agg(2,2)=a23der*yj
3154           agg(3,2)=a23der*zj
3155           agg(1,3)=a32der*xj
3156           agg(2,3)=a32der*yj
3157           agg(3,3)=a32der*zj
3158           agg(1,4)=a33der*xj
3159           agg(2,4)=a33der*yj
3160           agg(3,4)=a33der*zj
3161 ! Add the contributions coming from er
3162           fac3=-3.0d0*fac
3163           do k=1,3
3164             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3165             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3166             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3167             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3168           enddo
3169           do k=1,3
3170 ! Derivatives in DC(i)
3171 !grad            ghalf1=0.5d0*agg(k,1)
3172 !grad            ghalf2=0.5d0*agg(k,2)
3173 !grad            ghalf3=0.5d0*agg(k,3)
3174 !grad            ghalf4=0.5d0*agg(k,4)
3175             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3176             -3.0d0*uryg(k,2)*vry)!+ghalf1
3177             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3178             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3179             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3180             -3.0d0*urzg(k,2)*vry)!+ghalf3
3181             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3182             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3183 ! Derivatives in DC(i+1)
3184             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3185             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3186             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3187             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3188             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3189             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3190             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3191             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3192 ! Derivatives in DC(j)
3193             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3194             -3.0d0*vryg(k,2)*ury)!+ghalf1
3195             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3196             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3197             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3198             -3.0d0*vryg(k,2)*urz)!+ghalf3
3199             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3200             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3201 ! Derivatives in DC(j+1) or DC(nres-1)
3202             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3203             -3.0d0*vryg(k,3)*ury)
3204             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3205             -3.0d0*vrzg(k,3)*ury)
3206             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3207             -3.0d0*vryg(k,3)*urz)
3208             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3209             -3.0d0*vrzg(k,3)*urz)
3210 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3211 !grad              do l=1,4
3212 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3213 !grad              enddo
3214 !grad            endif
3215           enddo
3216           acipa(1,1)=a22
3217           acipa(1,2)=a23
3218           acipa(2,1)=a32
3219           acipa(2,2)=a33
3220           a22=-a22
3221           a23=-a23
3222           do l=1,2
3223             do k=1,3
3224               agg(k,l)=-agg(k,l)
3225               aggi(k,l)=-aggi(k,l)
3226               aggi1(k,l)=-aggi1(k,l)
3227               aggj(k,l)=-aggj(k,l)
3228               aggj1(k,l)=-aggj1(k,l)
3229             enddo
3230           enddo
3231           if (j.lt.nres-1) then
3232             a22=-a22
3233             a32=-a32
3234             do l=1,3,2
3235               do k=1,3
3236                 agg(k,l)=-agg(k,l)
3237                 aggi(k,l)=-aggi(k,l)
3238                 aggi1(k,l)=-aggi1(k,l)
3239                 aggj(k,l)=-aggj(k,l)
3240                 aggj1(k,l)=-aggj1(k,l)
3241               enddo
3242             enddo
3243           else
3244             a22=-a22
3245             a23=-a23
3246             a32=-a32
3247             a33=-a33
3248             do l=1,4
3249               do k=1,3
3250                 agg(k,l)=-agg(k,l)
3251                 aggi(k,l)=-aggi(k,l)
3252                 aggi1(k,l)=-aggi1(k,l)
3253                 aggj(k,l)=-aggj(k,l)
3254                 aggj1(k,l)=-aggj1(k,l)
3255               enddo
3256             enddo
3257           endif
3258           ENDIF ! WCORR
3259           IF (wel_loc.gt.0.0d0) THEN
3260 ! Contribution to the local-electrostatic energy coming from the i-j pair
3261           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3262            +a33*muij(4)
3263 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3264
3265           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3266                   'eelloc',i,j,eel_loc_ij
3267 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3268 !          if (energy_dec) write (iout,*) "muij",muij
3269 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3270
3271           eel_loc=eel_loc+eel_loc_ij
3272 ! Partial derivatives in virtual-bond dihedral angles gamma
3273           if (i.gt.1) &
3274           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3275                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3276                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3277           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3278                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3279                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3280 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3281           do l=1,3
3282             ggg(l)=agg(l,1)*muij(1)+ &
3283                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3284             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3285             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3286 !grad            ghalf=0.5d0*ggg(l)
3287 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3288 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3289           enddo
3290 !grad          do k=i+1,j2
3291 !grad            do l=1,3
3292 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3293 !grad            enddo
3294 !grad          enddo
3295 ! Remaining derivatives of eello
3296           do l=1,3
3297             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3298                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3299             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3300                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3301             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3302                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3303             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3304                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3305           enddo
3306           ENDIF
3307 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3308 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3309           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3310              .and. num_conti.le.maxconts) then
3311 !            write (iout,*) i,j," entered corr"
3312 !
3313 ! Calculate the contact function. The ith column of the array JCONT will
3314 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3315 ! greater than I). The arrays FACONT and GACONT will contain the values of
3316 ! the contact function and its derivative.
3317 !           r0ij=1.02D0*rpp(iteli,itelj)
3318 !           r0ij=1.11D0*rpp(iteli,itelj)
3319             r0ij=2.20D0*rpp(iteli,itelj)
3320 !           r0ij=1.55D0*rpp(iteli,itelj)
3321             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3322 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3323             if (fcont.gt.0.0D0) then
3324               num_conti=num_conti+1
3325               if (num_conti.gt.maxconts) then
3326 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3327 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3328                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3329                                ' will skip next contacts for this conf.', num_conti
3330               else
3331                 jcont_hb(num_conti,i)=j
3332 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3333 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3334                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3335                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3336 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3337 !  terms.
3338                 d_cont(num_conti,i)=rij
3339 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3340 !     --- Electrostatic-interaction matrix ---
3341                 a_chuj(1,1,num_conti,i)=a22
3342                 a_chuj(1,2,num_conti,i)=a23
3343                 a_chuj(2,1,num_conti,i)=a32
3344                 a_chuj(2,2,num_conti,i)=a33
3345 !     --- Gradient of rij
3346                 do kkk=1,3
3347                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3348                 enddo
3349                 kkll=0
3350                 do k=1,2
3351                   do l=1,2
3352                     kkll=kkll+1
3353                     do m=1,3
3354                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3355                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3356                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3357                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3358                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3359                     enddo
3360                   enddo
3361                 enddo
3362                 ENDIF
3363                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3364 ! Calculate contact energies
3365                 cosa4=4.0D0*cosa
3366                 wij=cosa-3.0D0*cosb*cosg
3367                 cosbg1=cosb+cosg
3368                 cosbg2=cosb-cosg
3369 !               fac3=dsqrt(-ael6i)/r0ij**3
3370                 fac3=dsqrt(-ael6i)*r3ij
3371 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3372                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3373                 if (ees0tmp.gt.0) then
3374                   ees0pij=dsqrt(ees0tmp)
3375                 else
3376                   ees0pij=0
3377                 endif
3378 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3379                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3380                 if (ees0tmp.gt.0) then
3381                   ees0mij=dsqrt(ees0tmp)
3382                 else
3383                   ees0mij=0
3384                 endif
3385 !               ees0mij=0.0D0
3386                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3387                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3388 ! Diagnostics. Comment out or remove after debugging!
3389 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3390 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3391 !               ees0m(num_conti,i)=0.0D0
3392 ! End diagnostics.
3393 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3394 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3395 ! Angular derivatives of the contact function
3396                 ees0pij1=fac3/ees0pij
3397                 ees0mij1=fac3/ees0mij
3398                 fac3p=-3.0D0*fac3*rrmij
3399                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3400                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3401 !               ees0mij1=0.0D0
3402                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3403                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3404                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3405                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3406                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3407                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3408                 ecosap=ecosa1+ecosa2
3409                 ecosbp=ecosb1+ecosb2
3410                 ecosgp=ecosg1+ecosg2
3411                 ecosam=ecosa1-ecosa2
3412                 ecosbm=ecosb1-ecosb2
3413                 ecosgm=ecosg1-ecosg2
3414 ! Diagnostics
3415 !               ecosap=ecosa1
3416 !               ecosbp=ecosb1
3417 !               ecosgp=ecosg1
3418 !               ecosam=0.0D0
3419 !               ecosbm=0.0D0
3420 !               ecosgm=0.0D0
3421 ! End diagnostics
3422                 facont_hb(num_conti,i)=fcont
3423                 fprimcont=fprimcont/rij
3424 !d              facont_hb(num_conti,i)=1.0D0
3425 ! Following line is for diagnostics.
3426 !d              fprimcont=0.0D0
3427                 do k=1,3
3428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3430                 enddo
3431                 do k=1,3
3432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3434                 enddo
3435                 gggp(1)=gggp(1)+ees0pijp*xj
3436                 gggp(2)=gggp(2)+ees0pijp*yj
3437                 gggp(3)=gggp(3)+ees0pijp*zj
3438                 gggm(1)=gggm(1)+ees0mijp*xj
3439                 gggm(2)=gggm(2)+ees0mijp*yj
3440                 gggm(3)=gggm(3)+ees0mijp*zj
3441 ! Derivatives due to the contact function
3442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3445                 do k=1,3
3446 !
3447 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3448 !          following the change of gradient-summation algorithm.
3449 !
3450 !grad                  ghalfp=0.5D0*gggp(k)
3451 !grad                  ghalfm=0.5D0*gggm(k)
3452                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3453                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3454                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3455                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3456                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3457                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3458                   gacontp_hb3(k,num_conti,i)=gggp(k)
3459                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3460                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3461                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3462                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3463                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3464                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3465                   gacontm_hb3(k,num_conti,i)=gggm(k)
3466                 enddo
3467 ! Diagnostics. Comment out or remove after debugging!
3468 !diag           do k=1,3
3469 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3470 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3471 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3472 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3473 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3474 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3475 !diag           enddo
3476               ENDIF ! wcorr
3477               endif  ! num_conti.le.maxconts
3478             endif  ! fcont.gt.0
3479           endif    ! j.gt.i+1
3480           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3481             do k=1,4
3482               do l=1,3
3483                 ghalf=0.5d0*agg(l,k)
3484                 aggi(l,k)=aggi(l,k)+ghalf
3485                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3486                 aggj(l,k)=aggj(l,k)+ghalf
3487               enddo
3488             enddo
3489             if (j.eq.nres-1 .and. i.lt.j-2) then
3490               do k=1,4
3491                 do l=1,3
3492                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3493                 enddo
3494               enddo
3495             endif
3496           endif
3497 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3498       return
3499       end subroutine eelecij
3500 !-----------------------------------------------------------------------------
3501       subroutine eturn3(i,eello_turn3)
3502 ! Third- and fourth-order contributions from turns
3503
3504       use comm_locel
3505 !      implicit real*8 (a-h,o-z)
3506 !      include 'DIMENSIONS'
3507 !      include 'COMMON.IOUNITS'
3508 !      include 'COMMON.GEO'
3509 !      include 'COMMON.VAR'
3510 !      include 'COMMON.LOCAL'
3511 !      include 'COMMON.CHAIN'
3512 !      include 'COMMON.DERIV'
3513 !      include 'COMMON.INTERACT'
3514 !      include 'COMMON.CONTACTS'
3515 !      include 'COMMON.TORSION'
3516 !      include 'COMMON.VECTORS'
3517 !      include 'COMMON.FFIELD'
3518 !      include 'COMMON.CONTROL'
3519       real(kind=8),dimension(3) :: ggg
3520       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3521         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3522       real(kind=8),dimension(2) :: auxvec,auxvec1
3523 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3524       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3525 !el      integer :: num_conti,j1,j2
3526 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3527 !el        dz_normi,xmedi,ymedi,zmedi
3528
3529 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3530 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3531 !el         num_conti,j1,j2
3532 !el local variables
3533       integer :: i,j,l
3534       real(kind=8) :: eello_turn3
3535
3536       j=i+2
3537 !      write (iout,*) "eturn3",i,j,j1,j2
3538       a_temp(1,1)=a22
3539       a_temp(1,2)=a23
3540       a_temp(2,1)=a32
3541       a_temp(2,2)=a33
3542 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3543 !
3544 !               Third-order contributions
3545 !
3546 !                 (i+2)o----(i+3)
3547 !                      | |
3548 !                      | |
3549 !                 (i+1)o----i
3550 !
3551 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3552 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3553         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3554         call transpose2(auxmat(1,1),auxmat1(1,1))
3555         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3556         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3557         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3558                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3559 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3560 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3561 !d     &    ' eello_turn3_num',4*eello_turn3_num
3562 ! Derivatives in gamma(i)
3563         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3564         call transpose2(auxmat2(1,1),auxmat3(1,1))
3565         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3566         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3567 ! Derivatives in gamma(i+1)
3568         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3569         call transpose2(auxmat2(1,1),auxmat3(1,1))
3570         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3571         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3572           +0.5d0*(pizda(1,1)+pizda(2,2))
3573 ! Cartesian derivatives
3574         do l=1,3
3575 !            ghalf1=0.5d0*agg(l,1)
3576 !            ghalf2=0.5d0*agg(l,2)
3577 !            ghalf3=0.5d0*agg(l,3)
3578 !            ghalf4=0.5d0*agg(l,4)
3579           a_temp(1,1)=aggi(l,1)!+ghalf1
3580           a_temp(1,2)=aggi(l,2)!+ghalf2
3581           a_temp(2,1)=aggi(l,3)!+ghalf3
3582           a_temp(2,2)=aggi(l,4)!+ghalf4
3583           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3584           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3585             +0.5d0*(pizda(1,1)+pizda(2,2))
3586           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3587           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3588           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3589           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3590           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3591           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3592             +0.5d0*(pizda(1,1)+pizda(2,2))
3593           a_temp(1,1)=aggj(l,1)!+ghalf1
3594           a_temp(1,2)=aggj(l,2)!+ghalf2
3595           a_temp(2,1)=aggj(l,3)!+ghalf3
3596           a_temp(2,2)=aggj(l,4)!+ghalf4
3597           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3598           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3599             +0.5d0*(pizda(1,1)+pizda(2,2))
3600           a_temp(1,1)=aggj1(l,1)
3601           a_temp(1,2)=aggj1(l,2)
3602           a_temp(2,1)=aggj1(l,3)
3603           a_temp(2,2)=aggj1(l,4)
3604           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3605           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3606             +0.5d0*(pizda(1,1)+pizda(2,2))
3607         enddo
3608       return
3609       end subroutine eturn3
3610 !-----------------------------------------------------------------------------
3611       subroutine eturn4(i,eello_turn4)
3612 ! Third- and fourth-order contributions from turns
3613
3614       use comm_locel
3615 !      implicit real*8 (a-h,o-z)
3616 !      include 'DIMENSIONS'
3617 !      include 'COMMON.IOUNITS'
3618 !      include 'COMMON.GEO'
3619 !      include 'COMMON.VAR'
3620 !      include 'COMMON.LOCAL'
3621 !      include 'COMMON.CHAIN'
3622 !      include 'COMMON.DERIV'
3623 !      include 'COMMON.INTERACT'
3624 !      include 'COMMON.CONTACTS'
3625 !      include 'COMMON.TORSION'
3626 !      include 'COMMON.VECTORS'
3627 !      include 'COMMON.FFIELD'
3628 !      include 'COMMON.CONTROL'
3629       real(kind=8),dimension(3) :: ggg
3630       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3631         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3632       real(kind=8),dimension(2) :: auxvec,auxvec1
3633 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3634       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3635 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3636 !el        dz_normi,xmedi,ymedi,zmedi
3637 !el      integer :: num_conti,j1,j2
3638 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3639 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3640 !el          num_conti,j1,j2
3641 !el local variables
3642       integer :: i,j,iti1,iti2,iti3,l
3643       real(kind=8) :: eello_turn4,s1,s2,s3
3644
3645       j=i+3
3646 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3647 !
3648 !               Fourth-order contributions
3649 !
3650 !                 (i+3)o----(i+4)
3651 !                     /  |
3652 !               (i+2)o   |
3653 !                     \  |
3654 !                 (i+1)o----i
3655 !
3656 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3657 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3658 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3659         a_temp(1,1)=a22
3660         a_temp(1,2)=a23
3661         a_temp(2,1)=a32
3662         a_temp(2,2)=a33
3663         iti1=itortyp(itype(i+1))
3664         iti2=itortyp(itype(i+2))
3665         iti3=itortyp(itype(i+3))
3666 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3667         call transpose2(EUg(1,1,i+1),e1t(1,1))
3668         call transpose2(Eug(1,1,i+2),e2t(1,1))
3669         call transpose2(Eug(1,1,i+3),e3t(1,1))
3670         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3671         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3672         s1=scalar2(b1(1,iti2),auxvec(1))
3673         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3674         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3675         s2=scalar2(b1(1,iti1),auxvec(1))
3676         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3677         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3678         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3679         eello_turn4=eello_turn4-(s1+s2+s3)
3680         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3681            'eturn4',i,j,-(s1+s2+s3)
3682 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3683 !d     &    ' eello_turn4_num',8*eello_turn4_num
3684 ! Derivatives in gamma(i)
3685         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3686         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3687         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3688         s1=scalar2(b1(1,iti2),auxvec(1))
3689         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3690         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3691         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3692 ! Derivatives in gamma(i+1)
3693         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3694         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3695         s2=scalar2(b1(1,iti1),auxvec(1))
3696         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3697         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3698         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3699         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3700 ! Derivatives in gamma(i+2)
3701         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3702         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3703         s1=scalar2(b1(1,iti2),auxvec(1))
3704         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3705         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3706         s2=scalar2(b1(1,iti1),auxvec(1))
3707         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3708         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3709         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3710         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3711 ! Cartesian derivatives
3712 ! Derivatives of this turn contributions in DC(i+2)
3713         if (j.lt.nres-1) then
3714           do l=1,3
3715             a_temp(1,1)=agg(l,1)
3716             a_temp(1,2)=agg(l,2)
3717             a_temp(2,1)=agg(l,3)
3718             a_temp(2,2)=agg(l,4)
3719             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3720             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3721             s1=scalar2(b1(1,iti2),auxvec(1))
3722             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3723             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3724             s2=scalar2(b1(1,iti1),auxvec(1))
3725             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3726             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3727             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728             ggg(l)=-(s1+s2+s3)
3729             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3730           enddo
3731         endif
3732 ! Remaining derivatives of this turn contribution
3733         do l=1,3
3734           a_temp(1,1)=aggi(l,1)
3735           a_temp(1,2)=aggi(l,2)
3736           a_temp(2,1)=aggi(l,3)
3737           a_temp(2,2)=aggi(l,4)
3738           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3739           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3740           s1=scalar2(b1(1,iti2),auxvec(1))
3741           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3742           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3743           s2=scalar2(b1(1,iti1),auxvec(1))
3744           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3745           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3746           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3747           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3748           a_temp(1,1)=aggi1(l,1)
3749           a_temp(1,2)=aggi1(l,2)
3750           a_temp(2,1)=aggi1(l,3)
3751           a_temp(2,2)=aggi1(l,4)
3752           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754           s1=scalar2(b1(1,iti2),auxvec(1))
3755           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757           s2=scalar2(b1(1,iti1),auxvec(1))
3758           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3762           a_temp(1,1)=aggj(l,1)
3763           a_temp(1,2)=aggj(l,2)
3764           a_temp(2,1)=aggj(l,3)
3765           a_temp(2,2)=aggj(l,4)
3766           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3767           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3768           s1=scalar2(b1(1,iti2),auxvec(1))
3769           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3770           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3771           s2=scalar2(b1(1,iti1),auxvec(1))
3772           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3773           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3774           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3775           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3776           a_temp(1,1)=aggj1(l,1)
3777           a_temp(1,2)=aggj1(l,2)
3778           a_temp(2,1)=aggj1(l,3)
3779           a_temp(2,2)=aggj1(l,4)
3780           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3781           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3782           s1=scalar2(b1(1,iti2),auxvec(1))
3783           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3784           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3785           s2=scalar2(b1(1,iti1),auxvec(1))
3786           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3787           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3788           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3789 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3790           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3791         enddo
3792       return
3793       end subroutine eturn4
3794 !-----------------------------------------------------------------------------
3795       subroutine unormderiv(u,ugrad,unorm,ungrad)
3796 ! This subroutine computes the derivatives of a normalized vector u, given
3797 ! the derivatives computed without normalization conditions, ugrad. Returns
3798 ! ungrad.
3799 !      implicit none
3800       real(kind=8),dimension(3) :: u,vec
3801       real(kind=8),dimension(3,3) ::ugrad,ungrad
3802       real(kind=8) :: unorm     !,scalar
3803       integer :: i,j
3804 !      write (2,*) 'ugrad',ugrad
3805 !      write (2,*) 'u',u
3806       do i=1,3
3807         vec(i)=scalar(ugrad(1,i),u(1))
3808       enddo
3809 !      write (2,*) 'vec',vec
3810       do i=1,3
3811         do j=1,3
3812           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3813         enddo
3814       enddo
3815 !      write (2,*) 'ungrad',ungrad
3816       return
3817       end subroutine unormderiv
3818 !-----------------------------------------------------------------------------
3819       subroutine escp_soft_sphere(evdw2,evdw2_14)
3820 !
3821 ! This subroutine calculates the excluded-volume interaction energy between
3822 ! peptide-group centers and side chains and its gradient in virtual-bond and
3823 ! side-chain vectors.
3824 !
3825 !      implicit real*8 (a-h,o-z)
3826 !      include 'DIMENSIONS'
3827 !      include 'COMMON.GEO'
3828 !      include 'COMMON.VAR'
3829 !      include 'COMMON.LOCAL'
3830 !      include 'COMMON.CHAIN'
3831 !      include 'COMMON.DERIV'
3832 !      include 'COMMON.INTERACT'
3833 !      include 'COMMON.FFIELD'
3834 !      include 'COMMON.IOUNITS'
3835 !      include 'COMMON.CONTROL'
3836       real(kind=8),dimension(3) :: ggg
3837 !el local variables
3838       integer :: i,iint,j,k,iteli,itypj
3839       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3840                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3841
3842       evdw2=0.0D0
3843       evdw2_14=0.0d0
3844       r0_scp=4.5d0
3845 !d    print '(a)','Enter ESCP'
3846 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3847       do i=iatscp_s,iatscp_e
3848         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3849         iteli=itel(i)
3850         xi=0.5D0*(c(1,i)+c(1,i+1))
3851         yi=0.5D0*(c(2,i)+c(2,i+1))
3852         zi=0.5D0*(c(3,i)+c(3,i+1))
3853
3854         do iint=1,nscp_gr(i)
3855
3856         do j=iscpstart(i,iint),iscpend(i,iint)
3857           if (itype(j).eq.ntyp1) cycle
3858           itypj=iabs(itype(j))
3859 ! Uncomment following three lines for SC-p interactions
3860 !         xj=c(1,nres+j)-xi
3861 !         yj=c(2,nres+j)-yi
3862 !         zj=c(3,nres+j)-zi
3863 ! Uncomment following three lines for Ca-p interactions
3864           xj=c(1,j)-xi
3865           yj=c(2,j)-yi
3866           zj=c(3,j)-zi
3867           rij=xj*xj+yj*yj+zj*zj
3868           r0ij=r0_scp
3869           r0ijsq=r0ij*r0ij
3870           if (rij.lt.r0ijsq) then
3871             evdwij=0.25d0*(rij-r0ijsq)**2
3872             fac=rij-r0ijsq
3873           else
3874             evdwij=0.0d0
3875             fac=0.0d0
3876           endif
3877           evdw2=evdw2+evdwij
3878 !
3879 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3880 !
3881           ggg(1)=xj*fac
3882           ggg(2)=yj*fac
3883           ggg(3)=zj*fac
3884 !grad          if (j.lt.i) then
3885 !d          write (iout,*) 'j<i'
3886 ! Uncomment following three lines for SC-p interactions
3887 !           do k=1,3
3888 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3889 !           enddo
3890 !grad          else
3891 !d          write (iout,*) 'j>i'
3892 !grad            do k=1,3
3893 !grad              ggg(k)=-ggg(k)
3894 ! Uncomment following line for SC-p interactions
3895 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3896 !grad            enddo
3897 !grad          endif
3898 !grad          do k=1,3
3899 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3900 !grad          enddo
3901 !grad          kstart=min0(i+1,j)
3902 !grad          kend=max0(i-1,j-1)
3903 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3904 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3905 !grad          do k=kstart,kend
3906 !grad            do l=1,3
3907 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3908 !grad            enddo
3909 !grad          enddo
3910           do k=1,3
3911             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3912             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3913           enddo
3914         enddo
3915
3916         enddo ! iint
3917       enddo ! i
3918       return
3919       end subroutine escp_soft_sphere
3920 !-----------------------------------------------------------------------------
3921       subroutine escp(evdw2,evdw2_14)
3922 !
3923 ! This subroutine calculates the excluded-volume interaction energy between
3924 ! peptide-group centers and side chains and its gradient in virtual-bond and
3925 ! side-chain vectors.
3926 !
3927 !      implicit real*8 (a-h,o-z)
3928 !      include 'DIMENSIONS'
3929 !      include 'COMMON.GEO'
3930 !      include 'COMMON.VAR'
3931 !      include 'COMMON.LOCAL'
3932 !      include 'COMMON.CHAIN'
3933 !      include 'COMMON.DERIV'
3934 !      include 'COMMON.INTERACT'
3935 !      include 'COMMON.FFIELD'
3936 !      include 'COMMON.IOUNITS'
3937 !      include 'COMMON.CONTROL'
3938       real(kind=8),dimension(3) :: ggg
3939 !el local variables
3940       integer :: i,iint,j,k,iteli,itypj
3941       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3942                    e1,e2,evdwij
3943
3944       evdw2=0.0D0
3945       evdw2_14=0.0d0
3946 !d    print '(a)','Enter ESCP'
3947 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3948       do i=iatscp_s,iatscp_e
3949         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3950         iteli=itel(i)
3951         xi=0.5D0*(c(1,i)+c(1,i+1))
3952         yi=0.5D0*(c(2,i)+c(2,i+1))
3953         zi=0.5D0*(c(3,i)+c(3,i+1))
3954
3955         do iint=1,nscp_gr(i)
3956
3957         do j=iscpstart(i,iint),iscpend(i,iint)
3958           itypj=iabs(itype(j))
3959           if (itypj.eq.ntyp1) cycle
3960 ! Uncomment following three lines for SC-p interactions
3961 !         xj=c(1,nres+j)-xi
3962 !         yj=c(2,nres+j)-yi
3963 !         zj=c(3,nres+j)-zi
3964 ! Uncomment following three lines for Ca-p interactions
3965           xj=c(1,j)-xi
3966           yj=c(2,j)-yi
3967           zj=c(3,j)-zi
3968           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3969           fac=rrij**expon2
3970           e1=fac*fac*aad(itypj,iteli)
3971           e2=fac*bad(itypj,iteli)
3972           if (iabs(j-i) .le. 2) then
3973             e1=scal14*e1
3974             e2=scal14*e2
3975             evdw2_14=evdw2_14+e1+e2
3976           endif
3977           evdwij=e1+e2
3978           evdw2=evdw2+evdwij
3979 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3980 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3981           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3982              'evdw2',i,j,evdwij
3983 !
3984 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3985 !
3986           fac=-(evdwij+e1)*rrij
3987           ggg(1)=xj*fac
3988           ggg(2)=yj*fac
3989           ggg(3)=zj*fac
3990 !grad          if (j.lt.i) then
3991 !d          write (iout,*) 'j<i'
3992 ! Uncomment following three lines for SC-p interactions
3993 !           do k=1,3
3994 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3995 !           enddo
3996 !grad          else
3997 !d          write (iout,*) 'j>i'
3998 !grad            do k=1,3
3999 !grad              ggg(k)=-ggg(k)
4000 ! Uncomment following line for SC-p interactions
4001 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4002 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4003 !grad            enddo
4004 !grad          endif
4005 !grad          do k=1,3
4006 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4007 !grad          enddo
4008 !grad          kstart=min0(i+1,j)
4009 !grad          kend=max0(i-1,j-1)
4010 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4011 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4012 !grad          do k=kstart,kend
4013 !grad            do l=1,3
4014 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4015 !grad            enddo
4016 !grad          enddo
4017           do k=1,3
4018             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4019             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4020           enddo
4021         enddo
4022
4023         enddo ! iint
4024       enddo ! i
4025       do i=1,nct
4026         do j=1,3
4027           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4028           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4029           gradx_scp(j,i)=expon*gradx_scp(j,i)
4030         enddo
4031       enddo
4032 !******************************************************************************
4033 !
4034 !                              N O T E !!!
4035 !
4036 ! To save time the factor EXPON has been extracted from ALL components
4037 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4038 ! use!
4039 !
4040 !******************************************************************************
4041       return
4042       end subroutine escp
4043 !-----------------------------------------------------------------------------
4044       subroutine edis(ehpb)
4045 !
4046 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4047 !
4048 !      implicit real*8 (a-h,o-z)
4049 !      include 'DIMENSIONS'
4050 !      include 'COMMON.SBRIDGE'
4051 !      include 'COMMON.CHAIN'
4052 !      include 'COMMON.DERIV'
4053 !      include 'COMMON.VAR'
4054 !      include 'COMMON.INTERACT'
4055 !      include 'COMMON.IOUNITS'
4056       real(kind=8),dimension(3) :: ggg
4057 !el local variables
4058       integer :: i,j,ii,jj,iii,jjj,k
4059       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4060
4061       ehpb=0.0D0
4062 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4063 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4064       if (link_end.eq.0) return
4065       do i=link_start,link_end
4066 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4067 ! CA-CA distance used in regularization of structure.
4068         ii=ihpb(i)
4069         jj=jhpb(i)
4070 ! iii and jjj point to the residues for which the distance is assigned.
4071         if (ii.gt.nres) then
4072           iii=ii-nres
4073           jjj=jj-nres
4074         else
4075           iii=ii
4076           jjj=jj
4077         endif
4078 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4079 !     &    dhpb(i),dhpb1(i),forcon(i)
4080 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4081 !    distance and angle dependent SS bond potential.
4082 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4083 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4084         if (.not.dyn_ss .and. i.le.nss) then
4085 ! 15/02/13 CC dynamic SSbond - additional check
4086          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4087         iabs(itype(jjj)).eq.1) then
4088           call ssbond_ene(iii,jjj,eij)
4089           ehpb=ehpb+2*eij
4090 !d          write (iout,*) "eij",eij
4091          endif
4092         else
4093 ! Calculate the distance between the two points and its difference from the
4094 ! target distance.
4095         dd=dist(ii,jj)
4096         rdis=dd-dhpb(i)
4097 ! Get the force constant corresponding to this distance.
4098         waga=forcon(i)
4099 ! Calculate the contribution to energy.
4100         ehpb=ehpb+waga*rdis*rdis
4101 !
4102 ! Evaluate gradient.
4103 !
4104         fac=waga*rdis/dd
4105 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4106 !d   &   ' waga=',waga,' fac=',fac
4107         do j=1,3
4108           ggg(j)=fac*(c(j,jj)-c(j,ii))
4109         enddo
4110 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4111 ! If this is a SC-SC distance, we need to calculate the contributions to the
4112 ! Cartesian gradient in the SC vectors (ghpbx).
4113         if (iii.lt.ii) then
4114           do j=1,3
4115             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4116             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4117           enddo
4118         endif
4119 !grad        do j=iii,jjj-1
4120 !grad          do k=1,3
4121 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4122 !grad          enddo
4123 !grad        enddo
4124         do k=1,3
4125           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4126           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4127         enddo
4128         endif
4129       enddo
4130       ehpb=0.5D0*ehpb
4131       return
4132       end subroutine edis
4133 !-----------------------------------------------------------------------------
4134       subroutine ssbond_ene(i,j,eij)
4135 !
4136 ! Calculate the distance and angle dependent SS-bond potential energy
4137 ! using a free-energy function derived based on RHF/6-31G** ab initio
4138 ! calculations of diethyl disulfide.
4139 !
4140 ! A. Liwo and U. Kozlowska, 11/24/03
4141 !
4142 !      implicit real*8 (a-h,o-z)
4143 !      include 'DIMENSIONS'
4144 !      include 'COMMON.SBRIDGE'
4145 !      include 'COMMON.CHAIN'
4146 !      include 'COMMON.DERIV'
4147 !      include 'COMMON.LOCAL'
4148 !      include 'COMMON.INTERACT'
4149 !      include 'COMMON.VAR'
4150 !      include 'COMMON.IOUNITS'
4151       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4152 !el local variables
4153       integer :: i,j,itypi,itypj,k
4154       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4155                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4156                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4157                    cosphi,ggk
4158
4159       itypi=iabs(itype(i))
4160       xi=c(1,nres+i)
4161       yi=c(2,nres+i)
4162       zi=c(3,nres+i)
4163       dxi=dc_norm(1,nres+i)
4164       dyi=dc_norm(2,nres+i)
4165       dzi=dc_norm(3,nres+i)
4166 !      dsci_inv=dsc_inv(itypi)
4167       dsci_inv=vbld_inv(nres+i)
4168       itypj=iabs(itype(j))
4169 !      dscj_inv=dsc_inv(itypj)
4170       dscj_inv=vbld_inv(nres+j)
4171       xj=c(1,nres+j)-xi
4172       yj=c(2,nres+j)-yi
4173       zj=c(3,nres+j)-zi
4174       dxj=dc_norm(1,nres+j)
4175       dyj=dc_norm(2,nres+j)
4176       dzj=dc_norm(3,nres+j)
4177       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4178       rij=dsqrt(rrij)
4179       erij(1)=xj*rij
4180       erij(2)=yj*rij
4181       erij(3)=zj*rij
4182       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4183       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4184       om12=dxi*dxj+dyi*dyj+dzi*dzj
4185       do k=1,3
4186         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4187         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4188       enddo
4189       rij=1.0d0/rij
4190       deltad=rij-d0cm
4191       deltat1=1.0d0-om1
4192       deltat2=1.0d0+om2
4193       deltat12=om2-om1+2.0d0
4194       cosphi=om12-om1*om2
4195       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4196         +akct*deltad*deltat12 &
4197         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4198 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4199 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4200 !     &  " deltat12",deltat12," eij",eij
4201       ed=2*akcm*deltad+akct*deltat12
4202       pom1=akct*deltad
4203       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4204       eom1=-2*akth*deltat1-pom1-om2*pom2
4205       eom2= 2*akth*deltat2+pom1-om1*pom2
4206       eom12=pom2
4207       do k=1,3
4208         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4209         ghpbx(k,i)=ghpbx(k,i)-ggk &
4210                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4211                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4212         ghpbx(k,j)=ghpbx(k,j)+ggk &
4213                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4214                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4215         ghpbc(k,i)=ghpbc(k,i)-ggk
4216         ghpbc(k,j)=ghpbc(k,j)+ggk
4217       enddo
4218 !
4219 ! Calculate the components of the gradient in DC and X
4220 !
4221 !grad      do k=i,j-1
4222 !grad        do l=1,3
4223 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4224 !grad        enddo
4225 !grad      enddo
4226       return
4227       end subroutine ssbond_ene
4228 !-----------------------------------------------------------------------------
4229       subroutine ebond(estr)
4230 !
4231 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4232 !
4233 !      implicit real*8 (a-h,o-z)
4234 !      include 'DIMENSIONS'
4235 !      include 'COMMON.LOCAL'
4236 !      include 'COMMON.GEO'
4237 !      include 'COMMON.INTERACT'
4238 !      include 'COMMON.DERIV'
4239 !      include 'COMMON.VAR'
4240 !      include 'COMMON.CHAIN'
4241 !      include 'COMMON.IOUNITS'
4242 !      include 'COMMON.NAMES'
4243 !      include 'COMMON.FFIELD'
4244 !      include 'COMMON.CONTROL'
4245 !      include 'COMMON.SETUP'
4246       real(kind=8),dimension(3) :: u,ud
4247 !el local variables
4248       integer :: i,j,iti,nbi,k
4249       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4250                    uprod1,uprod2
4251
4252       estr=0.0d0
4253       estr1=0.0d0
4254 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4255 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4256
4257       do i=ibondp_start,ibondp_end
4258         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4259         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4260 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4261 !C          do j=1,3
4262 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4263 !C            *dc(j,i-1)/vbld(i)
4264 !C          enddo
4265 !C          if (energy_dec) write(iout,*) &
4266 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4267         diff = vbld(i)-vbldpDUM
4268         else
4269         diff = vbld(i)-vbldp0
4270         endif
4271         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4272            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4273         estr=estr+diff*diff
4274         do j=1,3
4275           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4276         enddo
4277 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4278 !        endif
4279       enddo
4280       estr=0.5d0*AKP*estr+estr1
4281 !
4282 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4283 !
4284       do i=ibond_start,ibond_end
4285         iti=iabs(itype(i))
4286         if (iti.ne.10 .and. iti.ne.ntyp1) then
4287           nbi=nbondterm(iti)
4288           if (nbi.eq.1) then
4289             diff=vbld(i+nres)-vbldsc0(1,iti)
4290             if (energy_dec) write (iout,*) &
4291             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4292             AKSC(1,iti),AKSC(1,iti)*diff*diff
4293             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4294             do j=1,3
4295               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4296             enddo
4297           else
4298             do j=1,nbi
4299               diff=vbld(i+nres)-vbldsc0(j,iti)
4300               ud(j)=aksc(j,iti)*diff
4301               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4302             enddo
4303             uprod=u(1)
4304             do j=2,nbi
4305               uprod=uprod*u(j)
4306             enddo
4307             usum=0.0d0
4308             usumsqder=0.0d0
4309             do j=1,nbi
4310               uprod1=1.0d0
4311               uprod2=1.0d0
4312               do k=1,nbi
4313                 if (k.ne.j) then
4314                   uprod1=uprod1*u(k)
4315                   uprod2=uprod2*u(k)*u(k)
4316                 endif
4317               enddo
4318               usum=usum+uprod1
4319               usumsqder=usumsqder+ud(j)*uprod2
4320             enddo
4321             estr=estr+uprod/usum
4322             do j=1,3
4323              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4324             enddo
4325           endif
4326         endif
4327       enddo
4328       return
4329       end subroutine ebond
4330 #ifdef CRYST_THETA
4331 !-----------------------------------------------------------------------------
4332       subroutine ebend(etheta)
4333 !
4334 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4335 ! angles gamma and its derivatives in consecutive thetas and gammas.
4336 !
4337       use comm_calcthet
4338 !      implicit real*8 (a-h,o-z)
4339 !      include 'DIMENSIONS'
4340 !      include 'COMMON.LOCAL'
4341 !      include 'COMMON.GEO'
4342 !      include 'COMMON.INTERACT'
4343 !      include 'COMMON.DERIV'
4344 !      include 'COMMON.VAR'
4345 !      include 'COMMON.CHAIN'
4346 !      include 'COMMON.IOUNITS'
4347 !      include 'COMMON.NAMES'
4348 !      include 'COMMON.FFIELD'
4349 !      include 'COMMON.CONTROL'
4350 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4351 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4352 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4353 !el      integer :: it
4354 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4355 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4356 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4357 !el local variables
4358       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4359        ichir21,ichir22
4360       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4361        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4362        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4363       real(kind=8),dimension(2) :: y,z
4364
4365       delta=0.02d0*pi
4366 !      time11=dexp(-2*time)
4367 !      time12=1.0d0
4368       etheta=0.0D0
4369 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4370       do i=ithet_start,ithet_end
4371         if (itype(i-1).eq.ntyp1) cycle
4372 ! Zero the energy function and its derivative at 0 or pi.
4373         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4374         it=itype(i-1)
4375         ichir1=isign(1,itype(i-2))
4376         ichir2=isign(1,itype(i))
4377          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4378          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4379          if (itype(i-1).eq.10) then
4380           itype1=isign(10,itype(i-2))
4381           ichir11=isign(1,itype(i-2))
4382           ichir12=isign(1,itype(i-2))
4383           itype2=isign(10,itype(i))
4384           ichir21=isign(1,itype(i))
4385           ichir22=isign(1,itype(i))
4386          endif
4387
4388         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4389 #ifdef OSF
4390           phii=phi(i)
4391           if (phii.ne.phii) phii=150.0
4392 #else
4393           phii=phi(i)
4394 #endif
4395           y(1)=dcos(phii)
4396           y(2)=dsin(phii)
4397         else
4398           y(1)=0.0D0
4399           y(2)=0.0D0
4400         endif
4401         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4402 #ifdef OSF
4403           phii1=phi(i+1)
4404           if (phii1.ne.phii1) phii1=150.0
4405           phii1=pinorm(phii1)
4406           z(1)=cos(phii1)
4407 #else
4408           phii1=phi(i+1)
4409           z(1)=dcos(phii1)
4410 #endif
4411           z(2)=dsin(phii1)
4412         else
4413           z(1)=0.0D0
4414           z(2)=0.0D0
4415         endif
4416 ! Calculate the "mean" value of theta from the part of the distribution
4417 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4418 ! In following comments this theta will be referred to as t_c.
4419         thet_pred_mean=0.0d0
4420         do k=1,2
4421             athetk=athet(k,it,ichir1,ichir2)
4422             bthetk=bthet(k,it,ichir1,ichir2)
4423           if (it.eq.10) then
4424              athetk=athet(k,itype1,ichir11,ichir12)
4425              bthetk=bthet(k,itype2,ichir21,ichir22)
4426           endif
4427          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4428         enddo
4429         dthett=thet_pred_mean*ssd
4430         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4431 ! Derivatives of the "mean" values in gamma1 and gamma2.
4432         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4433                +athet(2,it,ichir1,ichir2)*y(1))*ss
4434         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4435                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4436          if (it.eq.10) then
4437         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4438              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4439         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4440                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4441          endif
4442         if (theta(i).gt.pi-delta) then
4443           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4444                E_tc0)
4445           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4446           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4447           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4448               E_theta)
4449           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4450               E_tc)
4451         else if (theta(i).lt.delta) then
4452           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4453           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4454           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4455               E_theta)
4456           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4457           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4458               E_tc)
4459         else
4460           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4461               E_theta,E_tc)
4462         endif
4463         etheta=etheta+ethetai
4464         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4465             'ebend',i,ethetai
4466         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4467         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4468         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4469       enddo
4470 ! Ufff.... We've done all this!!!
4471       return
4472       end subroutine ebend
4473 !-----------------------------------------------------------------------------
4474       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4475
4476       use comm_calcthet
4477 !      implicit real*8 (a-h,o-z)
4478 !      include 'DIMENSIONS'
4479 !      include 'COMMON.LOCAL'
4480 !      include 'COMMON.IOUNITS'
4481 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4482 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4483 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4484       integer :: i,j,k
4485       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4486 !el      integer :: it
4487 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4488 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4489 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4490 !el local variables
4491       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4492        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4493
4494 ! Calculate the contributions to both Gaussian lobes.
4495 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4496 ! The "polynomial part" of the "standard deviation" of this part of
4497 ! the distribution.
4498         sig=polthet(3,it)
4499         do j=2,0,-1
4500           sig=sig*thet_pred_mean+polthet(j,it)
4501         enddo
4502 ! Derivative of the "interior part" of the "standard deviation of the"
4503 ! gamma-dependent Gaussian lobe in t_c.
4504         sigtc=3*polthet(3,it)
4505         do j=2,1,-1
4506           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4507         enddo
4508         sigtc=sig*sigtc
4509 ! Set the parameters of both Gaussian lobes of the distribution.
4510 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4511         fac=sig*sig+sigc0(it)
4512         sigcsq=fac+fac
4513         sigc=1.0D0/sigcsq
4514 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4515         sigsqtc=-4.0D0*sigcsq*sigtc
4516 !       print *,i,sig,sigtc,sigsqtc
4517 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4518         sigtc=-sigtc/(fac*fac)
4519 ! Following variable is sigma(t_c)**(-2)
4520         sigcsq=sigcsq*sigcsq
4521         sig0i=sig0(it)
4522         sig0inv=1.0D0/sig0i**2
4523         delthec=thetai-thet_pred_mean
4524         delthe0=thetai-theta0i
4525         term1=-0.5D0*sigcsq*delthec*delthec
4526         term2=-0.5D0*sig0inv*delthe0*delthe0
4527 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4528 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4529 ! to the energy (this being the log of the distribution) at the end of energy
4530 ! term evaluation for this virtual-bond angle.
4531         if (term1.gt.term2) then
4532           termm=term1
4533           term2=dexp(term2-termm)
4534           term1=1.0d0
4535         else
4536           termm=term2
4537           term1=dexp(term1-termm)
4538           term2=1.0d0
4539         endif
4540 ! The ratio between the gamma-independent and gamma-dependent lobes of
4541 ! the distribution is a Gaussian function of thet_pred_mean too.
4542         diffak=gthet(2,it)-thet_pred_mean
4543         ratak=diffak/gthet(3,it)**2
4544         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4545 ! Let's differentiate it in thet_pred_mean NOW.
4546         aktc=ak*ratak
4547 ! Now put together the distribution terms to make complete distribution.
4548         termexp=term1+ak*term2
4549         termpre=sigc+ak*sig0i
4550 ! Contribution of the bending energy from this theta is just the -log of
4551 ! the sum of the contributions from the two lobes and the pre-exponential
4552 ! factor. Simple enough, isn't it?
4553         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4554 ! NOW the derivatives!!!
4555 ! 6/6/97 Take into account the deformation.
4556         E_theta=(delthec*sigcsq*term1 &
4557              +ak*delthe0*sig0inv*term2)/termexp
4558         E_tc=((sigtc+aktc*sig0i)/termpre &
4559             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4560              aktc*term2)/termexp)
4561       return
4562       end subroutine theteng
4563 #else
4564 !-----------------------------------------------------------------------------
4565       subroutine ebend(etheta)
4566 !
4567 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4568 ! angles gamma and its derivatives in consecutive thetas and gammas.
4569 ! ab initio-derived potentials from
4570 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4571 !
4572 !      implicit real*8 (a-h,o-z)
4573 !      include 'DIMENSIONS'
4574 !      include 'COMMON.LOCAL'
4575 !      include 'COMMON.GEO'
4576 !      include 'COMMON.INTERACT'
4577 !      include 'COMMON.DERIV'
4578 !      include 'COMMON.VAR'
4579 !      include 'COMMON.CHAIN'
4580 !      include 'COMMON.IOUNITS'
4581 !      include 'COMMON.NAMES'
4582 !      include 'COMMON.FFIELD'
4583 !      include 'COMMON.CONTROL'
4584       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4585       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4586       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4587       logical :: lprn=.false., lprn1=.false.
4588 !el local variables
4589       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4590       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4591       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4592
4593       etheta=0.0D0
4594       do i=ithet_start,ithet_end
4595         if (itype(i-1).eq.ntyp1) cycle
4596         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4597         if (iabs(itype(i+1)).eq.20) iblock=2
4598         if (iabs(itype(i+1)).ne.20) iblock=1
4599         dethetai=0.0d0
4600         dephii=0.0d0
4601         dephii1=0.0d0
4602         theti2=0.5d0*theta(i)
4603         ityp2=ithetyp((itype(i-1)))
4604         do k=1,nntheterm
4605           coskt(k)=dcos(k*theti2)
4606           sinkt(k)=dsin(k*theti2)
4607         enddo
4608         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4609 #ifdef OSF
4610           phii=phi(i)
4611           if (phii.ne.phii) phii=150.0
4612 #else
4613           phii=phi(i)
4614 #endif
4615           ityp1=ithetyp((itype(i-2)))
4616 ! propagation of chirality for glycine type
4617           do k=1,nsingle
4618             cosph1(k)=dcos(k*phii)
4619             sinph1(k)=dsin(k*phii)
4620           enddo
4621         else
4622           phii=0.0d0
4623           ityp1=ithetyp(itype(i-2))
4624           do k=1,nsingle
4625             cosph1(k)=0.0d0
4626             sinph1(k)=0.0d0
4627           enddo
4628         endif
4629         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4630 #ifdef OSF
4631           phii1=phi(i+1)
4632           if (phii1.ne.phii1) phii1=150.0
4633           phii1=pinorm(phii1)
4634 #else
4635           phii1=phi(i+1)
4636 #endif
4637           ityp3=ithetyp((itype(i)))
4638           do k=1,nsingle
4639             cosph2(k)=dcos(k*phii1)
4640             sinph2(k)=dsin(k*phii1)
4641           enddo
4642         else
4643           phii1=0.0d0
4644           ityp3=ithetyp(itype(i))
4645           do k=1,nsingle
4646             cosph2(k)=0.0d0
4647             sinph2(k)=0.0d0
4648           enddo
4649         endif
4650         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4651         do k=1,ndouble
4652           do l=1,k-1
4653             ccl=cosph1(l)*cosph2(k-l)
4654             ssl=sinph1(l)*sinph2(k-l)
4655             scl=sinph1(l)*cosph2(k-l)
4656             csl=cosph1(l)*sinph2(k-l)
4657             cosph1ph2(l,k)=ccl-ssl
4658             cosph1ph2(k,l)=ccl+ssl
4659             sinph1ph2(l,k)=scl+csl
4660             sinph1ph2(k,l)=scl-csl
4661           enddo
4662         enddo
4663         if (lprn) then
4664         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4665           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4666         write (iout,*) "coskt and sinkt"
4667         do k=1,nntheterm
4668           write (iout,*) k,coskt(k),sinkt(k)
4669         enddo
4670         endif
4671         do k=1,ntheterm
4672           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4673           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4674             *coskt(k)
4675           if (lprn) &
4676           write (iout,*) "k",k,&
4677            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4678            " ethetai",ethetai
4679         enddo
4680         if (lprn) then
4681         write (iout,*) "cosph and sinph"
4682         do k=1,nsingle
4683           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4684         enddo
4685         write (iout,*) "cosph1ph2 and sinph2ph2"
4686         do k=2,ndouble
4687           do l=1,k-1
4688             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4689                sinph1ph2(l,k),sinph1ph2(k,l)
4690           enddo
4691         enddo
4692         write(iout,*) "ethetai",ethetai
4693         endif
4694         do m=1,ntheterm2
4695           do k=1,nsingle
4696             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4697                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4698                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4699                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4700             ethetai=ethetai+sinkt(m)*aux
4701             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4702             dephii=dephii+k*sinkt(m)* &
4703                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4704                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4705             dephii1=dephii1+k*sinkt(m)* &
4706                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4707                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4708             if (lprn) &
4709             write (iout,*) "m",m," k",k," bbthet", &
4710                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4711                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4712                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4713                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4714           enddo
4715         enddo
4716         if (lprn) &
4717         write(iout,*) "ethetai",ethetai
4718         do m=1,ntheterm3
4719           do k=2,ndouble
4720             do l=1,k-1
4721               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4722                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4723                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4724                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4725               ethetai=ethetai+sinkt(m)*aux
4726               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4727               dephii=dephii+l*sinkt(m)* &
4728                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4729                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4730                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4731                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4732               dephii1=dephii1+(k-l)*sinkt(m)* &
4733                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4734                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4735                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4736                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4737               if (lprn) then
4738               write (iout,*) "m",m," k",k," l",l," ffthet",&
4739                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4740                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4741                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4742                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4743                   " ethetai",ethetai
4744               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4745                   cosph1ph2(k,l)*sinkt(m),&
4746                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4747               endif
4748             enddo
4749           enddo
4750         enddo
4751 10      continue
4752 !        lprn1=.true.
4753         if (lprn1) &
4754           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4755          i,theta(i)*rad2deg,phii*rad2deg,&
4756          phii1*rad2deg,ethetai
4757 !        lprn1=.false.
4758         etheta=etheta+ethetai
4759         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4760                                     'ebend',i,ethetai
4761         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4762         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4763         gloc(nphi+i-2,icg)=wang*dethetai
4764       enddo
4765       return
4766       end subroutine ebend
4767 #endif
4768 #ifdef CRYST_SC
4769 !-----------------------------------------------------------------------------
4770       subroutine esc(escloc)
4771 ! Calculate the local energy of a side chain and its derivatives in the
4772 ! corresponding virtual-bond valence angles THETA and the spherical angles
4773 ! ALPHA and OMEGA.
4774 !
4775       use comm_sccalc
4776 !      implicit real*8 (a-h,o-z)
4777 !      include 'DIMENSIONS'
4778 !      include 'COMMON.GEO'
4779 !      include 'COMMON.LOCAL'
4780 !      include 'COMMON.VAR'
4781 !      include 'COMMON.INTERACT'
4782 !      include 'COMMON.DERIV'
4783 !      include 'COMMON.CHAIN'
4784 !      include 'COMMON.IOUNITS'
4785 !      include 'COMMON.NAMES'
4786 !      include 'COMMON.FFIELD'
4787 !      include 'COMMON.CONTROL'
4788       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4789          ddersc0,ddummy,xtemp,temp
4790 !el      real(kind=8) :: time11,time12,time112,theti
4791       real(kind=8) :: escloc,delta
4792 !el      integer :: it,nlobit
4793 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4794 !el local variables
4795       integer :: i,k
4796       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4797        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4798       delta=0.02d0*pi
4799       escloc=0.0D0
4800 !     write (iout,'(a)') 'ESC'
4801       do i=loc_start,loc_end
4802         it=itype(i)
4803         if (it.eq.ntyp1) cycle
4804         if (it.eq.10) goto 1
4805         nlobit=nlob(iabs(it))
4806 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4807 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4808         theti=theta(i+1)-pipol
4809         x(1)=dtan(theti)
4810         x(2)=alph(i)
4811         x(3)=omeg(i)
4812
4813         if (x(2).gt.pi-delta) then
4814           xtemp(1)=x(1)
4815           xtemp(2)=pi-delta
4816           xtemp(3)=x(3)
4817           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4818           xtemp(2)=pi
4819           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4820           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4821               escloci,dersc(2))
4822           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4823               ddersc0(1),dersc(1))
4824           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4825               ddersc0(3),dersc(3))
4826           xtemp(2)=pi-delta
4827           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4828           xtemp(2)=pi
4829           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4830           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4831                   dersc0(2),esclocbi,dersc02)
4832           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4833                   dersc12,dersc01)
4834           call splinthet(x(2),0.5d0*delta,ss,ssd)
4835           dersc0(1)=dersc01
4836           dersc0(2)=dersc02
4837           dersc0(3)=0.0d0
4838           do k=1,3
4839             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4840           enddo
4841           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4842 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4843 !    &             esclocbi,ss,ssd
4844           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4845 !         escloci=esclocbi
4846 !         write (iout,*) escloci
4847         else if (x(2).lt.delta) then
4848           xtemp(1)=x(1)
4849           xtemp(2)=delta
4850           xtemp(3)=x(3)
4851           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4852           xtemp(2)=0.0d0
4853           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4854           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4855               escloci,dersc(2))
4856           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4857               ddersc0(1),dersc(1))
4858           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4859               ddersc0(3),dersc(3))
4860           xtemp(2)=delta
4861           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4862           xtemp(2)=0.0d0
4863           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4864           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4865                   dersc0(2),esclocbi,dersc02)
4866           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4867                   dersc12,dersc01)
4868           dersc0(1)=dersc01
4869           dersc0(2)=dersc02
4870           dersc0(3)=0.0d0
4871           call splinthet(x(2),0.5d0*delta,ss,ssd)
4872           do k=1,3
4873             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4874           enddo
4875           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4876 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4877 !    &             esclocbi,ss,ssd
4878           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4879 !         write (iout,*) escloci
4880         else
4881           call enesc(x,escloci,dersc,ddummy,.false.)
4882         endif
4883
4884         escloc=escloc+escloci
4885         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4886            'escloc',i,escloci
4887 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4888
4889         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4890          wscloc*dersc(1)
4891         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4892         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4893     1   continue
4894       enddo
4895       return
4896       end subroutine esc
4897 !-----------------------------------------------------------------------------
4898       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4899
4900       use comm_sccalc
4901 !      implicit real*8 (a-h,o-z)
4902 !      include 'DIMENSIONS'
4903 !      include 'COMMON.GEO'
4904 !      include 'COMMON.LOCAL'
4905 !      include 'COMMON.IOUNITS'
4906 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4907       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4908       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4909       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4910       real(kind=8) :: escloci
4911       logical :: mixed
4912 !el local variables
4913       integer :: j,iii,l,k !el,it,nlobit
4914       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4915 !el       time11,time12,time112
4916 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4917         escloc_i=0.0D0
4918         do j=1,3
4919           dersc(j)=0.0D0
4920           if (mixed) ddersc(j)=0.0d0
4921         enddo
4922         x3=x(3)
4923
4924 ! Because of periodicity of the dependence of the SC energy in omega we have
4925 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4926 ! To avoid underflows, first compute & store the exponents.
4927
4928         do iii=-1,1
4929
4930           x(3)=x3+iii*dwapi
4931
4932           do j=1,nlobit
4933             do k=1,3
4934               z(k)=x(k)-censc(k,j,it)
4935             enddo
4936             do k=1,3
4937               Axk=0.0D0
4938               do l=1,3
4939                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4940               enddo
4941               Ax(k,j,iii)=Axk
4942             enddo
4943             expfac=0.0D0
4944             do k=1,3
4945               expfac=expfac+Ax(k,j,iii)*z(k)
4946             enddo
4947             contr(j,iii)=expfac
4948           enddo ! j
4949
4950         enddo ! iii
4951
4952         x(3)=x3
4953 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4954 ! subsequent NaNs and INFs in energy calculation.
4955 ! Find the largest exponent
4956         emin=contr(1,-1)
4957         do iii=-1,1
4958           do j=1,nlobit
4959             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4960           enddo
4961         enddo
4962         emin=0.5D0*emin
4963 !d      print *,'it=',it,' emin=',emin
4964
4965 ! Compute the contribution to SC energy and derivatives
4966         do iii=-1,1
4967
4968           do j=1,nlobit
4969 #ifdef OSF
4970             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4971             if(adexp.ne.adexp) adexp=1.0
4972             expfac=dexp(adexp)
4973 #else
4974             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4975 #endif
4976 !d          print *,'j=',j,' expfac=',expfac
4977             escloc_i=escloc_i+expfac
4978             do k=1,3
4979               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4980             enddo
4981             if (mixed) then
4982               do k=1,3,2
4983                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4984                   +gaussc(k,2,j,it))*expfac
4985               enddo
4986             endif
4987           enddo
4988
4989         enddo ! iii
4990
4991         dersc(1)=dersc(1)/cos(theti)**2
4992         ddersc(1)=ddersc(1)/cos(theti)**2
4993         ddersc(3)=ddersc(3)
4994
4995         escloci=-(dlog(escloc_i)-emin)
4996         do j=1,3
4997           dersc(j)=dersc(j)/escloc_i
4998         enddo
4999         if (mixed) then
5000           do j=1,3,2
5001             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5002           enddo
5003         endif
5004       return
5005       end subroutine enesc
5006 !-----------------------------------------------------------------------------
5007       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5008
5009       use comm_sccalc
5010 !      implicit real*8 (a-h,o-z)
5011 !      include 'DIMENSIONS'
5012 !      include 'COMMON.GEO'
5013 !      include 'COMMON.LOCAL'
5014 !      include 'COMMON.IOUNITS'
5015 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5016       real(kind=8),dimension(3) :: x,z,dersc
5017       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5018       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5019       real(kind=8) :: escloci,dersc12,emin
5020       logical :: mixed
5021 !el local varables
5022       integer :: j,k,l !el,it,nlobit
5023       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5024
5025       escloc_i=0.0D0
5026
5027       do j=1,3
5028         dersc(j)=0.0D0
5029       enddo
5030
5031       do j=1,nlobit
5032         do k=1,2
5033           z(k)=x(k)-censc(k,j,it)
5034         enddo
5035         z(3)=dwapi
5036         do k=1,3
5037           Axk=0.0D0
5038           do l=1,3
5039             Axk=Axk+gaussc(l,k,j,it)*z(l)
5040           enddo
5041           Ax(k,j)=Axk
5042         enddo
5043         expfac=0.0D0
5044         do k=1,3
5045           expfac=expfac+Ax(k,j)*z(k)
5046         enddo
5047         contr(j)=expfac
5048       enddo ! j
5049
5050 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5051 ! subsequent NaNs and INFs in energy calculation.
5052 ! Find the largest exponent
5053       emin=contr(1)
5054       do j=1,nlobit
5055         if (emin.gt.contr(j)) emin=contr(j)
5056       enddo
5057       emin=0.5D0*emin
5058
5059 ! Compute the contribution to SC energy and derivatives
5060
5061       dersc12=0.0d0
5062       do j=1,nlobit
5063         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5064         escloc_i=escloc_i+expfac
5065         do k=1,2
5066           dersc(k)=dersc(k)+Ax(k,j)*expfac
5067         enddo
5068         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5069                   +gaussc(1,2,j,it))*expfac
5070         dersc(3)=0.0d0
5071       enddo
5072
5073       dersc(1)=dersc(1)/cos(theti)**2
5074       dersc12=dersc12/cos(theti)**2
5075       escloci=-(dlog(escloc_i)-emin)
5076       do j=1,2
5077         dersc(j)=dersc(j)/escloc_i
5078       enddo
5079       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5080       return
5081       end subroutine enesc_bound
5082 #else
5083 !-----------------------------------------------------------------------------
5084       subroutine esc(escloc)
5085 ! Calculate the local energy of a side chain and its derivatives in the
5086 ! corresponding virtual-bond valence angles THETA and the spherical angles
5087 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5088 ! added by Urszula Kozlowska. 07/11/2007
5089 !
5090       use comm_sccalc
5091 !      implicit real*8 (a-h,o-z)
5092 !      include 'DIMENSIONS'
5093 !      include 'COMMON.GEO'
5094 !      include 'COMMON.LOCAL'
5095 !      include 'COMMON.VAR'
5096 !      include 'COMMON.SCROT'
5097 !      include 'COMMON.INTERACT'
5098 !      include 'COMMON.DERIV'
5099 !      include 'COMMON.CHAIN'
5100 !      include 'COMMON.IOUNITS'
5101 !      include 'COMMON.NAMES'
5102 !      include 'COMMON.FFIELD'
5103 !      include 'COMMON.CONTROL'
5104 !      include 'COMMON.VECTORS'
5105       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5106       real(kind=8),dimension(65) :: x
5107       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5108          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5109       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5110       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5111          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5112 !el local variables
5113       integer :: i,j,k !el,it,nlobit
5114       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5115 !el      real(kind=8) :: time11,time12,time112,theti
5116 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5117       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5118                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5119                    sumene1x,sumene2x,sumene3x,sumene4x,&
5120                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5121                    cosfac2xx,sinfac2yy
5122 #ifdef DEBUG
5123       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5124                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5125                    de_dt_num
5126 #endif
5127 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5128
5129       delta=0.02d0*pi
5130       escloc=0.0D0
5131       do i=loc_start,loc_end
5132         if (itype(i).eq.ntyp1) cycle
5133         costtab(i+1) =dcos(theta(i+1))
5134         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5135         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5136         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5137         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5138         cosfac=dsqrt(cosfac2)
5139         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5140         sinfac=dsqrt(sinfac2)
5141         it=iabs(itype(i))
5142         if (it.eq.10) goto 1
5143 !
5144 !  Compute the axes of tghe local cartesian coordinates system; store in
5145 !   x_prime, y_prime and z_prime
5146 !
5147         do j=1,3
5148           x_prime(j) = 0.00
5149           y_prime(j) = 0.00
5150           z_prime(j) = 0.00
5151         enddo
5152 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5153 !     &   dc_norm(3,i+nres)
5154         do j = 1,3
5155           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5156           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5157         enddo
5158         do j = 1,3
5159           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5160         enddo
5161 !       write (2,*) "i",i
5162 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5163 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5164 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5165 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5166 !      & " xy",scalar(x_prime(1),y_prime(1)),
5167 !      & " xz",scalar(x_prime(1),z_prime(1)),
5168 !      & " yy",scalar(y_prime(1),y_prime(1)),
5169 !      & " yz",scalar(y_prime(1),z_prime(1)),
5170 !      & " zz",scalar(z_prime(1),z_prime(1))
5171 !
5172 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5173 ! to local coordinate system. Store in xx, yy, zz.
5174 !
5175         xx=0.0d0
5176         yy=0.0d0
5177         zz=0.0d0
5178         do j = 1,3
5179           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5180           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5181           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5182         enddo
5183
5184         xxtab(i)=xx
5185         yytab(i)=yy
5186         zztab(i)=zz
5187 !
5188 ! Compute the energy of the ith side cbain
5189 !
5190 !        write (2,*) "xx",xx," yy",yy," zz",zz
5191         it=iabs(itype(i))
5192         do j = 1,65
5193           x(j) = sc_parmin(j,it)
5194         enddo
5195 #ifdef CHECK_COORD
5196 !c diagnostics - remove later
5197         xx1 = dcos(alph(2))
5198         yy1 = dsin(alph(2))*dcos(omeg(2))
5199         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5200         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5201           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5202           xx1,yy1,zz1
5203 !,"  --- ", xx_w,yy_w,zz_w
5204 ! end diagnostics
5205 #endif
5206         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5207          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5208          + x(10)*yy*zz
5209         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5210          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5211          + x(20)*yy*zz
5212         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5213          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5214          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5215          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5216          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5217          +x(40)*xx*yy*zz
5218         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5219          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5220          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5221          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5222          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5223          +x(60)*xx*yy*zz
5224         dsc_i   = 0.743d0+x(61)
5225         dp2_i   = 1.9d0+x(62)
5226         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5227                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5228         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5229                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5230         s1=(1+x(63))/(0.1d0 + dscp1)
5231         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5232         s2=(1+x(65))/(0.1d0 + dscp2)
5233         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5234         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5235       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5236 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5237 !     &   sumene4,
5238 !     &   dscp1,dscp2,sumene
5239 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5240         escloc = escloc + sumene
5241 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5242 !     & ,zz,xx,yy
5243 !#define DEBUG
5244 #ifdef DEBUG
5245 !
5246 ! This section to check the numerical derivatives of the energy of ith side
5247 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5248 ! #define DEBUG in the code to turn it on.
5249 !
5250         write (2,*) "sumene               =",sumene
5251         aincr=1.0d-7
5252         xxsave=xx
5253         xx=xx+aincr
5254         write (2,*) xx,yy,zz
5255         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5256         de_dxx_num=(sumenep-sumene)/aincr
5257         xx=xxsave
5258         write (2,*) "xx+ sumene from enesc=",sumenep
5259         yysave=yy
5260         yy=yy+aincr
5261         write (2,*) xx,yy,zz
5262         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5263         de_dyy_num=(sumenep-sumene)/aincr
5264         yy=yysave
5265         write (2,*) "yy+ sumene from enesc=",sumenep
5266         zzsave=zz
5267         zz=zz+aincr
5268         write (2,*) xx,yy,zz
5269         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5270         de_dzz_num=(sumenep-sumene)/aincr
5271         zz=zzsave
5272         write (2,*) "zz+ sumene from enesc=",sumenep
5273         costsave=cost2tab(i+1)
5274         sintsave=sint2tab(i+1)
5275         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5276         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5277         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5278         de_dt_num=(sumenep-sumene)/aincr
5279         write (2,*) " t+ sumene from enesc=",sumenep
5280         cost2tab(i+1)=costsave
5281         sint2tab(i+1)=sintsave
5282 ! End of diagnostics section.
5283 #endif
5284 !
5285 ! Compute the gradient of esc
5286 !
5287 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5288         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5289         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5290         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5291         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5292         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5293         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5294         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5295         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5296         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5297            *(pom_s1/dscp1+pom_s16*dscp1**4)
5298         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5299            *(pom_s2/dscp2+pom_s26*dscp2**4)
5300         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5301         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5302         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5303         +x(40)*yy*zz
5304         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5305         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5306         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5307         +x(60)*yy*zz
5308         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5309               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5310               +(pom1+pom2)*pom_dx
5311 #ifdef DEBUG
5312         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5313 #endif
5314 !
5315         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5316         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5317         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5318         +x(40)*xx*zz
5319         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5320         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5321         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5322         +x(59)*zz**2 +x(60)*xx*zz
5323         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5324               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5325               +(pom1-pom2)*pom_dy
5326 #ifdef DEBUG
5327         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5328 #endif
5329 !
5330         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5331         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5332         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5333         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5334         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5335         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5336         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5337         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5338 #ifdef DEBUG
5339         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5340 #endif
5341 !
5342         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5343         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5344         +pom1*pom_dt1+pom2*pom_dt2
5345 #ifdef DEBUG
5346         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5347 #endif
5348 !
5349 !
5350        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5351        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5352        cosfac2xx=cosfac2*xx
5353        sinfac2yy=sinfac2*yy
5354        do k = 1,3
5355          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5356             vbld_inv(i+1)
5357          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5358             vbld_inv(i)
5359          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5360          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5361 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5362 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5363 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5364 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5365          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5366          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5367          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5368          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5369          dZZ_Ci1(k)=0.0d0
5370          dZZ_Ci(k)=0.0d0
5371          do j=1,3
5372            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5373            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5374            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5375            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5376          enddo
5377
5378          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5379          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5380          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5381          (z_prime(k)-zz*dC_norm(k,i+nres))
5382 !
5383          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5384          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5385        enddo
5386
5387        do k=1,3
5388          dXX_Ctab(k,i)=dXX_Ci(k)
5389          dXX_C1tab(k,i)=dXX_Ci1(k)
5390          dYY_Ctab(k,i)=dYY_Ci(k)
5391          dYY_C1tab(k,i)=dYY_Ci1(k)
5392          dZZ_Ctab(k,i)=dZZ_Ci(k)
5393          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5394          dXX_XYZtab(k,i)=dXX_XYZ(k)
5395          dYY_XYZtab(k,i)=dYY_XYZ(k)
5396          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5397        enddo
5398
5399        do k = 1,3
5400 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5401 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5402 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5403 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5404 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5405 !     &    dt_dci(k)
5406 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5407 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5408          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5409           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5410          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5411           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5412          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5413           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5414        enddo
5415 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5416 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5417
5418 ! to check gradient call subroutine check_grad
5419
5420     1 continue
5421       enddo
5422       return
5423       end subroutine esc
5424 !-----------------------------------------------------------------------------
5425       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5426 !      implicit none
5427       real(kind=8),dimension(65) :: x
5428       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5429         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5430
5431       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5432         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5433         + x(10)*yy*zz
5434       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5435         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5436         + x(20)*yy*zz
5437       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5438         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5439         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5440         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5441         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5442         +x(40)*xx*yy*zz
5443       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5444         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5445         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5446         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5447         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5448         +x(60)*xx*yy*zz
5449       dsc_i   = 0.743d0+x(61)
5450       dp2_i   = 1.9d0+x(62)
5451       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5452                 *(xx*cost2+yy*sint2))
5453       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5454                 *(xx*cost2-yy*sint2))
5455       s1=(1+x(63))/(0.1d0 + dscp1)
5456       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5457       s2=(1+x(65))/(0.1d0 + dscp2)
5458       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5459       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5460        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5461       enesc=sumene
5462       return
5463       end function enesc
5464 #endif
5465 !-----------------------------------------------------------------------------
5466       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5467 !
5468 ! This procedure calculates two-body contact function g(rij) and its derivative:
5469 !
5470 !           eps0ij                                     !       x < -1
5471 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5472 !            0                                         !       x > 1
5473 !
5474 ! where x=(rij-r0ij)/delta
5475 !
5476 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5477 !
5478 !      implicit none
5479       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5480       real(kind=8) :: x,x2,x4,delta
5481 !     delta=0.02D0*r0ij
5482 !      delta=0.2D0*r0ij
5483       x=(rij-r0ij)/delta
5484       if (x.lt.-1.0D0) then
5485         fcont=eps0ij
5486         fprimcont=0.0D0
5487       else if (x.le.1.0D0) then
5488         x2=x*x
5489         x4=x2*x2
5490         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5491         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5492       else
5493         fcont=0.0D0
5494         fprimcont=0.0D0
5495       endif
5496       return
5497       end subroutine gcont
5498 !-----------------------------------------------------------------------------
5499       subroutine splinthet(theti,delta,ss,ssder)
5500 !      implicit real*8 (a-h,o-z)
5501 !      include 'DIMENSIONS'
5502 !      include 'COMMON.VAR'
5503 !      include 'COMMON.GEO'
5504       real(kind=8) :: theti,delta,ss,ssder
5505       real(kind=8) :: thetup,thetlow
5506       thetup=pi-delta
5507       thetlow=delta
5508       if (theti.gt.pipol) then
5509         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5510       else
5511         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5512         ssder=-ssder
5513       endif
5514       return
5515       end subroutine splinthet
5516 !-----------------------------------------------------------------------------
5517       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5518 !      implicit none
5519       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5520       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5521       a1=fprim0*delta/(f1-f0)
5522       a2=3.0d0-2.0d0*a1
5523       a3=a1-2.0d0
5524       ksi=(x-x0)/delta
5525       ksi2=ksi*ksi
5526       ksi3=ksi2*ksi
5527       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5528       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5529       return
5530       end subroutine spline1
5531 !-----------------------------------------------------------------------------
5532       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5533 !      implicit none
5534       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5535       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5536       ksi=(x-x0)/delta
5537       ksi2=ksi*ksi
5538       ksi3=ksi2*ksi
5539       a1=fprim0x*delta
5540       a2=3*(f1x-f0x)-2*fprim0x*delta
5541       a3=fprim0x*delta-2*(f1x-f0x)
5542       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5543       return
5544       end subroutine spline2
5545 !-----------------------------------------------------------------------------
5546 #ifdef CRYST_TOR
5547 !-----------------------------------------------------------------------------
5548       subroutine etor(etors,edihcnstr)
5549 !      implicit real*8 (a-h,o-z)
5550 !      include 'DIMENSIONS'
5551 !      include 'COMMON.VAR'
5552 !      include 'COMMON.GEO'
5553 !      include 'COMMON.LOCAL'
5554 !      include 'COMMON.TORSION'
5555 !      include 'COMMON.INTERACT'
5556 !      include 'COMMON.DERIV'
5557 !      include 'COMMON.CHAIN'
5558 !      include 'COMMON.NAMES'
5559 !      include 'COMMON.IOUNITS'
5560 !      include 'COMMON.FFIELD'
5561 !      include 'COMMON.TORCNSTR'
5562 !      include 'COMMON.CONTROL'
5563       real(kind=8) :: etors,edihcnstr
5564       logical :: lprn
5565 !el local variables
5566       integer :: i,j,
5567       real(kind=8) :: phii,fac,etors_ii
5568
5569 ! Set lprn=.true. for debugging
5570       lprn=.false.
5571 !      lprn=.true.
5572       etors=0.0D0
5573       do i=iphi_start,iphi_end
5574       etors_ii=0.0D0
5575         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5576             .or. itype(i).eq.ntyp1) cycle
5577         itori=itortyp(itype(i-2))
5578         itori1=itortyp(itype(i-1))
5579         phii=phi(i)
5580         gloci=0.0D0
5581 ! Proline-Proline pair is a special case...
5582         if (itori.eq.3 .and. itori1.eq.3) then
5583           if (phii.gt.-dwapi3) then
5584             cosphi=dcos(3*phii)
5585             fac=1.0D0/(1.0D0-cosphi)
5586             etorsi=v1(1,3,3)*fac
5587             etorsi=etorsi+etorsi
5588             etors=etors+etorsi-v1(1,3,3)
5589             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5590             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5591           endif
5592           do j=1,3
5593             v1ij=v1(j+1,itori,itori1)
5594             v2ij=v2(j+1,itori,itori1)
5595             cosphi=dcos(j*phii)
5596             sinphi=dsin(j*phii)
5597             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5598             if (energy_dec) etors_ii=etors_ii+ &
5599                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5600             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5601           enddo
5602         else
5603           do j=1,nterm_old
5604             v1ij=v1(j,itori,itori1)
5605             v2ij=v2(j,itori,itori1)
5606             cosphi=dcos(j*phii)
5607             sinphi=dsin(j*phii)
5608             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5609             if (energy_dec) etors_ii=etors_ii+ &
5610                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5611             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5612           enddo
5613         endif
5614         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5615              'etor',i,etors_ii
5616         if (lprn) &
5617         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5618         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5619         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5620         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5621 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5622       enddo
5623 ! 6/20/98 - dihedral angle constraints
5624       edihcnstr=0.0d0
5625       do i=1,ndih_constr
5626         itori=idih_constr(i)
5627         phii=phi(itori)
5628         difi=phii-phi0(i)
5629         if (difi.gt.drange(i)) then
5630           difi=difi-drange(i)
5631           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5632           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5633         else if (difi.lt.-drange(i)) then
5634           difi=difi+drange(i)
5635           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5636           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5637         endif
5638 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5639 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5640       enddo
5641 !      write (iout,*) 'edihcnstr',edihcnstr
5642       return
5643       end subroutine etor
5644 !-----------------------------------------------------------------------------
5645       subroutine etor_d(etors_d)
5646       real(kind=8) :: etors_d
5647       etors_d=0.0d0
5648       return
5649       end subroutine etor_d
5650 #else
5651 !-----------------------------------------------------------------------------
5652       subroutine etor(etors,edihcnstr)
5653 !      implicit real*8 (a-h,o-z)
5654 !      include 'DIMENSIONS'
5655 !      include 'COMMON.VAR'
5656 !      include 'COMMON.GEO'
5657 !      include 'COMMON.LOCAL'
5658 !      include 'COMMON.TORSION'
5659 !      include 'COMMON.INTERACT'
5660 !      include 'COMMON.DERIV'
5661 !      include 'COMMON.CHAIN'
5662 !      include 'COMMON.NAMES'
5663 !      include 'COMMON.IOUNITS'
5664 !      include 'COMMON.FFIELD'
5665 !      include 'COMMON.TORCNSTR'
5666 !      include 'COMMON.CONTROL'
5667       real(kind=8) :: etors,edihcnstr
5668       logical :: lprn
5669 !el local variables
5670       integer :: i,j,iblock,itori,itori1
5671       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5672                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5673 ! Set lprn=.true. for debugging
5674       lprn=.false.
5675 !     lprn=.true.
5676       etors=0.0D0
5677       do i=iphi_start,iphi_end
5678         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5679              .or. itype(i-3).eq.ntyp1 &
5680              .or. itype(i).eq.ntyp1) cycle
5681         etors_ii=0.0D0
5682          if (iabs(itype(i)).eq.20) then
5683          iblock=2
5684          else
5685          iblock=1
5686          endif
5687         itori=itortyp(itype(i-2))
5688         itori1=itortyp(itype(i-1))
5689         phii=phi(i)
5690         gloci=0.0D0
5691 ! Regular cosine and sine terms
5692         do j=1,nterm(itori,itori1,iblock)
5693           v1ij=v1(j,itori,itori1,iblock)
5694           v2ij=v2(j,itori,itori1,iblock)
5695           cosphi=dcos(j*phii)
5696           sinphi=dsin(j*phii)
5697           etors=etors+v1ij*cosphi+v2ij*sinphi
5698           if (energy_dec) etors_ii=etors_ii+ &
5699                      v1ij*cosphi+v2ij*sinphi
5700           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5701         enddo
5702 ! Lorentz terms
5703 !                         v1
5704 !  E = SUM ----------------------------------- - v1
5705 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5706 !
5707         cosphi=dcos(0.5d0*phii)
5708         sinphi=dsin(0.5d0*phii)
5709         do j=1,nlor(itori,itori1,iblock)
5710           vl1ij=vlor1(j,itori,itori1)
5711           vl2ij=vlor2(j,itori,itori1)
5712           vl3ij=vlor3(j,itori,itori1)
5713           pom=vl2ij*cosphi+vl3ij*sinphi
5714           pom1=1.0d0/(pom*pom+1.0d0)
5715           etors=etors+vl1ij*pom1
5716           if (energy_dec) etors_ii=etors_ii+ &
5717                      vl1ij*pom1
5718           pom=-pom*pom1*pom1
5719           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5720         enddo
5721 ! Subtract the constant term
5722         etors=etors-v0(itori,itori1,iblock)
5723           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5724                'etor',i,etors_ii-v0(itori,itori1,iblock)
5725         if (lprn) &
5726         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5727         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5728         (v1(j,itori,itori1,iblock),j=1,6),&
5729         (v2(j,itori,itori1,iblock),j=1,6)
5730         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5731 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5732       enddo
5733 ! 6/20/98 - dihedral angle constraints
5734       edihcnstr=0.0d0
5735 !      do i=1,ndih_constr
5736       do i=idihconstr_start,idihconstr_end
5737         itori=idih_constr(i)
5738         phii=phi(itori)
5739         difi=pinorm(phii-phi0(i))
5740         if (difi.gt.drange(i)) then
5741           difi=difi-drange(i)
5742           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5743           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5744         else if (difi.lt.-drange(i)) then
5745           difi=difi+drange(i)
5746           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5748         else
5749           difi=0.0
5750         endif
5751 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5752 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5753 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5754       enddo
5755 !d       write (iout,*) 'edihcnstr',edihcnstr
5756       return
5757       end subroutine etor
5758 !-----------------------------------------------------------------------------
5759       subroutine etor_d(etors_d)
5760 ! 6/23/01 Compute double torsional energy
5761 !      implicit real*8 (a-h,o-z)
5762 !      include 'DIMENSIONS'
5763 !      include 'COMMON.VAR'
5764 !      include 'COMMON.GEO'
5765 !      include 'COMMON.LOCAL'
5766 !      include 'COMMON.TORSION'
5767 !      include 'COMMON.INTERACT'
5768 !      include 'COMMON.DERIV'
5769 !      include 'COMMON.CHAIN'
5770 !      include 'COMMON.NAMES'
5771 !      include 'COMMON.IOUNITS'
5772 !      include 'COMMON.FFIELD'
5773 !      include 'COMMON.TORCNSTR'
5774       real(kind=8) :: etors_d,etors_d_ii
5775       logical :: lprn
5776 !el local variables
5777       integer :: i,j,k,l,itori,itori1,itori2,iblock
5778       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5779                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5780                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5781                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5782 ! Set lprn=.true. for debugging
5783       lprn=.false.
5784 !     lprn=.true.
5785       etors_d=0.0D0
5786 !      write(iout,*) "a tu??"
5787       do i=iphid_start,iphid_end
5788         etors_d_ii=0.0D0
5789         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5790             .or. itype(i-3).eq.ntyp1 &
5791             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5792         itori=itortyp(itype(i-2))
5793         itori1=itortyp(itype(i-1))
5794         itori2=itortyp(itype(i))
5795         phii=phi(i)
5796         phii1=phi(i+1)
5797         gloci1=0.0D0
5798         gloci2=0.0D0
5799         iblock=1
5800         if (iabs(itype(i+1)).eq.20) iblock=2
5801
5802 ! Regular cosine and sine terms
5803         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5804           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5805           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5806           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5807           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5808           cosphi1=dcos(j*phii)
5809           sinphi1=dsin(j*phii)
5810           cosphi2=dcos(j*phii1)
5811           sinphi2=dsin(j*phii1)
5812           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5813            v2cij*cosphi2+v2sij*sinphi2
5814           if (energy_dec) etors_d_ii=etors_d_ii+ &
5815            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5816           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5817           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5818         enddo
5819         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5820           do l=1,k-1
5821             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5822             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5823             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5824             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5825             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5826             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5827             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5828             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5829             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5830               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5831             if (energy_dec) etors_d_ii=etors_d_ii+ &
5832               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5833               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5834             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5835               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5836             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5837               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5838           enddo
5839         enddo
5840         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5841                             'etor_d',i,etors_d_ii
5842         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5843         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5844       enddo
5845       return
5846       end subroutine etor_d
5847 #endif
5848 !-----------------------------------------------------------------------------
5849       subroutine eback_sc_corr(esccor)
5850 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5851 !        conformational states; temporarily implemented as differences
5852 !        between UNRES torsional potentials (dependent on three types of
5853 !        residues) and the torsional potentials dependent on all 20 types
5854 !        of residues computed from AM1  energy surfaces of terminally-blocked
5855 !        amino-acid residues.
5856 !      implicit real*8 (a-h,o-z)
5857 !      include 'DIMENSIONS'
5858 !      include 'COMMON.VAR'
5859 !      include 'COMMON.GEO'
5860 !      include 'COMMON.LOCAL'
5861 !      include 'COMMON.TORSION'
5862 !      include 'COMMON.SCCOR'
5863 !      include 'COMMON.INTERACT'
5864 !      include 'COMMON.DERIV'
5865 !      include 'COMMON.CHAIN'
5866 !      include 'COMMON.NAMES'
5867 !      include 'COMMON.IOUNITS'
5868 !      include 'COMMON.FFIELD'
5869 !      include 'COMMON.CONTROL'
5870       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5871                    cosphi,sinphi
5872       logical :: lprn
5873       integer :: i,interty,j,isccori,isccori1,intertyp
5874 ! Set lprn=.true. for debugging
5875       lprn=.false.
5876 !      lprn=.true.
5877 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5878       esccor=0.0D0
5879       do i=itau_start,itau_end
5880         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5881         esccor_ii=0.0D0
5882         isccori=isccortyp(itype(i-2))
5883         isccori1=isccortyp(itype(i-1))
5884
5885 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5886         phii=phi(i)
5887         do intertyp=1,3 !intertyp
5888          esccor_ii=0.0D0
5889 !c Added 09 May 2012 (Adasko)
5890 !c  Intertyp means interaction type of backbone mainchain correlation:
5891 !   1 = SC...Ca...Ca...Ca
5892 !   2 = Ca...Ca...Ca...SC
5893 !   3 = SC...Ca...Ca...SCi
5894         gloci=0.0D0
5895         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5896             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5897             (itype(i-1).eq.ntyp1))) &
5898           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5899            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5900            .or.(itype(i).eq.ntyp1))) &
5901           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5902             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5903             (itype(i-3).eq.ntyp1)))) cycle
5904         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5905         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5906        cycle
5907        do j=1,nterm_sccor(isccori,isccori1)
5908           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5909           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5910           cosphi=dcos(j*tauangle(intertyp,i))
5911           sinphi=dsin(j*tauangle(intertyp,i))
5912           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5913           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5914           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5915         enddo
5916         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5917                                 'esccor',i,intertyp,esccor_ii
5918 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5919         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5920         if (lprn) &
5921         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5922         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5923         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5924         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5925         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5926        enddo !intertyp
5927       enddo
5928
5929       return
5930       end subroutine eback_sc_corr
5931 !-----------------------------------------------------------------------------
5932       subroutine multibody(ecorr)
5933 ! This subroutine calculates multi-body contributions to energy following
5934 ! the idea of Skolnick et al. If side chains I and J make a contact and
5935 ! at the same time side chains I+1 and J+1 make a contact, an extra
5936 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5937 !      implicit real*8 (a-h,o-z)
5938 !      include 'DIMENSIONS'
5939 !      include 'COMMON.IOUNITS'
5940 !      include 'COMMON.DERIV'
5941 !      include 'COMMON.INTERACT'
5942 !      include 'COMMON.CONTACTS'
5943       real(kind=8),dimension(3) :: gx,gx1
5944       logical :: lprn
5945       real(kind=8) :: ecorr
5946       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5947 ! Set lprn=.true. for debugging
5948       lprn=.false.
5949
5950       if (lprn) then
5951         write (iout,'(a)') 'Contact function values:'
5952         do i=nnt,nct-2
5953           write (iout,'(i2,20(1x,i2,f10.5))') &
5954               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5955         enddo
5956       endif
5957       ecorr=0.0D0
5958
5959 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5960 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5961       do i=nnt,nct
5962         do j=1,3
5963           gradcorr(j,i)=0.0D0
5964           gradxorr(j,i)=0.0D0
5965         enddo
5966       enddo
5967       do i=nnt,nct-2
5968
5969         DO ISHIFT = 3,4
5970
5971         i1=i+ishift
5972         num_conti=num_cont(i)
5973         num_conti1=num_cont(i1)
5974         do jj=1,num_conti
5975           j=jcont(jj,i)
5976           do kk=1,num_conti1
5977             j1=jcont(kk,i1)
5978             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5979 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5980 !d   &                   ' ishift=',ishift
5981 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5982 ! The system gains extra energy.
5983               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5984             endif   ! j1==j+-ishift
5985           enddo     ! kk
5986         enddo       ! jj
5987
5988         ENDDO ! ISHIFT
5989
5990       enddo         ! i
5991       return
5992       end subroutine multibody
5993 !-----------------------------------------------------------------------------
5994       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5995 !      implicit real*8 (a-h,o-z)
5996 !      include 'DIMENSIONS'
5997 !      include 'COMMON.IOUNITS'
5998 !      include 'COMMON.DERIV'
5999 !      include 'COMMON.INTERACT'
6000 !      include 'COMMON.CONTACTS'
6001       real(kind=8),dimension(3) :: gx,gx1
6002       logical :: lprn
6003       integer :: i,j,k,l,jj,kk,m,ll
6004       real(kind=8) :: eij,ekl
6005       lprn=.false.
6006       eij=facont(jj,i)
6007       ekl=facont(kk,k)
6008 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6009 ! Calculate the multi-body contribution to energy.
6010 ! Calculate multi-body contributions to the gradient.
6011 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6012 !d   & k,l,(gacont(m,kk,k),m=1,3)
6013       do m=1,3
6014         gx(m) =ekl*gacont(m,jj,i)
6015         gx1(m)=eij*gacont(m,kk,k)
6016         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6017         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6018         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6019         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6020       enddo
6021       do m=i,j-1
6022         do ll=1,3
6023           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6024         enddo
6025       enddo
6026       do m=k,l-1
6027         do ll=1,3
6028           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6029         enddo
6030       enddo
6031       esccorr=-eij*ekl
6032       return
6033       end function esccorr
6034 !-----------------------------------------------------------------------------
6035       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6036 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6037 !      implicit real*8 (a-h,o-z)
6038 !      include 'DIMENSIONS'
6039 !      include 'COMMON.IOUNITS'
6040 #ifdef MPI
6041       include "mpif.h"
6042 !      integer :: maxconts !max_cont=maxconts  =nres/4
6043       integer,parameter :: max_dim=26
6044       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6045       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6046 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6047 !el      common /przechowalnia/ zapas
6048       integer :: status(MPI_STATUS_SIZE)
6049       integer,dimension((nres/4)*2) :: req !maxconts*2
6050       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6051 #endif
6052 !      include 'COMMON.SETUP'
6053 !      include 'COMMON.FFIELD'
6054 !      include 'COMMON.DERIV'
6055 !      include 'COMMON.INTERACT'
6056 !      include 'COMMON.CONTACTS'
6057 !      include 'COMMON.CONTROL'
6058 !      include 'COMMON.LOCAL'
6059       real(kind=8),dimension(3) :: gx,gx1
6060       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6061       logical :: lprn,ldone
6062 !el local variables
6063       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6064               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6065
6066 ! Set lprn=.true. for debugging
6067       lprn=.false.
6068 #ifdef MPI
6069 !      maxconts=nres/4
6070       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6071       n_corr=0
6072       n_corr1=0
6073       if (nfgtasks.le.1) goto 30
6074       if (lprn) then
6075         write (iout,'(a)') 'Contact function values before RECEIVE:'
6076         do i=nnt,nct-2
6077           write (iout,'(2i3,50(1x,i2,f5.2))') &
6078           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6079           j=1,num_cont_hb(i))
6080         enddo
6081       endif
6082       call flush(iout)
6083       do i=1,ntask_cont_from
6084         ncont_recv(i)=0
6085       enddo
6086       do i=1,ntask_cont_to
6087         ncont_sent(i)=0
6088       enddo
6089 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6090 !     & ntask_cont_to
6091 ! Make the list of contacts to send to send to other procesors
6092 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6093 !      call flush(iout)
6094       do i=iturn3_start,iturn3_end
6095 !        write (iout,*) "make contact list turn3",i," num_cont",
6096 !     &    num_cont_hb(i)
6097         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6098       enddo
6099       do i=iturn4_start,iturn4_end
6100 !        write (iout,*) "make contact list turn4",i," num_cont",
6101 !     &   num_cont_hb(i)
6102         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6103       enddo
6104       do ii=1,nat_sent
6105         i=iat_sent(ii)
6106 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6107 !     &    num_cont_hb(i)
6108         do j=1,num_cont_hb(i)
6109         do k=1,4
6110           jjc=jcont_hb(j,i)
6111           iproc=iint_sent_local(k,jjc,ii)
6112 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6113           if (iproc.gt.0) then
6114             ncont_sent(iproc)=ncont_sent(iproc)+1
6115             nn=ncont_sent(iproc)
6116             zapas(1,nn,iproc)=i
6117             zapas(2,nn,iproc)=jjc
6118             zapas(3,nn,iproc)=facont_hb(j,i)
6119             zapas(4,nn,iproc)=ees0p(j,i)
6120             zapas(5,nn,iproc)=ees0m(j,i)
6121             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6122             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6123             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6124             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6125             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6126             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6127             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6128             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6129             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6130             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6131             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6132             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6133             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6134             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6135             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6136             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6137             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6138             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6139             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6140             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6141             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6142           endif
6143         enddo
6144         enddo
6145       enddo
6146       if (lprn) then
6147       write (iout,*) &
6148         "Numbers of contacts to be sent to other processors",&
6149         (ncont_sent(i),i=1,ntask_cont_to)
6150       write (iout,*) "Contacts sent"
6151       do ii=1,ntask_cont_to
6152         nn=ncont_sent(ii)
6153         iproc=itask_cont_to(ii)
6154         write (iout,*) nn," contacts to processor",iproc,&
6155          " of CONT_TO_COMM group"
6156         do i=1,nn
6157           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6158         enddo
6159       enddo
6160       call flush(iout)
6161       endif
6162       CorrelType=477
6163       CorrelID=fg_rank+1
6164       CorrelType1=478
6165       CorrelID1=nfgtasks+fg_rank+1
6166       ireq=0
6167 ! Receive the numbers of needed contacts from other processors
6168       do ii=1,ntask_cont_from
6169         iproc=itask_cont_from(ii)
6170         ireq=ireq+1
6171         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6172           FG_COMM,req(ireq),IERR)
6173       enddo
6174 !      write (iout,*) "IRECV ended"
6175 !      call flush(iout)
6176 ! Send the number of contacts needed by other processors
6177       do ii=1,ntask_cont_to
6178         iproc=itask_cont_to(ii)
6179         ireq=ireq+1
6180         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6181           FG_COMM,req(ireq),IERR)
6182       enddo
6183 !      write (iout,*) "ISEND ended"
6184 !      write (iout,*) "number of requests (nn)",ireq
6185       call flush(iout)
6186       if (ireq.gt.0) &
6187         call MPI_Waitall(ireq,req,status_array,ierr)
6188 !      write (iout,*)
6189 !     &  "Numbers of contacts to be received from other processors",
6190 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6191 !      call flush(iout)
6192 ! Receive contacts
6193       ireq=0
6194       do ii=1,ntask_cont_from
6195         iproc=itask_cont_from(ii)
6196         nn=ncont_recv(ii)
6197 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6198 !     &   " of CONT_TO_COMM group"
6199         call flush(iout)
6200         if (nn.gt.0) then
6201           ireq=ireq+1
6202           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6203           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6204 !          write (iout,*) "ireq,req",ireq,req(ireq)
6205         endif
6206       enddo
6207 ! Send the contacts to processors that need them
6208       do ii=1,ntask_cont_to
6209         iproc=itask_cont_to(ii)
6210         nn=ncont_sent(ii)
6211 !        write (iout,*) nn," contacts to processor",iproc,
6212 !     &   " of CONT_TO_COMM group"
6213         if (nn.gt.0) then
6214           ireq=ireq+1
6215           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6216             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6217 !          write (iout,*) "ireq,req",ireq,req(ireq)
6218 !          do i=1,nn
6219 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6220 !          enddo
6221         endif
6222       enddo
6223 !      write (iout,*) "number of requests (contacts)",ireq
6224 !      write (iout,*) "req",(req(i),i=1,4)
6225 !      call flush(iout)
6226       if (ireq.gt.0) &
6227        call MPI_Waitall(ireq,req,status_array,ierr)
6228       do iii=1,ntask_cont_from
6229         iproc=itask_cont_from(iii)
6230         nn=ncont_recv(iii)
6231         if (lprn) then
6232         write (iout,*) "Received",nn," contacts from processor",iproc,&
6233          " of CONT_FROM_COMM group"
6234         call flush(iout)
6235         do i=1,nn
6236           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6237         enddo
6238         call flush(iout)
6239         endif
6240         do i=1,nn
6241           ii=zapas_recv(1,i,iii)
6242 ! Flag the received contacts to prevent double-counting
6243           jj=-zapas_recv(2,i,iii)
6244 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6245 !          call flush(iout)
6246           nnn=num_cont_hb(ii)+1
6247           num_cont_hb(ii)=nnn
6248           jcont_hb(nnn,ii)=jj
6249           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6250           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6251           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6252           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6253           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6254           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6255           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6256           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6257           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6258           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6259           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6260           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6261           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6262           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6263           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6264           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6265           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6266           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6267           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6268           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6269           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6270           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6271           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6272           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6273         enddo
6274       enddo
6275       call flush(iout)
6276       if (lprn) then
6277         write (iout,'(a)') 'Contact function values after receive:'
6278         do i=nnt,nct-2
6279           write (iout,'(2i3,50(1x,i3,f5.2))') &
6280           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6281           j=1,num_cont_hb(i))
6282         enddo
6283         call flush(iout)
6284       endif
6285    30 continue
6286 #endif
6287       if (lprn) then
6288         write (iout,'(a)') 'Contact function values:'
6289         do i=nnt,nct-2
6290           write (iout,'(2i3,50(1x,i3,f5.2))') &
6291           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6292           j=1,num_cont_hb(i))
6293         enddo
6294       endif
6295       ecorr=0.0D0
6296
6297 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6298 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6299 ! Remove the loop below after debugging !!!
6300       do i=nnt,nct
6301         do j=1,3
6302           gradcorr(j,i)=0.0D0
6303           gradxorr(j,i)=0.0D0
6304         enddo
6305       enddo
6306 ! Calculate the local-electrostatic correlation terms
6307       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6308         i1=i+1
6309         num_conti=num_cont_hb(i)
6310         num_conti1=num_cont_hb(i+1)
6311         do jj=1,num_conti
6312           j=jcont_hb(jj,i)
6313           jp=iabs(j)
6314           do kk=1,num_conti1
6315             j1=jcont_hb(kk,i1)
6316             jp1=iabs(j1)
6317 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6318 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6319             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6320                 .or. j.lt.0 .and. j1.gt.0) .and. &
6321                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6322 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6323 ! The system gains extra energy.
6324               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6325               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6326                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6327               n_corr=n_corr+1
6328             else if (j1.eq.j) then
6329 ! Contacts I-J and I-(J+1) occur simultaneously.
6330 ! The system loses extra energy.
6331 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6332             endif
6333           enddo ! kk
6334           do kk=1,num_conti
6335             j1=jcont_hb(kk,i)
6336 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6337 !    &         ' jj=',jj,' kk=',kk
6338             if (j1.eq.j+1) then
6339 ! Contacts I-J and (I+1)-J occur simultaneously.
6340 ! The system loses extra energy.
6341 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6342             endif ! j1==j+1
6343           enddo ! kk
6344         enddo ! jj
6345       enddo ! i
6346       return
6347       end subroutine multibody_hb
6348 !-----------------------------------------------------------------------------
6349       subroutine add_hb_contact(ii,jj,itask)
6350 !      implicit real*8 (a-h,o-z)
6351 !      include "DIMENSIONS"
6352 !      include "COMMON.IOUNITS"
6353 !      include "COMMON.CONTACTS"
6354 !      integer,parameter :: maxconts=nres/4
6355       integer,parameter :: max_dim=26
6356       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6357 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6358 !      common /przechowalnia/ zapas
6359       integer :: i,j,ii,jj,iproc,nn,jjc
6360       integer,dimension(4) :: itask
6361 !      write (iout,*) "itask",itask
6362       do i=1,2
6363         iproc=itask(i)
6364         if (iproc.gt.0) then
6365           do j=1,num_cont_hb(ii)
6366             jjc=jcont_hb(j,ii)
6367 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6368             if (jjc.eq.jj) then
6369               ncont_sent(iproc)=ncont_sent(iproc)+1
6370               nn=ncont_sent(iproc)
6371               zapas(1,nn,iproc)=ii
6372               zapas(2,nn,iproc)=jjc
6373               zapas(3,nn,iproc)=facont_hb(j,ii)
6374               zapas(4,nn,iproc)=ees0p(j,ii)
6375               zapas(5,nn,iproc)=ees0m(j,ii)
6376               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6377               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6378               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6379               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6380               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6381               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6382               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6383               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6384               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6385               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6386               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6387               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6388               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6389               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6390               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6391               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6392               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6393               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6394               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6395               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6396               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6397               exit
6398             endif
6399           enddo
6400         endif
6401       enddo
6402       return
6403       end subroutine add_hb_contact
6404 !-----------------------------------------------------------------------------
6405       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6406 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6407 !      implicit real*8 (a-h,o-z)
6408 !      include 'DIMENSIONS'
6409 !      include 'COMMON.IOUNITS'
6410       integer,parameter :: max_dim=70
6411 #ifdef MPI
6412       include "mpif.h"
6413 !      integer :: maxconts !max_cont=maxconts=nres/4
6414       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6415       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6416 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6417 !      common /przechowalnia/ zapas
6418       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6419         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6420         ierr,iii,nnn
6421 #endif
6422 !      include 'COMMON.SETUP'
6423 !      include 'COMMON.FFIELD'
6424 !      include 'COMMON.DERIV'
6425 !      include 'COMMON.LOCAL'
6426 !      include 'COMMON.INTERACT'
6427 !      include 'COMMON.CONTACTS'
6428 !      include 'COMMON.CHAIN'
6429 !      include 'COMMON.CONTROL'
6430       real(kind=8),dimension(3) :: gx,gx1
6431       integer,dimension(nres) :: num_cont_hb_old
6432       logical :: lprn,ldone
6433 !EL      double precision eello4,eello5,eelo6,eello_turn6
6434 !EL      external eello4,eello5,eello6,eello_turn6
6435 !el local variables
6436       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6437               j1,jp1,i1,num_conti1
6438       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6439       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6440
6441 ! Set lprn=.true. for debugging
6442       lprn=.false.
6443       eturn6=0.0d0
6444 #ifdef MPI
6445 !      maxconts=nres/4
6446       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6447       do i=1,nres
6448         num_cont_hb_old(i)=num_cont_hb(i)
6449       enddo
6450       n_corr=0
6451       n_corr1=0
6452       if (nfgtasks.le.1) goto 30
6453       if (lprn) then
6454         write (iout,'(a)') 'Contact function values before RECEIVE:'
6455         do i=nnt,nct-2
6456           write (iout,'(2i3,50(1x,i2,f5.2))') &
6457           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6458           j=1,num_cont_hb(i))
6459         enddo
6460       endif
6461       call flush(iout)
6462       do i=1,ntask_cont_from
6463         ncont_recv(i)=0
6464       enddo
6465       do i=1,ntask_cont_to
6466         ncont_sent(i)=0
6467       enddo
6468 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6469 !     & ntask_cont_to
6470 ! Make the list of contacts to send to send to other procesors
6471       do i=iturn3_start,iturn3_end
6472 !        write (iout,*) "make contact list turn3",i," num_cont",
6473 !     &    num_cont_hb(i)
6474         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6475       enddo
6476       do i=iturn4_start,iturn4_end
6477 !        write (iout,*) "make contact list turn4",i," num_cont",
6478 !     &   num_cont_hb(i)
6479         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6480       enddo
6481       do ii=1,nat_sent
6482         i=iat_sent(ii)
6483 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6484 !     &    num_cont_hb(i)
6485         do j=1,num_cont_hb(i)
6486         do k=1,4
6487           jjc=jcont_hb(j,i)
6488           iproc=iint_sent_local(k,jjc,ii)
6489 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6490           if (iproc.ne.0) then
6491             ncont_sent(iproc)=ncont_sent(iproc)+1
6492             nn=ncont_sent(iproc)
6493             zapas(1,nn,iproc)=i
6494             zapas(2,nn,iproc)=jjc
6495             zapas(3,nn,iproc)=d_cont(j,i)
6496             ind=3
6497             do kk=1,3
6498               ind=ind+1
6499               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6500             enddo
6501             do kk=1,2
6502               do ll=1,2
6503                 ind=ind+1
6504                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6505               enddo
6506             enddo
6507             do jj=1,5
6508               do kk=1,3
6509                 do ll=1,2
6510                   do mm=1,2
6511                     ind=ind+1
6512                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6513                   enddo
6514                 enddo
6515               enddo
6516             enddo
6517           endif
6518         enddo
6519         enddo
6520       enddo
6521       if (lprn) then
6522       write (iout,*) &
6523         "Numbers of contacts to be sent to other processors",&
6524         (ncont_sent(i),i=1,ntask_cont_to)
6525       write (iout,*) "Contacts sent"
6526       do ii=1,ntask_cont_to
6527         nn=ncont_sent(ii)
6528         iproc=itask_cont_to(ii)
6529         write (iout,*) nn," contacts to processor",iproc,&
6530          " of CONT_TO_COMM group"
6531         do i=1,nn
6532           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6533         enddo
6534       enddo
6535       call flush(iout)
6536       endif
6537       CorrelType=477
6538       CorrelID=fg_rank+1
6539       CorrelType1=478
6540       CorrelID1=nfgtasks+fg_rank+1
6541       ireq=0
6542 ! Receive the numbers of needed contacts from other processors
6543       do ii=1,ntask_cont_from
6544         iproc=itask_cont_from(ii)
6545         ireq=ireq+1
6546         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6547           FG_COMM,req(ireq),IERR)
6548       enddo
6549 !      write (iout,*) "IRECV ended"
6550 !      call flush(iout)
6551 ! Send the number of contacts needed by other processors
6552       do ii=1,ntask_cont_to
6553         iproc=itask_cont_to(ii)
6554         ireq=ireq+1
6555         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6556           FG_COMM,req(ireq),IERR)
6557       enddo
6558 !      write (iout,*) "ISEND ended"
6559 !      write (iout,*) "number of requests (nn)",ireq
6560       call flush(iout)
6561       if (ireq.gt.0) &
6562         call MPI_Waitall(ireq,req,status_array,ierr)
6563 !      write (iout,*)
6564 !     &  "Numbers of contacts to be received from other processors",
6565 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6566 !      call flush(iout)
6567 ! Receive contacts
6568       ireq=0
6569       do ii=1,ntask_cont_from
6570         iproc=itask_cont_from(ii)
6571         nn=ncont_recv(ii)
6572 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6573 !     &   " of CONT_TO_COMM group"
6574         call flush(iout)
6575         if (nn.gt.0) then
6576           ireq=ireq+1
6577           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6578           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6579 !          write (iout,*) "ireq,req",ireq,req(ireq)
6580         endif
6581       enddo
6582 ! Send the contacts to processors that need them
6583       do ii=1,ntask_cont_to
6584         iproc=itask_cont_to(ii)
6585         nn=ncont_sent(ii)
6586 !        write (iout,*) nn," contacts to processor",iproc,
6587 !     &   " of CONT_TO_COMM group"
6588         if (nn.gt.0) then
6589           ireq=ireq+1
6590           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6591             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6592 !          write (iout,*) "ireq,req",ireq,req(ireq)
6593 !          do i=1,nn
6594 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6595 !          enddo
6596         endif
6597       enddo
6598 !      write (iout,*) "number of requests (contacts)",ireq
6599 !      write (iout,*) "req",(req(i),i=1,4)
6600 !      call flush(iout)
6601       if (ireq.gt.0) &
6602        call MPI_Waitall(ireq,req,status_array,ierr)
6603       do iii=1,ntask_cont_from
6604         iproc=itask_cont_from(iii)
6605         nn=ncont_recv(iii)
6606         if (lprn) then
6607         write (iout,*) "Received",nn," contacts from processor",iproc,&
6608          " of CONT_FROM_COMM group"
6609         call flush(iout)
6610         do i=1,nn
6611           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6612         enddo
6613         call flush(iout)
6614         endif
6615         do i=1,nn
6616           ii=zapas_recv(1,i,iii)
6617 ! Flag the received contacts to prevent double-counting
6618           jj=-zapas_recv(2,i,iii)
6619 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6620 !          call flush(iout)
6621           nnn=num_cont_hb(ii)+1
6622           num_cont_hb(ii)=nnn
6623           jcont_hb(nnn,ii)=jj
6624           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6625           ind=3
6626           do kk=1,3
6627             ind=ind+1
6628             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6629           enddo
6630           do kk=1,2
6631             do ll=1,2
6632               ind=ind+1
6633               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6634             enddo
6635           enddo
6636           do jj=1,5
6637             do kk=1,3
6638               do ll=1,2
6639                 do mm=1,2
6640                   ind=ind+1
6641                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6642                 enddo
6643               enddo
6644             enddo
6645           enddo
6646         enddo
6647       enddo
6648       call flush(iout)
6649       if (lprn) then
6650         write (iout,'(a)') 'Contact function values after receive:'
6651         do i=nnt,nct-2
6652           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6653           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6654           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6655         enddo
6656         call flush(iout)
6657       endif
6658    30 continue
6659 #endif
6660       if (lprn) then
6661         write (iout,'(a)') 'Contact function values:'
6662         do i=nnt,nct-2
6663           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6664           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6665           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6666         enddo
6667       endif
6668       ecorr=0.0D0
6669       ecorr5=0.0d0
6670       ecorr6=0.0d0
6671
6672 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6673 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6674 ! Remove the loop below after debugging !!!
6675       do i=nnt,nct
6676         do j=1,3
6677           gradcorr(j,i)=0.0D0
6678           gradxorr(j,i)=0.0D0
6679         enddo
6680       enddo
6681 ! Calculate the dipole-dipole interaction energies
6682       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6683       do i=iatel_s,iatel_e+1
6684         num_conti=num_cont_hb(i)
6685         do jj=1,num_conti
6686           j=jcont_hb(jj,i)
6687 #ifdef MOMENT
6688           call dipole(i,j,jj)
6689 #endif
6690         enddo
6691       enddo
6692       endif
6693 ! Calculate the local-electrostatic correlation terms
6694 !                write (iout,*) "gradcorr5 in eello5 before loop"
6695 !                do iii=1,nres
6696 !                  write (iout,'(i5,3f10.5)')
6697 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6698 !                enddo
6699       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6700 !        write (iout,*) "corr loop i",i
6701         i1=i+1
6702         num_conti=num_cont_hb(i)
6703         num_conti1=num_cont_hb(i+1)
6704         do jj=1,num_conti
6705           j=jcont_hb(jj,i)
6706           jp=iabs(j)
6707           do kk=1,num_conti1
6708             j1=jcont_hb(kk,i1)
6709             jp1=iabs(j1)
6710 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6711 !     &         ' jj=',jj,' kk=',kk
6712 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6713             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6714                 .or. j.lt.0 .and. j1.gt.0) .and. &
6715                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6716 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6717 ! The system gains extra energy.
6718               n_corr=n_corr+1
6719               sqd1=dsqrt(d_cont(jj,i))
6720               sqd2=dsqrt(d_cont(kk,i1))
6721               sred_geom = sqd1*sqd2
6722               IF (sred_geom.lt.cutoff_corr) THEN
6723                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6724                   ekont,fprimcont)
6725 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6726 !d     &         ' jj=',jj,' kk=',kk
6727                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6728                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6729                 do l=1,3
6730                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6731                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6732                 enddo
6733                 n_corr1=n_corr1+1
6734 !d               write (iout,*) 'sred_geom=',sred_geom,
6735 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6736 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6737 !d               write (iout,*) "g_contij",g_contij
6738 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6739 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6740                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6741                 if (wcorr4.gt.0.0d0) &
6742                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6743                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6744                        write (iout,'(a6,4i5,0pf7.3)') &
6745                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6746 !                write (iout,*) "gradcorr5 before eello5"
6747 !                do iii=1,nres
6748 !                  write (iout,'(i5,3f10.5)')
6749 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6750 !                enddo
6751                 if (wcorr5.gt.0.0d0) &
6752                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6753 !                write (iout,*) "gradcorr5 after eello5"
6754 !                do iii=1,nres
6755 !                  write (iout,'(i5,3f10.5)')
6756 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6757 !                enddo
6758                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6759                        write (iout,'(a6,4i5,0pf7.3)') &
6760                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6761 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6762 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6763                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6764                      .or. wturn6.eq.0.0d0))then
6765 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6766                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6767                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6768                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6769 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6770 !d     &            'ecorr6=',ecorr6
6771 !d                write (iout,'(4e15.5)') sred_geom,
6772 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6773 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6774 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6775                 else if (wturn6.gt.0.0d0 &
6776                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6777 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6778                   eturn6=eturn6+eello_turn6(i,jj,kk)
6779                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6780                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6781 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6782                 endif
6783               ENDIF
6784 1111          continue
6785             endif
6786           enddo ! kk
6787         enddo ! jj
6788       enddo ! i
6789       do i=1,nres
6790         num_cont_hb(i)=num_cont_hb_old(i)
6791       enddo
6792 !                write (iout,*) "gradcorr5 in eello5"
6793 !                do iii=1,nres
6794 !                  write (iout,'(i5,3f10.5)')
6795 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6796 !                enddo
6797       return
6798       end subroutine multibody_eello
6799 !-----------------------------------------------------------------------------
6800       subroutine add_hb_contact_eello(ii,jj,itask)
6801 !      implicit real*8 (a-h,o-z)
6802 !      include "DIMENSIONS"
6803 !      include "COMMON.IOUNITS"
6804 !      include "COMMON.CONTACTS"
6805 !      integer,parameter :: maxconts=nres/4
6806       integer,parameter :: max_dim=70
6807       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6808 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6809 !      common /przechowalnia/ zapas
6810
6811       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6812       integer,dimension(4) ::itask
6813 !      write (iout,*) "itask",itask
6814       do i=1,2
6815         iproc=itask(i)
6816         if (iproc.gt.0) then
6817           do j=1,num_cont_hb(ii)
6818             jjc=jcont_hb(j,ii)
6819 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6820             if (jjc.eq.jj) then
6821               ncont_sent(iproc)=ncont_sent(iproc)+1
6822               nn=ncont_sent(iproc)
6823               zapas(1,nn,iproc)=ii
6824               zapas(2,nn,iproc)=jjc
6825               zapas(3,nn,iproc)=d_cont(j,ii)
6826               ind=3
6827               do kk=1,3
6828                 ind=ind+1
6829                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6830               enddo
6831               do kk=1,2
6832                 do ll=1,2
6833                   ind=ind+1
6834                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6835                 enddo
6836               enddo
6837               do jj=1,5
6838                 do kk=1,3
6839                   do ll=1,2
6840                     do mm=1,2
6841                       ind=ind+1
6842                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6843                     enddo
6844                   enddo
6845                 enddo
6846               enddo
6847               exit
6848             endif
6849           enddo
6850         endif
6851       enddo
6852       return
6853       end subroutine add_hb_contact_eello
6854 !-----------------------------------------------------------------------------
6855       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6856 !      implicit real*8 (a-h,o-z)
6857 !      include 'DIMENSIONS'
6858 !      include 'COMMON.IOUNITS'
6859 !      include 'COMMON.DERIV'
6860 !      include 'COMMON.INTERACT'
6861 !      include 'COMMON.CONTACTS'
6862       real(kind=8),dimension(3) :: gx,gx1
6863       logical :: lprn
6864 !el local variables
6865       integer :: i,j,k,l,jj,kk,ll
6866       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6867                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6868                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6869
6870       lprn=.false.
6871       eij=facont_hb(jj,i)
6872       ekl=facont_hb(kk,k)
6873       ees0pij=ees0p(jj,i)
6874       ees0pkl=ees0p(kk,k)
6875       ees0mij=ees0m(jj,i)
6876       ees0mkl=ees0m(kk,k)
6877       ekont=eij*ekl
6878       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6879 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6880 ! Following 4 lines for diagnostics.
6881 !d    ees0pkl=0.0D0
6882 !d    ees0pij=1.0D0
6883 !d    ees0mkl=0.0D0
6884 !d    ees0mij=1.0D0
6885 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6886 !     & 'Contacts ',i,j,
6887 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6888 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6889 !     & 'gradcorr_long'
6890 ! Calculate the multi-body contribution to energy.
6891 !      ecorr=ecorr+ekont*ees
6892 ! Calculate multi-body contributions to the gradient.
6893       coeffpees0pij=coeffp*ees0pij
6894       coeffmees0mij=coeffm*ees0mij
6895       coeffpees0pkl=coeffp*ees0pkl
6896       coeffmees0mkl=coeffm*ees0mkl
6897       do ll=1,3
6898 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6899         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6900         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6901         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6902         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6903         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6904         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6905 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6906         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6907         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6908         coeffmees0mij*gacontm_hb1(ll,kk,k))
6909         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6910         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6911         coeffmees0mij*gacontm_hb2(ll,kk,k))
6912         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6913            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6914            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6915         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6916         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6917         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6918            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6919            coeffmees0mij*gacontm_hb3(ll,kk,k))
6920         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6921         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6922 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6923       enddo
6924 !      write (iout,*)
6925 !grad      do m=i+1,j-1
6926 !grad        do ll=1,3
6927 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6928 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6929 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6930 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6931 !grad        enddo
6932 !grad      enddo
6933 !grad      do m=k+1,l-1
6934 !grad        do ll=1,3
6935 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6936 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6937 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6938 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6939 !grad        enddo
6940 !grad      enddo
6941 !      write (iout,*) "ehbcorr",ekont*ees
6942       ehbcorr=ekont*ees
6943       return
6944       end function ehbcorr
6945 #ifdef MOMENT
6946 !-----------------------------------------------------------------------------
6947       subroutine dipole(i,j,jj)
6948 !      implicit real*8 (a-h,o-z)
6949 !      include 'DIMENSIONS'
6950 !      include 'COMMON.IOUNITS'
6951 !      include 'COMMON.CHAIN'
6952 !      include 'COMMON.FFIELD'
6953 !      include 'COMMON.DERIV'
6954 !      include 'COMMON.INTERACT'
6955 !      include 'COMMON.CONTACTS'
6956 !      include 'COMMON.TORSION'
6957 !      include 'COMMON.VAR'
6958 !      include 'COMMON.GEO'
6959       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6960       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6961       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6962
6963       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6964       allocate(dipderx(3,5,4,maxconts,nres))
6965 !
6966
6967       iti1 = itortyp(itype(i+1))
6968       if (j.lt.nres-1) then
6969         itj1 = itortyp(itype(j+1))
6970       else
6971         itj1=ntortyp+1
6972       endif
6973       do iii=1,2
6974         dipi(iii,1)=Ub2(iii,i)
6975         dipderi(iii)=Ub2der(iii,i)
6976         dipi(iii,2)=b1(iii,iti1)
6977         dipj(iii,1)=Ub2(iii,j)
6978         dipderj(iii)=Ub2der(iii,j)
6979         dipj(iii,2)=b1(iii,itj1)
6980       enddo
6981       kkk=0
6982       do iii=1,2
6983         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6984         do jjj=1,2
6985           kkk=kkk+1
6986           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6987         enddo
6988       enddo
6989       do kkk=1,5
6990         do lll=1,3
6991           mmm=0
6992           do iii=1,2
6993             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6994               auxvec(1))
6995             do jjj=1,2
6996               mmm=mmm+1
6997               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6998             enddo
6999           enddo
7000         enddo
7001       enddo
7002       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7003       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7004       do iii=1,2
7005         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7006       enddo
7007       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7008       do iii=1,2
7009         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7010       enddo
7011       return
7012       end subroutine dipole
7013 #endif
7014 !-----------------------------------------------------------------------------
7015       subroutine calc_eello(i,j,k,l,jj,kk)
7016 !
7017 ! This subroutine computes matrices and vectors needed to calculate
7018 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7019 !
7020       use comm_kut
7021 !      implicit real*8 (a-h,o-z)
7022 !      include 'DIMENSIONS'
7023 !      include 'COMMON.IOUNITS'
7024 !      include 'COMMON.CHAIN'
7025 !      include 'COMMON.DERIV'
7026 !      include 'COMMON.INTERACT'
7027 !      include 'COMMON.CONTACTS'
7028 !      include 'COMMON.TORSION'
7029 !      include 'COMMON.VAR'
7030 !      include 'COMMON.GEO'
7031 !      include 'COMMON.FFIELD'
7032       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7033       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7034       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7035               itj1
7036 !el      logical :: lprn
7037 !el      common /kutas/ lprn
7038 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7039 !d     & ' jj=',jj,' kk=',kk
7040 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7041 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7042 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7043       do iii=1,2
7044         do jjj=1,2
7045           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7046           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7047         enddo
7048       enddo
7049       call transpose2(aa1(1,1),aa1t(1,1))
7050       call transpose2(aa2(1,1),aa2t(1,1))
7051       do kkk=1,5
7052         do lll=1,3
7053           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7054             aa1tder(1,1,lll,kkk))
7055           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7056             aa2tder(1,1,lll,kkk))
7057         enddo
7058       enddo
7059       if (l.eq.j+1) then
7060 ! parallel orientation of the two CA-CA-CA frames.
7061         if (i.gt.1) then
7062           iti=itortyp(itype(i))
7063         else
7064           iti=ntortyp+1
7065         endif
7066         itk1=itortyp(itype(k+1))
7067         itj=itortyp(itype(j))
7068         if (l.lt.nres-1) then
7069           itl1=itortyp(itype(l+1))
7070         else
7071           itl1=ntortyp+1
7072         endif
7073 ! A1 kernel(j+1) A2T
7074 !d        do iii=1,2
7075 !d          write (iout,'(3f10.5,5x,3f10.5)')
7076 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7077 !d        enddo
7078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7079          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7080          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7081 ! Following matrices are needed only for 6-th order cumulants
7082         IF (wcorr6.gt.0.0d0) THEN
7083         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7084          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7085          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7086         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7087          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7088          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7089          ADtEAderx(1,1,1,1,1,1))
7090         lprn=.false.
7091         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7092          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7093          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7094          ADtEA1derx(1,1,1,1,1,1))
7095         ENDIF
7096 ! End 6-th order cumulants
7097 !d        lprn=.false.
7098 !d        if (lprn) then
7099 !d        write (2,*) 'In calc_eello6'
7100 !d        do iii=1,2
7101 !d          write (2,*) 'iii=',iii
7102 !d          do kkk=1,5
7103 !d            write (2,*) 'kkk=',kkk
7104 !d            do jjj=1,2
7105 !d              write (2,'(3(2f10.5),5x)')
7106 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7107 !d            enddo
7108 !d          enddo
7109 !d        enddo
7110 !d        endif
7111         call transpose2(EUgder(1,1,k),auxmat(1,1))
7112         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7113         call transpose2(EUg(1,1,k),auxmat(1,1))
7114         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7115         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7116         do iii=1,2
7117           do kkk=1,5
7118             do lll=1,3
7119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7120                 EAEAderx(1,1,lll,kkk,iii,1))
7121             enddo
7122           enddo
7123         enddo
7124 ! A1T kernel(i+1) A2
7125         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7126          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7127          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7128 ! Following matrices are needed only for 6-th order cumulants
7129         IF (wcorr6.gt.0.0d0) THEN
7130         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7131          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7132          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7133         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7134          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7135          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7136          ADtEAderx(1,1,1,1,1,2))
7137         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7138          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7139          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7140          ADtEA1derx(1,1,1,1,1,2))
7141         ENDIF
7142 ! End 6-th order cumulants
7143         call transpose2(EUgder(1,1,l),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7145         call transpose2(EUg(1,1,l),auxmat(1,1))
7146         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7147         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7148         do iii=1,2
7149           do kkk=1,5
7150             do lll=1,3
7151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7152                 EAEAderx(1,1,lll,kkk,iii,2))
7153             enddo
7154           enddo
7155         enddo
7156 ! AEAb1 and AEAb2
7157 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7158 ! They are needed only when the fifth- or the sixth-order cumulants are
7159 ! indluded.
7160         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7161         call transpose2(AEA(1,1,1),auxmat(1,1))
7162         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7163         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7164         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7165         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7166         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7168         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7169         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7170         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7171         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7172         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7173         call transpose2(AEA(1,1,2),auxmat(1,1))
7174         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7175         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7176         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7177         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7178         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7179         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7180         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7181         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7182         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7183         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7184         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7185 ! Calculate the Cartesian derivatives of the vectors.
7186         do iii=1,2
7187           do kkk=1,5
7188             do lll=1,3
7189               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7190               call matvec2(auxmat(1,1),b1(1,iti),&
7191                 AEAb1derx(1,lll,kkk,iii,1,1))
7192               call matvec2(auxmat(1,1),Ub2(1,i),&
7193                 AEAb2derx(1,lll,kkk,iii,1,1))
7194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7195                 AEAb1derx(1,lll,kkk,iii,2,1))
7196               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7197                 AEAb2derx(1,lll,kkk,iii,2,1))
7198               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7199               call matvec2(auxmat(1,1),b1(1,itj),&
7200                 AEAb1derx(1,lll,kkk,iii,1,2))
7201               call matvec2(auxmat(1,1),Ub2(1,j),&
7202                 AEAb2derx(1,lll,kkk,iii,1,2))
7203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7204                 AEAb1derx(1,lll,kkk,iii,2,2))
7205               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7206                 AEAb2derx(1,lll,kkk,iii,2,2))
7207             enddo
7208           enddo
7209         enddo
7210         ENDIF
7211 ! End vectors
7212       else
7213 ! Antiparallel orientation of the two CA-CA-CA frames.
7214         if (i.gt.1) then
7215           iti=itortyp(itype(i))
7216         else
7217           iti=ntortyp+1
7218         endif
7219         itk1=itortyp(itype(k+1))
7220         itl=itortyp(itype(l))
7221         itj=itortyp(itype(j))
7222         if (j.lt.nres-1) then
7223           itj1=itortyp(itype(j+1))
7224         else
7225           itj1=ntortyp+1
7226         endif
7227 ! A2 kernel(j-1)T A1T
7228         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7229          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7230          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7231 ! Following matrices are needed only for 6-th order cumulants
7232         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7233            j.eq.i+4 .and. l.eq.i+3)) THEN
7234         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7235          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7236          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7237         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7238          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7239          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7240          ADtEAderx(1,1,1,1,1,1))
7241         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7242          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7243          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7244          ADtEA1derx(1,1,1,1,1,1))
7245         ENDIF
7246 ! End 6-th order cumulants
7247         call transpose2(EUgder(1,1,k),auxmat(1,1))
7248         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7249         call transpose2(EUg(1,1,k),auxmat(1,1))
7250         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7251         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7252         do iii=1,2
7253           do kkk=1,5
7254             do lll=1,3
7255               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7256                 EAEAderx(1,1,lll,kkk,iii,1))
7257             enddo
7258           enddo
7259         enddo
7260 ! A2T kernel(i+1)T A1
7261         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7262          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7263          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7264 ! Following matrices are needed only for 6-th order cumulants
7265         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7266            j.eq.i+4 .and. l.eq.i+3)) THEN
7267         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7268          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7269          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7270         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7271          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7272          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7273          ADtEAderx(1,1,1,1,1,2))
7274         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7275          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7276          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7277          ADtEA1derx(1,1,1,1,1,2))
7278         ENDIF
7279 ! End 6-th order cumulants
7280         call transpose2(EUgder(1,1,j),auxmat(1,1))
7281         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7282         call transpose2(EUg(1,1,j),auxmat(1,1))
7283         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7284         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7285         do iii=1,2
7286           do kkk=1,5
7287             do lll=1,3
7288               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7289                 EAEAderx(1,1,lll,kkk,iii,2))
7290             enddo
7291           enddo
7292         enddo
7293 ! AEAb1 and AEAb2
7294 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7295 ! They are needed only when the fifth- or the sixth-order cumulants are
7296 ! indluded.
7297         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7298           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7299         call transpose2(AEA(1,1,1),auxmat(1,1))
7300         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7301         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7302         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7303         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7304         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7305         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7306         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7307         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7308         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7309         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7310         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7311         call transpose2(AEA(1,1,2),auxmat(1,1))
7312         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7313         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7314         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7315         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7316         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7317         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7318         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7319         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7320         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7321         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7322         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7323 ! Calculate the Cartesian derivatives of the vectors.
7324         do iii=1,2
7325           do kkk=1,5
7326             do lll=1,3
7327               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7328               call matvec2(auxmat(1,1),b1(1,iti),&
7329                 AEAb1derx(1,lll,kkk,iii,1,1))
7330               call matvec2(auxmat(1,1),Ub2(1,i),&
7331                 AEAb2derx(1,lll,kkk,iii,1,1))
7332               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7333                 AEAb1derx(1,lll,kkk,iii,2,1))
7334               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7335                 AEAb2derx(1,lll,kkk,iii,2,1))
7336               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7337               call matvec2(auxmat(1,1),b1(1,itl),&
7338                 AEAb1derx(1,lll,kkk,iii,1,2))
7339               call matvec2(auxmat(1,1),Ub2(1,l),&
7340                 AEAb2derx(1,lll,kkk,iii,1,2))
7341               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7342                 AEAb1derx(1,lll,kkk,iii,2,2))
7343               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7344                 AEAb2derx(1,lll,kkk,iii,2,2))
7345             enddo
7346           enddo
7347         enddo
7348         ENDIF
7349 ! End vectors
7350       endif
7351       return
7352       end subroutine calc_eello
7353 !-----------------------------------------------------------------------------
7354       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7355       use comm_kut
7356       implicit none
7357       integer :: nderg
7358       logical :: transp
7359       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7360       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7361       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7362       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7363       integer :: iii,kkk,lll
7364       integer :: jjj,mmm
7365 !el      logical :: lprn
7366 !el      common /kutas/ lprn
7367       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7368       do iii=1,nderg
7369         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7370           AKAderg(1,1,iii))
7371       enddo
7372 !d      if (lprn) write (2,*) 'In kernel'
7373       do kkk=1,5
7374 !d        if (lprn) write (2,*) 'kkk=',kkk
7375         do lll=1,3
7376           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7377             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7378 !d          if (lprn) then
7379 !d            write (2,*) 'lll=',lll
7380 !d            write (2,*) 'iii=1'
7381 !d            do jjj=1,2
7382 !d              write (2,'(3(2f10.5),5x)')
7383 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7384 !d            enddo
7385 !d          endif
7386           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7387             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7388 !d          if (lprn) then
7389 !d            write (2,*) 'lll=',lll
7390 !d            write (2,*) 'iii=2'
7391 !d            do jjj=1,2
7392 !d              write (2,'(3(2f10.5),5x)')
7393 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7394 !d            enddo
7395 !d          endif
7396         enddo
7397       enddo
7398       return
7399       end subroutine kernel
7400 !-----------------------------------------------------------------------------
7401       real(kind=8) function eello4(i,j,k,l,jj,kk)
7402 !      implicit real*8 (a-h,o-z)
7403 !      include 'DIMENSIONS'
7404 !      include 'COMMON.IOUNITS'
7405 !      include 'COMMON.CHAIN'
7406 !      include 'COMMON.DERIV'
7407 !      include 'COMMON.INTERACT'
7408 !      include 'COMMON.CONTACTS'
7409 !      include 'COMMON.TORSION'
7410 !      include 'COMMON.VAR'
7411 !      include 'COMMON.GEO'
7412       real(kind=8),dimension(2,2) :: pizda
7413       real(kind=8),dimension(3) :: ggg1,ggg2
7414       real(kind=8) ::  eel4,glongij,glongkl
7415       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7416 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7417 !d        eello4=0.0d0
7418 !d        return
7419 !d      endif
7420 !d      print *,'eello4:',i,j,k,l,jj,kk
7421 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7422 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7423 !old      eij=facont_hb(jj,i)
7424 !old      ekl=facont_hb(kk,k)
7425 !old      ekont=eij*ekl
7426       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7427 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7428       gcorr_loc(k-1)=gcorr_loc(k-1) &
7429          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7430       if (l.eq.j+1) then
7431         gcorr_loc(l-1)=gcorr_loc(l-1) &
7432            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7433       else
7434         gcorr_loc(j-1)=gcorr_loc(j-1) &
7435            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7436       endif
7437       do iii=1,2
7438         do kkk=1,5
7439           do lll=1,3
7440             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7441                               -EAEAderx(2,2,lll,kkk,iii,1)
7442 !d            derx(lll,kkk,iii)=0.0d0
7443           enddo
7444         enddo
7445       enddo
7446 !d      gcorr_loc(l-1)=0.0d0
7447 !d      gcorr_loc(j-1)=0.0d0
7448 !d      gcorr_loc(k-1)=0.0d0
7449 !d      eel4=1.0d0
7450 !d      write (iout,*)'Contacts have occurred for peptide groups',
7451 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7452 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7453       if (j.lt.nres-1) then
7454         j1=j+1
7455         j2=j-1
7456       else
7457         j1=j-1
7458         j2=j-2
7459       endif
7460       if (l.lt.nres-1) then
7461         l1=l+1
7462         l2=l-1
7463       else
7464         l1=l-1
7465         l2=l-2
7466       endif
7467       do ll=1,3
7468 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7469 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7470         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7471         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7472 !grad        ghalf=0.5d0*ggg1(ll)
7473         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7474         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7475         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7476         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7477         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7478         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7479 !grad        ghalf=0.5d0*ggg2(ll)
7480         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7481         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7482         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7483         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7484         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7485         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7486       enddo
7487 !grad      do m=i+1,j-1
7488 !grad        do ll=1,3
7489 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7490 !grad        enddo
7491 !grad      enddo
7492 !grad      do m=k+1,l-1
7493 !grad        do ll=1,3
7494 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7495 !grad        enddo
7496 !grad      enddo
7497 !grad      do m=i+2,j2
7498 !grad        do ll=1,3
7499 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7500 !grad        enddo
7501 !grad      enddo
7502 !grad      do m=k+2,l2
7503 !grad        do ll=1,3
7504 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7505 !grad        enddo
7506 !grad      enddo
7507 !d      do iii=1,nres-3
7508 !d        write (2,*) iii,gcorr_loc(iii)
7509 !d      enddo
7510       eello4=ekont*eel4
7511 !d      write (2,*) 'ekont',ekont
7512 !d      write (iout,*) 'eello4',ekont*eel4
7513       return
7514       end function eello4
7515 !-----------------------------------------------------------------------------
7516       real(kind=8) function eello5(i,j,k,l,jj,kk)
7517 !      implicit real*8 (a-h,o-z)
7518 !      include 'DIMENSIONS'
7519 !      include 'COMMON.IOUNITS'
7520 !      include 'COMMON.CHAIN'
7521 !      include 'COMMON.DERIV'
7522 !      include 'COMMON.INTERACT'
7523 !      include 'COMMON.CONTACTS'
7524 !      include 'COMMON.TORSION'
7525 !      include 'COMMON.VAR'
7526 !      include 'COMMON.GEO'
7527       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7528       real(kind=8),dimension(2) :: vv
7529       real(kind=8),dimension(3) :: ggg1,ggg2
7530       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7531       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7532       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7533 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7534 !                                                                              C
7535 !                            Parallel chains                                   C
7536 !                                                                              C
7537 !          o             o                   o             o                   C
7538 !         /l\           / \             \   / \           / \   /              C
7539 !        /   \         /   \             \ /   \         /   \ /               C
7540 !       j| o |l1       | o |              o| o |         | o |o                C
7541 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7542 !      \i/   \         /   \ /             /   \         /   \                 C
7543 !       o    k1             o                                                  C
7544 !         (I)          (II)                (III)          (IV)                 C
7545 !                                                                              C
7546 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7547 !                                                                              C
7548 !                            Antiparallel chains                               C
7549 !                                                                              C
7550 !          o             o                   o             o                   C
7551 !         /j\           / \             \   / \           / \   /              C
7552 !        /   \         /   \             \ /   \         /   \ /               C
7553 !      j1| o |l        | o |              o| o |         | o |o                C
7554 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7555 !      \i/   \         /   \ /             /   \         /   \                 C
7556 !       o     k1            o                                                  C
7557 !         (I)          (II)                (III)          (IV)                 C
7558 !                                                                              C
7559 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7560 !                                                                              C
7561 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7562 !                                                                              C
7563 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7564 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7565 !d        eello5=0.0d0
7566 !d        return
7567 !d      endif
7568 !d      write (iout,*)
7569 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7570 !d     &   ' and',k,l
7571       itk=itortyp(itype(k))
7572       itl=itortyp(itype(l))
7573       itj=itortyp(itype(j))
7574       eello5_1=0.0d0
7575       eello5_2=0.0d0
7576       eello5_3=0.0d0
7577       eello5_4=0.0d0
7578 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7579 !d     &   eel5_3_num,eel5_4_num)
7580       do iii=1,2
7581         do kkk=1,5
7582           do lll=1,3
7583             derx(lll,kkk,iii)=0.0d0
7584           enddo
7585         enddo
7586       enddo
7587 !d      eij=facont_hb(jj,i)
7588 !d      ekl=facont_hb(kk,k)
7589 !d      ekont=eij*ekl
7590 !d      write (iout,*)'Contacts have occurred for peptide groups',
7591 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7592 !d      goto 1111
7593 ! Contribution from the graph I.
7594 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7595 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7596       call transpose2(EUg(1,1,k),auxmat(1,1))
7597       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7598       vv(1)=pizda(1,1)-pizda(2,2)
7599       vv(2)=pizda(1,2)+pizda(2,1)
7600       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7601        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7602 ! Explicit gradient in virtual-dihedral angles.
7603       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7604        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7605        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7606       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7607       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7608       vv(1)=pizda(1,1)-pizda(2,2)
7609       vv(2)=pizda(1,2)+pizda(2,1)
7610       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7611        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7612        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7613       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7614       vv(1)=pizda(1,1)-pizda(2,2)
7615       vv(2)=pizda(1,2)+pizda(2,1)
7616       if (l.eq.j+1) then
7617         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7618          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7619          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7620       else
7621         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7622          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7623          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7624       endif
7625 ! Cartesian gradient
7626       do iii=1,2
7627         do kkk=1,5
7628           do lll=1,3
7629             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7630               pizda(1,1))
7631             vv(1)=pizda(1,1)-pizda(2,2)
7632             vv(2)=pizda(1,2)+pizda(2,1)
7633             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7634              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7635              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7636           enddo
7637         enddo
7638       enddo
7639 !      goto 1112
7640 !1111  continue
7641 ! Contribution from graph II
7642       call transpose2(EE(1,1,itk),auxmat(1,1))
7643       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7644       vv(1)=pizda(1,1)+pizda(2,2)
7645       vv(2)=pizda(2,1)-pizda(1,2)
7646       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7647        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7648 ! Explicit gradient in virtual-dihedral angles.
7649       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7650        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7651       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7652       vv(1)=pizda(1,1)+pizda(2,2)
7653       vv(2)=pizda(2,1)-pizda(1,2)
7654       if (l.eq.j+1) then
7655         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7656          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7657          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7658       else
7659         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7660          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7661          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7662       endif
7663 ! Cartesian gradient
7664       do iii=1,2
7665         do kkk=1,5
7666           do lll=1,3
7667             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7668               pizda(1,1))
7669             vv(1)=pizda(1,1)+pizda(2,2)
7670             vv(2)=pizda(2,1)-pizda(1,2)
7671             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7672              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7673              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7674           enddo
7675         enddo
7676       enddo
7677 !d      goto 1112
7678 !d1111  continue
7679       if (l.eq.j+1) then
7680 !d        goto 1110
7681 ! Parallel orientation
7682 ! Contribution from graph III
7683         call transpose2(EUg(1,1,l),auxmat(1,1))
7684         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7685         vv(1)=pizda(1,1)-pizda(2,2)
7686         vv(2)=pizda(1,2)+pizda(2,1)
7687         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7688          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7689 ! Explicit gradient in virtual-dihedral angles.
7690         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7691          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7692          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7693         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7694         vv(1)=pizda(1,1)-pizda(2,2)
7695         vv(2)=pizda(1,2)+pizda(2,1)
7696         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7697          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7698          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7699         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7700         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7701         vv(1)=pizda(1,1)-pizda(2,2)
7702         vv(2)=pizda(1,2)+pizda(2,1)
7703         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7704          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7705          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7706 ! Cartesian gradient
7707         do iii=1,2
7708           do kkk=1,5
7709             do lll=1,3
7710               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7711                 pizda(1,1))
7712               vv(1)=pizda(1,1)-pizda(2,2)
7713               vv(2)=pizda(1,2)+pizda(2,1)
7714               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7715                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7716                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7717             enddo
7718           enddo
7719         enddo
7720 !d        goto 1112
7721 ! Contribution from graph IV
7722 !d1110    continue
7723         call transpose2(EE(1,1,itl),auxmat(1,1))
7724         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7725         vv(1)=pizda(1,1)+pizda(2,2)
7726         vv(2)=pizda(2,1)-pizda(1,2)
7727         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7728          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7729 ! Explicit gradient in virtual-dihedral angles.
7730         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7731          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7732         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7733         vv(1)=pizda(1,1)+pizda(2,2)
7734         vv(2)=pizda(2,1)-pizda(1,2)
7735         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7736          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7737          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7738 ! Cartesian gradient
7739         do iii=1,2
7740           do kkk=1,5
7741             do lll=1,3
7742               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7743                 pizda(1,1))
7744               vv(1)=pizda(1,1)+pizda(2,2)
7745               vv(2)=pizda(2,1)-pizda(1,2)
7746               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7747                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7748                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7749             enddo
7750           enddo
7751         enddo
7752       else
7753 ! Antiparallel orientation
7754 ! Contribution from graph III
7755 !        goto 1110
7756         call transpose2(EUg(1,1,j),auxmat(1,1))
7757         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7758         vv(1)=pizda(1,1)-pizda(2,2)
7759         vv(2)=pizda(1,2)+pizda(2,1)
7760         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7761          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7762 ! Explicit gradient in virtual-dihedral angles.
7763         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7764          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7765          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7766         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7767         vv(1)=pizda(1,1)-pizda(2,2)
7768         vv(2)=pizda(1,2)+pizda(2,1)
7769         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7770          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7771          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7772         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7773         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7774         vv(1)=pizda(1,1)-pizda(2,2)
7775         vv(2)=pizda(1,2)+pizda(2,1)
7776         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7777          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7778          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7779 ! Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7784                 pizda(1,1))
7785               vv(1)=pizda(1,1)-pizda(2,2)
7786               vv(2)=pizda(1,2)+pizda(2,1)
7787               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7788                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7789                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7790             enddo
7791           enddo
7792         enddo
7793 !d        goto 1112
7794 ! Contribution from graph IV
7795 1110    continue
7796         call transpose2(EE(1,1,itj),auxmat(1,1))
7797         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7798         vv(1)=pizda(1,1)+pizda(2,2)
7799         vv(2)=pizda(2,1)-pizda(1,2)
7800         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7801          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7802 ! Explicit gradient in virtual-dihedral angles.
7803         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7804          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7805         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7806         vv(1)=pizda(1,1)+pizda(2,2)
7807         vv(2)=pizda(2,1)-pizda(1,2)
7808         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7809          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7810          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7811 ! Cartesian gradient
7812         do iii=1,2
7813           do kkk=1,5
7814             do lll=1,3
7815               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7816                 pizda(1,1))
7817               vv(1)=pizda(1,1)+pizda(2,2)
7818               vv(2)=pizda(2,1)-pizda(1,2)
7819               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7820                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7821                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7822             enddo
7823           enddo
7824         enddo
7825       endif
7826 1112  continue
7827       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7828 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7829 !d        write (2,*) 'ijkl',i,j,k,l
7830 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7831 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7832 !d      endif
7833 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7834 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7835 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7836 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7837       if (j.lt.nres-1) then
7838         j1=j+1
7839         j2=j-1
7840       else
7841         j1=j-1
7842         j2=j-2
7843       endif
7844       if (l.lt.nres-1) then
7845         l1=l+1
7846         l2=l-1
7847       else
7848         l1=l-1
7849         l2=l-2
7850       endif
7851 !d      eij=1.0d0
7852 !d      ekl=1.0d0
7853 !d      ekont=1.0d0
7854 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7855 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7856 !        summed up outside the subrouine as for the other subroutines
7857 !        handling long-range interactions. The old code is commented out
7858 !        with "cgrad" to keep track of changes.
7859       do ll=1,3
7860 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7861 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7862         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7863         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7864 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7865 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7866 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7867 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7868 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7869 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7870 !     &   gradcorr5ij,
7871 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7872 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7873 !grad        ghalf=0.5d0*ggg1(ll)
7874 !d        ghalf=0.0d0
7875         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7876         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7877         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7878         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7879         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7880         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7881 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7882 !grad        ghalf=0.5d0*ggg2(ll)
7883         ghalf=0.0d0
7884         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7885         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7886         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7887         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7888         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7889         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7890       enddo
7891 !d      goto 1112
7892 !grad      do m=i+1,j-1
7893 !grad        do ll=1,3
7894 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7895 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7896 !grad        enddo
7897 !grad      enddo
7898 !grad      do m=k+1,l-1
7899 !grad        do ll=1,3
7900 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7901 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7902 !grad        enddo
7903 !grad      enddo
7904 !1112  continue
7905 !grad      do m=i+2,j2
7906 !grad        do ll=1,3
7907 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7908 !grad        enddo
7909 !grad      enddo
7910 !grad      do m=k+2,l2
7911 !grad        do ll=1,3
7912 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7913 !grad        enddo
7914 !grad      enddo
7915 !d      do iii=1,nres-3
7916 !d        write (2,*) iii,g_corr5_loc(iii)
7917 !d      enddo
7918       eello5=ekont*eel5
7919 !d      write (2,*) 'ekont',ekont
7920 !d      write (iout,*) 'eello5',ekont*eel5
7921       return
7922       end function eello5
7923 !-----------------------------------------------------------------------------
7924       real(kind=8) function eello6(i,j,k,l,jj,kk)
7925 !      implicit real*8 (a-h,o-z)
7926 !      include 'DIMENSIONS'
7927 !      include 'COMMON.IOUNITS'
7928 !      include 'COMMON.CHAIN'
7929 !      include 'COMMON.DERIV'
7930 !      include 'COMMON.INTERACT'
7931 !      include 'COMMON.CONTACTS'
7932 !      include 'COMMON.TORSION'
7933 !      include 'COMMON.VAR'
7934 !      include 'COMMON.GEO'
7935 !      include 'COMMON.FFIELD'
7936       real(kind=8),dimension(3) :: ggg1,ggg2
7937       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7938                    eello6_6,eel6
7939       real(kind=8) :: gradcorr6ij,gradcorr6kl
7940       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7941 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7942 !d        eello6=0.0d0
7943 !d        return
7944 !d      endif
7945 !d      write (iout,*)
7946 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7947 !d     &   ' and',k,l
7948       eello6_1=0.0d0
7949       eello6_2=0.0d0
7950       eello6_3=0.0d0
7951       eello6_4=0.0d0
7952       eello6_5=0.0d0
7953       eello6_6=0.0d0
7954 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7955 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7956       do iii=1,2
7957         do kkk=1,5
7958           do lll=1,3
7959             derx(lll,kkk,iii)=0.0d0
7960           enddo
7961         enddo
7962       enddo
7963 !d      eij=facont_hb(jj,i)
7964 !d      ekl=facont_hb(kk,k)
7965 !d      ekont=eij*ekl
7966 !d      eij=1.0d0
7967 !d      ekl=1.0d0
7968 !d      ekont=1.0d0
7969       if (l.eq.j+1) then
7970         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7971         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7972         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7973         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7974         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7975         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7976       else
7977         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7978         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7979         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7980         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7981         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7982           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7983         else
7984           eello6_5=0.0d0
7985         endif
7986         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7987       endif
7988 ! If turn contributions are considered, they will be handled separately.
7989       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7990 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7991 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7992 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7993 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7994 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7995 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7996 !d      goto 1112
7997       if (j.lt.nres-1) then
7998         j1=j+1
7999         j2=j-1
8000       else
8001         j1=j-1
8002         j2=j-2
8003       endif
8004       if (l.lt.nres-1) then
8005         l1=l+1
8006         l2=l-1
8007       else
8008         l1=l-1
8009         l2=l-2
8010       endif
8011       do ll=1,3
8012 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8013 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8014 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8015 !grad        ghalf=0.5d0*ggg1(ll)
8016 !d        ghalf=0.0d0
8017         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8018         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8019         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8020         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8021         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8022         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8023         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8024         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8025 !grad        ghalf=0.5d0*ggg2(ll)
8026 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8027 !d        ghalf=0.0d0
8028         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8029         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8030         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8031         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8032         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8033         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8034       enddo
8035 !d      goto 1112
8036 !grad      do m=i+1,j-1
8037 !grad        do ll=1,3
8038 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8039 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8040 !grad        enddo
8041 !grad      enddo
8042 !grad      do m=k+1,l-1
8043 !grad        do ll=1,3
8044 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8045 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8046 !grad        enddo
8047 !grad      enddo
8048 !grad1112  continue
8049 !grad      do m=i+2,j2
8050 !grad        do ll=1,3
8051 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8052 !grad        enddo
8053 !grad      enddo
8054 !grad      do m=k+2,l2
8055 !grad        do ll=1,3
8056 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8057 !grad        enddo
8058 !grad      enddo
8059 !d      do iii=1,nres-3
8060 !d        write (2,*) iii,g_corr6_loc(iii)
8061 !d      enddo
8062       eello6=ekont*eel6
8063 !d      write (2,*) 'ekont',ekont
8064 !d      write (iout,*) 'eello6',ekont*eel6
8065       return
8066       end function eello6
8067 !-----------------------------------------------------------------------------
8068       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8069       use comm_kut
8070 !      implicit real*8 (a-h,o-z)
8071 !      include 'DIMENSIONS'
8072 !      include 'COMMON.IOUNITS'
8073 !      include 'COMMON.CHAIN'
8074 !      include 'COMMON.DERIV'
8075 !      include 'COMMON.INTERACT'
8076 !      include 'COMMON.CONTACTS'
8077 !      include 'COMMON.TORSION'
8078 !      include 'COMMON.VAR'
8079 !      include 'COMMON.GEO'
8080       real(kind=8),dimension(2) :: vv,vv1
8081       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8082       logical :: swap
8083 !el      logical :: lprn
8084 !el      common /kutas/ lprn
8085       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8086       real(kind=8) :: s1,s2,s3,s4,s5
8087 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8088 !                                                                              C
8089 !      Parallel       Antiparallel                                             C
8090 !                                                                              C
8091 !          o             o                                                     C
8092 !         /l\           /j\                                                    C
8093 !        /   \         /   \                                                   C
8094 !       /| o |         | o |\                                                  C
8095 !     \ j|/k\|  /   \  |/k\|l /                                                C
8096 !      \ /   \ /     \ /   \ /                                                 C
8097 !       o     o       o     o                                                  C
8098 !       i             i                                                        C
8099 !                                                                              C
8100 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8101       itk=itortyp(itype(k))
8102       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8103       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8104       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8105       call transpose2(EUgC(1,1,k),auxmat(1,1))
8106       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8107       vv1(1)=pizda1(1,1)-pizda1(2,2)
8108       vv1(2)=pizda1(1,2)+pizda1(2,1)
8109       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8110       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8111       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8112       s5=scalar2(vv(1),Dtobr2(1,i))
8113 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8114       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8115       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8116        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8117        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8118        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8119        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8120        +scalar2(vv(1),Dtobr2der(1,i)))
8121       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8122       vv1(1)=pizda1(1,1)-pizda1(2,2)
8123       vv1(2)=pizda1(1,2)+pizda1(2,1)
8124       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8125       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8126       if (l.eq.j+1) then
8127         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8128        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8129        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8130        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8131        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8132       else
8133         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8134        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8135        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8136        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8137        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8138       endif
8139       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8140       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8141       vv1(1)=pizda1(1,1)-pizda1(2,2)
8142       vv1(2)=pizda1(1,2)+pizda1(2,1)
8143       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8144        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8145        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8146        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8147       do iii=1,2
8148         if (swap) then
8149           ind=3-iii
8150         else
8151           ind=iii
8152         endif
8153         do kkk=1,5
8154           do lll=1,3
8155             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8156             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8157             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8158             call transpose2(EUgC(1,1,k),auxmat(1,1))
8159             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8160               pizda1(1,1))
8161             vv1(1)=pizda1(1,1)-pizda1(2,2)
8162             vv1(2)=pizda1(1,2)+pizda1(2,1)
8163             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8164             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8165              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8166             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8167              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8168             s5=scalar2(vv(1),Dtobr2(1,i))
8169             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8170           enddo
8171         enddo
8172       enddo
8173       return
8174       end function eello6_graph1
8175 !-----------------------------------------------------------------------------
8176       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8177       use comm_kut
8178 !      implicit real*8 (a-h,o-z)
8179 !      include 'DIMENSIONS'
8180 !      include 'COMMON.IOUNITS'
8181 !      include 'COMMON.CHAIN'
8182 !      include 'COMMON.DERIV'
8183 !      include 'COMMON.INTERACT'
8184 !      include 'COMMON.CONTACTS'
8185 !      include 'COMMON.TORSION'
8186 !      include 'COMMON.VAR'
8187 !      include 'COMMON.GEO'
8188       logical :: swap
8189       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8190       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8191 !el      logical :: lprn
8192 !el      common /kutas/ lprn
8193       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8194       real(kind=8) :: s2,s3,s4
8195 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8196 !                                                                              C
8197 !      Parallel       Antiparallel                                             C
8198 !                                                                              C
8199 !          o             o                                                     C
8200 !     \   /l\           /j\   /                                                C
8201 !      \ /   \         /   \ /                                                 C
8202 !       o| o |         | o |o                                                  C
8203 !     \ j|/k\|      \  |/k\|l                                                  C
8204 !      \ /   \       \ /   \                                                   C
8205 !       o             o                                                        C
8206 !       i             i                                                        C
8207 !                                                                              C
8208 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8209 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8210 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8211 !           but not in a cluster cumulant
8212 #ifdef MOMENT
8213       s1=dip(1,jj,i)*dip(1,kk,k)
8214 #endif
8215       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8216       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8217       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8218       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8219       call transpose2(EUg(1,1,k),auxmat(1,1))
8220       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8221       vv(1)=pizda(1,1)-pizda(2,2)
8222       vv(2)=pizda(1,2)+pizda(2,1)
8223       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8224 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8225 #ifdef MOMENT
8226       eello6_graph2=-(s1+s2+s3+s4)
8227 #else
8228       eello6_graph2=-(s2+s3+s4)
8229 #endif
8230 !      eello6_graph2=-s3
8231 ! Derivatives in gamma(i-1)
8232       if (i.gt.1) then
8233 #ifdef MOMENT
8234         s1=dipderg(1,jj,i)*dip(1,kk,k)
8235 #endif
8236         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8237         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8238         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8239         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8240 #ifdef MOMENT
8241         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8242 #else
8243         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8244 #endif
8245 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8246       endif
8247 ! Derivatives in gamma(k-1)
8248 #ifdef MOMENT
8249       s1=dip(1,jj,i)*dipderg(1,kk,k)
8250 #endif
8251       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8252       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8253       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8254       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8255       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8256       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8257       vv(1)=pizda(1,1)-pizda(2,2)
8258       vv(2)=pizda(1,2)+pizda(2,1)
8259       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8260 #ifdef MOMENT
8261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8262 #else
8263       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8264 #endif
8265 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8266 ! Derivatives in gamma(j-1) or gamma(l-1)
8267       if (j.gt.1) then
8268 #ifdef MOMENT
8269         s1=dipderg(3,jj,i)*dip(1,kk,k)
8270 #endif
8271         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8272         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8273         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8274         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8275         vv(1)=pizda(1,1)-pizda(2,2)
8276         vv(2)=pizda(1,2)+pizda(2,1)
8277         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8278 #ifdef MOMENT
8279         if (swap) then
8280           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8281         else
8282           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8283         endif
8284 #endif
8285         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8286 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8287       endif
8288 ! Derivatives in gamma(l-1) or gamma(j-1)
8289       if (l.gt.1) then
8290 #ifdef MOMENT
8291         s1=dip(1,jj,i)*dipderg(3,kk,k)
8292 #endif
8293         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8294         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8295         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8296         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8297         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8298         vv(1)=pizda(1,1)-pizda(2,2)
8299         vv(2)=pizda(1,2)+pizda(2,1)
8300         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8301 #ifdef MOMENT
8302         if (swap) then
8303           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8304         else
8305           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8306         endif
8307 #endif
8308         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8309 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8310       endif
8311 ! Cartesian derivatives.
8312       if (lprn) then
8313         write (2,*) 'In eello6_graph2'
8314         do iii=1,2
8315           write (2,*) 'iii=',iii
8316           do kkk=1,5
8317             write (2,*) 'kkk=',kkk
8318             do jjj=1,2
8319               write (2,'(3(2f10.5),5x)') &
8320               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8321             enddo
8322           enddo
8323         enddo
8324       endif
8325       do iii=1,2
8326         do kkk=1,5
8327           do lll=1,3
8328 #ifdef MOMENT
8329             if (iii.eq.1) then
8330               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8331             else
8332               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8333             endif
8334 #endif
8335             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8336               auxvec(1))
8337             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8338             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8339               auxvec(1))
8340             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8341             call transpose2(EUg(1,1,k),auxmat(1,1))
8342             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8343               pizda(1,1))
8344             vv(1)=pizda(1,1)-pizda(2,2)
8345             vv(2)=pizda(1,2)+pizda(2,1)
8346             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8347 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8348 #ifdef MOMENT
8349             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8350 #else
8351             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8352 #endif
8353             if (swap) then
8354               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8355             else
8356               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8357             endif
8358           enddo
8359         enddo
8360       enddo
8361       return
8362       end function eello6_graph2
8363 !-----------------------------------------------------------------------------
8364       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8365 !      implicit real*8 (a-h,o-z)
8366 !      include 'DIMENSIONS'
8367 !      include 'COMMON.IOUNITS'
8368 !      include 'COMMON.CHAIN'
8369 !      include 'COMMON.DERIV'
8370 !      include 'COMMON.INTERACT'
8371 !      include 'COMMON.CONTACTS'
8372 !      include 'COMMON.TORSION'
8373 !      include 'COMMON.VAR'
8374 !      include 'COMMON.GEO'
8375       real(kind=8),dimension(2) :: vv,auxvec
8376       real(kind=8),dimension(2,2) :: pizda,auxmat
8377       logical :: swap
8378       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8379       real(kind=8) :: s1,s2,s3,s4
8380 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8381 !                                                                              C
8382 !      Parallel       Antiparallel                                             C
8383 !                                                                              C
8384 !          o             o                                                     C
8385 !         /l\   /   \   /j\                                                    C
8386 !        /   \ /     \ /   \                                                   C
8387 !       /| o |o       o| o |\                                                  C
8388 !       j|/k\|  /      |/k\|l /                                                C
8389 !        /   \ /       /   \ /                                                 C
8390 !       /     o       /     o                                                  C
8391 !       i             i                                                        C
8392 !                                                                              C
8393 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8394 !
8395 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8396 !           energy moment and not to the cluster cumulant.
8397       iti=itortyp(itype(i))
8398       if (j.lt.nres-1) then
8399         itj1=itortyp(itype(j+1))
8400       else
8401         itj1=ntortyp+1
8402       endif
8403       itk=itortyp(itype(k))
8404       itk1=itortyp(itype(k+1))
8405       if (l.lt.nres-1) then
8406         itl1=itortyp(itype(l+1))
8407       else
8408         itl1=ntortyp+1
8409       endif
8410 #ifdef MOMENT
8411       s1=dip(4,jj,i)*dip(4,kk,k)
8412 #endif
8413       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8414       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8415       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8416       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8417       call transpose2(EE(1,1,itk),auxmat(1,1))
8418       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8419       vv(1)=pizda(1,1)+pizda(2,2)
8420       vv(2)=pizda(2,1)-pizda(1,2)
8421       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8422 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8423 !d     & "sum",-(s2+s3+s4)
8424 #ifdef MOMENT
8425       eello6_graph3=-(s1+s2+s3+s4)
8426 #else
8427       eello6_graph3=-(s2+s3+s4)
8428 #endif
8429 !      eello6_graph3=-s4
8430 ! Derivatives in gamma(k-1)
8431       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8432       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8433       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8434       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8435 ! Derivatives in gamma(l-1)
8436       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8437       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8438       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8439       vv(1)=pizda(1,1)+pizda(2,2)
8440       vv(2)=pizda(2,1)-pizda(1,2)
8441       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8442       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8443 ! Cartesian derivatives.
8444       do iii=1,2
8445         do kkk=1,5
8446           do lll=1,3
8447 #ifdef MOMENT
8448             if (iii.eq.1) then
8449               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8450             else
8451               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8452             endif
8453 #endif
8454             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8455               auxvec(1))
8456             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8457             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8458               auxvec(1))
8459             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8460             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8461               pizda(1,1))
8462             vv(1)=pizda(1,1)+pizda(2,2)
8463             vv(2)=pizda(2,1)-pizda(1,2)
8464             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8465 #ifdef MOMENT
8466             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8467 #else
8468             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8469 #endif
8470             if (swap) then
8471               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8472             else
8473               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8474             endif
8475 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8476           enddo
8477         enddo
8478       enddo
8479       return
8480       end function eello6_graph3
8481 !-----------------------------------------------------------------------------
8482       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8483 !      implicit real*8 (a-h,o-z)
8484 !      include 'DIMENSIONS'
8485 !      include 'COMMON.IOUNITS'
8486 !      include 'COMMON.CHAIN'
8487 !      include 'COMMON.DERIV'
8488 !      include 'COMMON.INTERACT'
8489 !      include 'COMMON.CONTACTS'
8490 !      include 'COMMON.TORSION'
8491 !      include 'COMMON.VAR'
8492 !      include 'COMMON.GEO'
8493 !      include 'COMMON.FFIELD'
8494       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8495       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8496       logical :: swap
8497       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8498               iii,kkk,lll
8499       real(kind=8) :: s1,s2,s3,s4
8500 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8501 !                                                                              C
8502 !      Parallel       Antiparallel                                             C
8503 !                                                                              C
8504 !          o             o                                                     C
8505 !         /l\   /   \   /j\                                                    C
8506 !        /   \ /     \ /   \                                                   C
8507 !       /| o |o       o| o |\                                                  C
8508 !     \ j|/k\|      \  |/k\|l                                                  C
8509 !      \ /   \       \ /   \                                                   C
8510 !       o     \       o     \                                                  C
8511 !       i             i                                                        C
8512 !                                                                              C
8513 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8514 !
8515 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8516 !           energy moment and not to the cluster cumulant.
8517 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8518       iti=itortyp(itype(i))
8519       itj=itortyp(itype(j))
8520       if (j.lt.nres-1) then
8521         itj1=itortyp(itype(j+1))
8522       else
8523         itj1=ntortyp+1
8524       endif
8525       itk=itortyp(itype(k))
8526       if (k.lt.nres-1) then
8527         itk1=itortyp(itype(k+1))
8528       else
8529         itk1=ntortyp+1
8530       endif
8531       itl=itortyp(itype(l))
8532       if (l.lt.nres-1) then
8533         itl1=itortyp(itype(l+1))
8534       else
8535         itl1=ntortyp+1
8536       endif
8537 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8538 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8539 !d     & ' itl',itl,' itl1',itl1
8540 #ifdef MOMENT
8541       if (imat.eq.1) then
8542         s1=dip(3,jj,i)*dip(3,kk,k)
8543       else
8544         s1=dip(2,jj,j)*dip(2,kk,l)
8545       endif
8546 #endif
8547       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8548       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8549       if (j.eq.l+1) then
8550         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8551         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8552       else
8553         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8554         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8555       endif
8556       call transpose2(EUg(1,1,k),auxmat(1,1))
8557       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8558       vv(1)=pizda(1,1)-pizda(2,2)
8559       vv(2)=pizda(2,1)+pizda(1,2)
8560       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8561 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8562 #ifdef MOMENT
8563       eello6_graph4=-(s1+s2+s3+s4)
8564 #else
8565       eello6_graph4=-(s2+s3+s4)
8566 #endif
8567 ! Derivatives in gamma(i-1)
8568       if (i.gt.1) then
8569 #ifdef MOMENT
8570         if (imat.eq.1) then
8571           s1=dipderg(2,jj,i)*dip(3,kk,k)
8572         else
8573           s1=dipderg(4,jj,j)*dip(2,kk,l)
8574         endif
8575 #endif
8576         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8577         if (j.eq.l+1) then
8578           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8579           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8580         else
8581           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8582           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8583         endif
8584         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8585         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8586 !d          write (2,*) 'turn6 derivatives'
8587 #ifdef MOMENT
8588           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8589 #else
8590           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8591 #endif
8592         else
8593 #ifdef MOMENT
8594           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8595 #else
8596           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8597 #endif
8598         endif
8599       endif
8600 ! Derivatives in gamma(k-1)
8601 #ifdef MOMENT
8602       if (imat.eq.1) then
8603         s1=dip(3,jj,i)*dipderg(2,kk,k)
8604       else
8605         s1=dip(2,jj,j)*dipderg(4,kk,l)
8606       endif
8607 #endif
8608       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8609       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8610       if (j.eq.l+1) then
8611         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8612         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8613       else
8614         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8615         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8616       endif
8617       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8618       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8619       vv(1)=pizda(1,1)-pizda(2,2)
8620       vv(2)=pizda(2,1)+pizda(1,2)
8621       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8622       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8623 #ifdef MOMENT
8624         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8625 #else
8626         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8627 #endif
8628       else
8629 #ifdef MOMENT
8630         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8631 #else
8632         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8633 #endif
8634       endif
8635 ! Derivatives in gamma(j-1) or gamma(l-1)
8636       if (l.eq.j+1 .and. l.gt.1) then
8637         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8638         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8639         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8640         vv(1)=pizda(1,1)-pizda(2,2)
8641         vv(2)=pizda(2,1)+pizda(1,2)
8642         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8643         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8644       else if (j.gt.1) then
8645         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8646         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8647         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8648         vv(1)=pizda(1,1)-pizda(2,2)
8649         vv(2)=pizda(2,1)+pizda(1,2)
8650         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8651         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8652           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8653         else
8654           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8655         endif
8656       endif
8657 ! Cartesian derivatives.
8658       do iii=1,2
8659         do kkk=1,5
8660           do lll=1,3
8661 #ifdef MOMENT
8662             if (iii.eq.1) then
8663               if (imat.eq.1) then
8664                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8665               else
8666                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8667               endif
8668             else
8669               if (imat.eq.1) then
8670                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8671               else
8672                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8673               endif
8674             endif
8675 #endif
8676             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8677               auxvec(1))
8678             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8679             if (j.eq.l+1) then
8680               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8681                 b1(1,itj1),auxvec(1))
8682               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8683             else
8684               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8685                 b1(1,itl1),auxvec(1))
8686               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8687             endif
8688             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8689               pizda(1,1))
8690             vv(1)=pizda(1,1)-pizda(2,2)
8691             vv(2)=pizda(2,1)+pizda(1,2)
8692             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8693             if (swap) then
8694               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8695 #ifdef MOMENT
8696                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8697                    -(s1+s2+s4)
8698 #else
8699                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8700                    -(s2+s4)
8701 #endif
8702                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8703               else
8704 #ifdef MOMENT
8705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8706 #else
8707                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8708 #endif
8709                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8710               endif
8711             else
8712 #ifdef MOMENT
8713               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8714 #else
8715               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8716 #endif
8717               if (l.eq.j+1) then
8718                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8719               else
8720                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8721               endif
8722             endif
8723           enddo
8724         enddo
8725       enddo
8726       return
8727       end function eello6_graph4
8728 !-----------------------------------------------------------------------------
8729       real(kind=8) function eello_turn6(i,jj,kk)
8730 !      implicit real*8 (a-h,o-z)
8731 !      include 'DIMENSIONS'
8732 !      include 'COMMON.IOUNITS'
8733 !      include 'COMMON.CHAIN'
8734 !      include 'COMMON.DERIV'
8735 !      include 'COMMON.INTERACT'
8736 !      include 'COMMON.CONTACTS'
8737 !      include 'COMMON.TORSION'
8738 !      include 'COMMON.VAR'
8739 !      include 'COMMON.GEO'
8740       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8741       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8742       real(kind=8),dimension(3) :: ggg1,ggg2
8743       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8744       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8745 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8746 !           the respective energy moment and not to the cluster cumulant.
8747 !el local variables
8748       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8749       integer :: j1,j2,l1,l2,ll
8750       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8751       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8752       s1=0.0d0
8753       s8=0.0d0
8754       s13=0.0d0
8755 !
8756       eello_turn6=0.0d0
8757       j=i+4
8758       k=i+1
8759       l=i+3
8760       iti=itortyp(itype(i))
8761       itk=itortyp(itype(k))
8762       itk1=itortyp(itype(k+1))
8763       itl=itortyp(itype(l))
8764       itj=itortyp(itype(j))
8765 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8766 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8767 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8768 !d        eello6=0.0d0
8769 !d        return
8770 !d      endif
8771 !d      write (iout,*)
8772 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8773 !d     &   ' and',k,l
8774 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8775       do iii=1,2
8776         do kkk=1,5
8777           do lll=1,3
8778             derx_turn(lll,kkk,iii)=0.0d0
8779           enddo
8780         enddo
8781       enddo
8782 !d      eij=1.0d0
8783 !d      ekl=1.0d0
8784 !d      ekont=1.0d0
8785       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8786 !d      eello6_5=0.0d0
8787 !d      write (2,*) 'eello6_5',eello6_5
8788 #ifdef MOMENT
8789       call transpose2(AEA(1,1,1),auxmat(1,1))
8790       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8791       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8792       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8793 #endif
8794       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8795       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8796       s2 = scalar2(b1(1,itk),vtemp1(1))
8797 #ifdef MOMENT
8798       call transpose2(AEA(1,1,2),atemp(1,1))
8799       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8800       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8801       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8802 #endif
8803       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8804       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8805       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8806 #ifdef MOMENT
8807       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8808       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8809       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8810       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8811       ss13 = scalar2(b1(1,itk),vtemp4(1))
8812       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8813 #endif
8814 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8815 !      s1=0.0d0
8816 !      s2=0.0d0
8817 !      s8=0.0d0
8818 !      s12=0.0d0
8819 !      s13=0.0d0
8820       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8821 ! Derivatives in gamma(i+2)
8822       s1d =0.0d0
8823       s8d =0.0d0
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,1),auxmatd(1,1))
8826       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8827       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8828       call transpose2(AEAderg(1,1,2),atempd(1,1))
8829       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8830       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8831 #endif
8832       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8833       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8834       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8835 !      s1d=0.0d0
8836 !      s2d=0.0d0
8837 !      s8d=0.0d0
8838 !      s12d=0.0d0
8839 !      s13d=0.0d0
8840       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8841 ! Derivatives in gamma(i+3)
8842 #ifdef MOMENT
8843       call transpose2(AEA(1,1,1),auxmatd(1,1))
8844       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8845       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8847 #endif
8848       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8849       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8850       s2d = scalar2(b1(1,itk),vtemp1d(1))
8851 #ifdef MOMENT
8852       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8853       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8854 #endif
8855       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8856 #ifdef MOMENT
8857       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8858       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8859       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8860 #endif
8861 !      s1d=0.0d0
8862 !      s2d=0.0d0
8863 !      s8d=0.0d0
8864 !      s12d=0.0d0
8865 !      s13d=0.0d0
8866 #ifdef MOMENT
8867       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8868                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8869 #else
8870       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8871                     -0.5d0*ekont*(s2d+s12d)
8872 #endif
8873 ! Derivatives in gamma(i+4)
8874       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8875       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8876       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8877 #ifdef MOMENT
8878       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8879       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8880       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8881 #endif
8882 !      s1d=0.0d0
8883 !      s2d=0.0d0
8884 !      s8d=0.0d0
8885 !      s12d=0.0d0
8886 !      s13d=0.0d0
8887 #ifdef MOMENT
8888       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8889 #else
8890       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8891 #endif
8892 ! Derivatives in gamma(i+5)
8893 #ifdef MOMENT
8894       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8897 #endif
8898       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8899       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8900       s2d = scalar2(b1(1,itk),vtemp1d(1))
8901 #ifdef MOMENT
8902       call transpose2(AEA(1,1,2),atempd(1,1))
8903       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8904       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8905 #endif
8906       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8907       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8908 #ifdef MOMENT
8909       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8910       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8911       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8912 #endif
8913 !      s1d=0.0d0
8914 !      s2d=0.0d0
8915 !      s8d=0.0d0
8916 !      s12d=0.0d0
8917 !      s13d=0.0d0
8918 #ifdef MOMENT
8919       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8920                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8921 #else
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8923                     -0.5d0*ekont*(s2d+s12d)
8924 #endif
8925 ! Cartesian derivatives
8926       do iii=1,2
8927         do kkk=1,5
8928           do lll=1,3
8929 #ifdef MOMENT
8930             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8931             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #endif
8934             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8935             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8936                 vtemp1d(1))
8937             s2d = scalar2(b1(1,itk),vtemp1d(1))
8938 #ifdef MOMENT
8939             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8940             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8941             s8d = -(atempd(1,1)+atempd(2,2))* &
8942                  scalar2(cc(1,1,itl),vtemp2(1))
8943 #endif
8944             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8945                  auxmatd(1,1))
8946             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8947             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8948 !      s1d=0.0d0
8949 !      s2d=0.0d0
8950 !      s8d=0.0d0
8951 !      s12d=0.0d0
8952 !      s13d=0.0d0
8953 #ifdef MOMENT
8954             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8955               - 0.5d0*(s1d+s2d)
8956 #else
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8958               - 0.5d0*s2d
8959 #endif
8960 #ifdef MOMENT
8961             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8962               - 0.5d0*(s8d+s12d)
8963 #else
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8965               - 0.5d0*s12d
8966 #endif
8967           enddo
8968         enddo
8969       enddo
8970 #ifdef MOMENT
8971       do kkk=1,5
8972         do lll=1,3
8973           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8974             achuj_tempd(1,1))
8975           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8976           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8977           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8978           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8979           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8980             vtemp4d(1))
8981           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8982           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8983           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8984         enddo
8985       enddo
8986 #endif
8987 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8988 !d     &  16*eel_turn6_num
8989 !d      goto 1112
8990       if (j.lt.nres-1) then
8991         j1=j+1
8992         j2=j-1
8993       else
8994         j1=j-1
8995         j2=j-2
8996       endif
8997       if (l.lt.nres-1) then
8998         l1=l+1
8999         l2=l-1
9000       else
9001         l1=l-1
9002         l2=l-2
9003       endif
9004       do ll=1,3
9005 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9006 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9007 !grad        ghalf=0.5d0*ggg1(ll)
9008 !d        ghalf=0.0d0
9009         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9010         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9011         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9012           +ekont*derx_turn(ll,2,1)
9013         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9014         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9015           +ekont*derx_turn(ll,4,1)
9016         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9017         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9018         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9019 !grad        ghalf=0.5d0*ggg2(ll)
9020 !d        ghalf=0.0d0
9021         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9022           +ekont*derx_turn(ll,2,2)
9023         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9024         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9025           +ekont*derx_turn(ll,4,2)
9026         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9027         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9028         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9029       enddo
9030 !d      goto 1112
9031 !grad      do m=i+1,j-1
9032 !grad        do ll=1,3
9033 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9034 !grad        enddo
9035 !grad      enddo
9036 !grad      do m=k+1,l-1
9037 !grad        do ll=1,3
9038 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9039 !grad        enddo
9040 !grad      enddo
9041 !grad1112  continue
9042 !grad      do m=i+2,j2
9043 !grad        do ll=1,3
9044 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9045 !grad        enddo
9046 !grad      enddo
9047 !grad      do m=k+2,l2
9048 !grad        do ll=1,3
9049 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9050 !grad        enddo
9051 !grad      enddo
9052 !d      do iii=1,nres-3
9053 !d        write (2,*) iii,g_corr6_loc(iii)
9054 !d      enddo
9055       eello_turn6=ekont*eel_turn6
9056 !d      write (2,*) 'ekont',ekont
9057 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9058       return
9059       end function eello_turn6
9060 !-----------------------------------------------------------------------------
9061       subroutine MATVEC2(A1,V1,V2)
9062 !DIR$ INLINEALWAYS MATVEC2
9063 #ifndef OSF
9064 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9065 #endif
9066 !      implicit real*8 (a-h,o-z)
9067 !      include 'DIMENSIONS'
9068       real(kind=8),dimension(2) :: V1,V2
9069       real(kind=8),dimension(2,2) :: A1
9070       real(kind=8) :: vaux1,vaux2
9071 !      DO 1 I=1,2
9072 !        VI=0.0
9073 !        DO 3 K=1,2
9074 !    3     VI=VI+A1(I,K)*V1(K)
9075 !        Vaux(I)=VI
9076 !    1 CONTINUE
9077
9078       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9079       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9080
9081       v2(1)=vaux1
9082       v2(2)=vaux2
9083       end subroutine MATVEC2
9084 !-----------------------------------------------------------------------------
9085       subroutine MATMAT2(A1,A2,A3)
9086 #ifndef OSF
9087 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9088 #endif
9089 !      implicit real*8 (a-h,o-z)
9090 !      include 'DIMENSIONS'
9091       real(kind=8),dimension(2,2) :: A1,A2,A3
9092       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9093 !      DIMENSION AI3(2,2)
9094 !        DO  J=1,2
9095 !          A3IJ=0.0
9096 !          DO K=1,2
9097 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9098 !          enddo
9099 !          A3(I,J)=A3IJ
9100 !       enddo
9101 !      enddo
9102
9103       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9104       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9105       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9106       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9107
9108       A3(1,1)=AI3_11
9109       A3(2,1)=AI3_21
9110       A3(1,2)=AI3_12
9111       A3(2,2)=AI3_22
9112       end subroutine MATMAT2
9113 !-----------------------------------------------------------------------------
9114       real(kind=8) function scalar2(u,v)
9115 !DIR$ INLINEALWAYS scalar2
9116       implicit none
9117       real(kind=8),dimension(2) :: u,v
9118       real(kind=8) :: sc
9119       integer :: i
9120       scalar2=u(1)*v(1)+u(2)*v(2)
9121       return
9122       end function scalar2
9123 !-----------------------------------------------------------------------------
9124       subroutine transpose2(a,at)
9125 !DIR$ INLINEALWAYS transpose2
9126 #ifndef OSF
9127 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9128 #endif
9129       implicit none
9130       real(kind=8),dimension(2,2) :: a,at
9131       at(1,1)=a(1,1)
9132       at(1,2)=a(2,1)
9133       at(2,1)=a(1,2)
9134       at(2,2)=a(2,2)
9135       return
9136       end subroutine transpose2
9137 !-----------------------------------------------------------------------------
9138       subroutine transpose(n,a,at)
9139       implicit none
9140       integer :: n,i,j
9141       real(kind=8),dimension(n,n) :: a,at
9142       do i=1,n
9143         do j=1,n
9144           at(j,i)=a(i,j)
9145         enddo
9146       enddo
9147       return
9148       end subroutine transpose
9149 !-----------------------------------------------------------------------------
9150       subroutine prodmat3(a1,a2,kk,transp,prod)
9151 !DIR$ INLINEALWAYS prodmat3
9152 #ifndef OSF
9153 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9154 #endif
9155       implicit none
9156       integer :: i,j
9157       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9158       logical :: transp
9159 !rc      double precision auxmat(2,2),prod_(2,2)
9160
9161       if (transp) then
9162 !rc        call transpose2(kk(1,1),auxmat(1,1))
9163 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9164 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9165
9166            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9167        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9168            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9169        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9170            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9171        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9172            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9173        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9174
9175       else
9176 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9177 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9178
9179            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9180         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9181            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9182         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9183            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9184         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9185            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9186         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9187
9188       endif
9189 !      call transpose2(a2(1,1),a2t(1,1))
9190
9191 !rc      print *,transp
9192 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9193 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9194
9195       return
9196       end subroutine prodmat3
9197 !-----------------------------------------------------------------------------
9198 ! energy_p_new_barrier.F
9199 !-----------------------------------------------------------------------------
9200       subroutine sum_gradient
9201 !      implicit real*8 (a-h,o-z)
9202       use io_base, only: pdbout
9203 !      include 'DIMENSIONS'
9204 #ifndef ISNAN
9205       external proc_proc
9206 #ifdef WINPGI
9207 !MS$ATTRIBUTES C ::  proc_proc
9208 #endif
9209 #endif
9210 #ifdef MPI
9211       include 'mpif.h'
9212 #endif
9213       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9214                    gloc_scbuf !(3,maxres)
9215
9216       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9217 !#endif
9218 !el local variables
9219       integer :: i,j,k,ierror,ierr
9220       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9221                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9222                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9223                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9224                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9225                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9226                    gsccorr_max,gsccorrx_max,time00
9227
9228 !      include 'COMMON.SETUP'
9229 !      include 'COMMON.IOUNITS'
9230 !      include 'COMMON.FFIELD'
9231 !      include 'COMMON.DERIV'
9232 !      include 'COMMON.INTERACT'
9233 !      include 'COMMON.SBRIDGE'
9234 !      include 'COMMON.CHAIN'
9235 !      include 'COMMON.VAR'
9236 !      include 'COMMON.CONTROL'
9237 !      include 'COMMON.TIME1'
9238 !      include 'COMMON.MAXGRAD'
9239 !      include 'COMMON.SCCOR'
9240 #ifdef TIMING
9241       time01=MPI_Wtime()
9242 #endif
9243 #ifdef DEBUG
9244       write (iout,*) "sum_gradient gvdwc, gvdwx"
9245       do i=1,nres
9246         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9247          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9248       enddo
9249       call flush(iout)
9250 #endif
9251 #ifdef MPI
9252         gradbufc=0.0d0
9253         gradbufx=0.0d0
9254         gradbufc_sum=0.0d0
9255         gloc_scbuf=0.0d0
9256         glocbuf=0.0d0
9257 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9258         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9259           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9260 #endif
9261 !
9262 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9263 !            in virtual-bond-vector coordinates
9264 !
9265 #ifdef DEBUG
9266 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9267 !      do i=1,nres-1
9268 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9269 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9270 !      enddo
9271 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9272 !      do i=1,nres-1
9273 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9274 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9275 !      enddo
9276       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9277       do i=1,nres
9278         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9279          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9280          (gvdwc_scpp(j,i),j=1,3)
9281       enddo
9282       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9283       do i=1,nres
9284         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9285          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9286          (gelc_loc_long(j,i),j=1,3)
9287       enddo
9288       call flush(iout)
9289 #endif
9290 #ifdef SPLITELE
9291       do i=1,nct
9292         do j=1,3
9293           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9294                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9295                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9296                       wel_loc*gel_loc_long(j,i)+ &
9297                       wcorr*gradcorr_long(j,i)+ &
9298                       wcorr5*gradcorr5_long(j,i)+ &
9299                       wcorr6*gradcorr6_long(j,i)+ &
9300                       wturn6*gcorr6_turn_long(j,i)+ &
9301                       wstrain*ghpbc(j,i)
9302         enddo
9303       enddo
9304 #else
9305       do i=1,nct
9306         do j=1,3
9307           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9308                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9309                       welec*gelc_long(j,i)+ &
9310                       wbond*gradb(j,i)+ &
9311                       wel_loc*gel_loc_long(j,i)+ &
9312                       wcorr*gradcorr_long(j,i)+ &
9313                       wcorr5*gradcorr5_long(j,i)+ &
9314                       wcorr6*gradcorr6_long(j,i)+ &
9315                       wturn6*gcorr6_turn_long(j,i)+ &
9316                       wstrain*ghpbc(j,i)
9317         enddo
9318       enddo
9319 #endif
9320 #ifdef MPI
9321       if (nfgtasks.gt.1) then
9322       time00=MPI_Wtime()
9323 #ifdef DEBUG
9324       write (iout,*) "gradbufc before allreduce"
9325       do i=1,nres
9326         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9327       enddo
9328       call flush(iout)
9329 #endif
9330       do i=1,nres
9331         do j=1,3
9332           gradbufc_sum(j,i)=gradbufc(j,i)
9333         enddo
9334       enddo
9335 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9336 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9337 !      time_reduce=time_reduce+MPI_Wtime()-time00
9338 #ifdef DEBUG
9339 !      write (iout,*) "gradbufc_sum after allreduce"
9340 !      do i=1,nres
9341 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9342 !      enddo
9343 !      call flush(iout)
9344 #endif
9345 #ifdef TIMING
9346 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9347 #endif
9348       do i=nnt,nres
9349         do k=1,3
9350           gradbufc(k,i)=0.0d0
9351         enddo
9352       enddo
9353 #ifdef DEBUG
9354       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9355       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9356                         " jgrad_end  ",jgrad_end(i),&
9357                         i=igrad_start,igrad_end)
9358 #endif
9359 !
9360 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9361 ! do not parallelize this part.
9362 !
9363 !      do i=igrad_start,igrad_end
9364 !        do j=jgrad_start(i),jgrad_end(i)
9365 !          do k=1,3
9366 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9367 !          enddo
9368 !        enddo
9369 !      enddo
9370       do j=1,3
9371         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9372       enddo
9373       do i=nres-2,nnt,-1
9374         do j=1,3
9375           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9376         enddo
9377       enddo
9378 #ifdef DEBUG
9379       write (iout,*) "gradbufc after summing"
9380       do i=1,nres
9381         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9382       enddo
9383       call flush(iout)
9384 #endif
9385       else
9386 #endif
9387 !el#define DEBUG
9388 #ifdef DEBUG
9389       write (iout,*) "gradbufc"
9390       do i=1,nres
9391         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9392       enddo
9393       call flush(iout)
9394 #endif
9395 !el#undef DEBUG
9396       do i=1,nres
9397         do j=1,3
9398           gradbufc_sum(j,i)=gradbufc(j,i)
9399           gradbufc(j,i)=0.0d0
9400         enddo
9401       enddo
9402       do j=1,3
9403         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9404       enddo
9405       do i=nres-2,nnt,-1
9406         do j=1,3
9407           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9408         enddo
9409       enddo
9410 !      do i=nnt,nres-1
9411 !        do k=1,3
9412 !          gradbufc(k,i)=0.0d0
9413 !        enddo
9414 !        do j=i+1,nres
9415 !          do k=1,3
9416 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9417 !          enddo
9418 !        enddo
9419 !      enddo
9420 !el#define DEBUG
9421 #ifdef DEBUG
9422       write (iout,*) "gradbufc after summing"
9423       do i=1,nres
9424         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9425       enddo
9426       call flush(iout)
9427 #endif
9428 !el#undef DEBUG
9429 #ifdef MPI
9430       endif
9431 #endif
9432       do k=1,3
9433         gradbufc(k,nres)=0.0d0
9434       enddo
9435 !el----------------
9436 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9437 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9438 !el-----------------
9439       do i=1,nct
9440         do j=1,3
9441 #ifdef SPLITELE
9442           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9443                       wel_loc*gel_loc(j,i)+ &
9444                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9445                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9446                       wel_loc*gel_loc_long(j,i)+ &
9447                       wcorr*gradcorr_long(j,i)+ &
9448                       wcorr5*gradcorr5_long(j,i)+ &
9449                       wcorr6*gradcorr6_long(j,i)+ &
9450                       wturn6*gcorr6_turn_long(j,i))+ &
9451                       wbond*gradb(j,i)+ &
9452                       wcorr*gradcorr(j,i)+ &
9453                       wturn3*gcorr3_turn(j,i)+ &
9454                       wturn4*gcorr4_turn(j,i)+ &
9455                       wcorr5*gradcorr5(j,i)+ &
9456                       wcorr6*gradcorr6(j,i)+ &
9457                       wturn6*gcorr6_turn(j,i)+ &
9458                       wsccor*gsccorc(j,i) &
9459                      +wscloc*gscloc(j,i)
9460 #else
9461           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9462                       wel_loc*gel_loc(j,i)+ &
9463                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9464                       welec*gelc_long(j,i)+ &
9465                       wel_loc*gel_loc_long(j,i)+ &
9466 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9467                       wcorr5*gradcorr5_long(j,i)+ &
9468                       wcorr6*gradcorr6_long(j,i)+ &
9469                       wturn6*gcorr6_turn_long(j,i))+ &
9470                       wbond*gradb(j,i)+ &
9471                       wcorr*gradcorr(j,i)+ &
9472                       wturn3*gcorr3_turn(j,i)+ &
9473                       wturn4*gcorr4_turn(j,i)+ &
9474                       wcorr5*gradcorr5(j,i)+ &
9475                       wcorr6*gradcorr6(j,i)+ &
9476                       wturn6*gcorr6_turn(j,i)+ &
9477                       wsccor*gsccorc(j,i) &
9478                      +wscloc*gscloc(j,i)
9479 #endif
9480           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9481                         wbond*gradbx(j,i)+ &
9482                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9483                         wsccor*gsccorx(j,i) &
9484                        +wscloc*gsclocx(j,i)
9485         enddo
9486       enddo
9487 #ifdef DEBUG
9488       write (iout,*) "gloc before adding corr"
9489       do i=1,4*nres
9490         write (iout,*) i,gloc(i,icg)
9491       enddo
9492 #endif
9493       do i=1,nres-3
9494         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9495          +wcorr5*g_corr5_loc(i) &
9496          +wcorr6*g_corr6_loc(i) &
9497          +wturn4*gel_loc_turn4(i) &
9498          +wturn3*gel_loc_turn3(i) &
9499          +wturn6*gel_loc_turn6(i) &
9500          +wel_loc*gel_loc_loc(i)
9501       enddo
9502 #ifdef DEBUG
9503       write (iout,*) "gloc after adding corr"
9504       do i=1,4*nres
9505         write (iout,*) i,gloc(i,icg)
9506       enddo
9507 #endif
9508 #ifdef MPI
9509       if (nfgtasks.gt.1) then
9510         do j=1,3
9511           do i=1,nres
9512             gradbufc(j,i)=gradc(j,i,icg)
9513             gradbufx(j,i)=gradx(j,i,icg)
9514           enddo
9515         enddo
9516         do i=1,4*nres
9517           glocbuf(i)=gloc(i,icg)
9518         enddo
9519 !#define DEBUG
9520 #ifdef DEBUG
9521       write (iout,*) "gloc_sc before reduce"
9522       do i=1,nres
9523        do j=1,1
9524         write (iout,*) i,j,gloc_sc(j,i,icg)
9525        enddo
9526       enddo
9527 #endif
9528 !#undef DEBUG
9529         do i=1,nres
9530          do j=1,3
9531           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9532          enddo
9533         enddo
9534         time00=MPI_Wtime()
9535         call MPI_Barrier(FG_COMM,IERR)
9536         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9537         time00=MPI_Wtime()
9538         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9539           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9540         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9541           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9542         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9543           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9544         time_reduce=time_reduce+MPI_Wtime()-time00
9545         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9546           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9547         time_reduce=time_reduce+MPI_Wtime()-time00
9548 !#define DEBUG
9549 #ifdef DEBUG
9550       write (iout,*) "gloc_sc after reduce"
9551       do i=1,nres
9552        do j=1,1
9553         write (iout,*) i,j,gloc_sc(j,i,icg)
9554        enddo
9555       enddo
9556 #endif
9557 !#undef DEBUG
9558 #ifdef DEBUG
9559       write (iout,*) "gloc after reduce"
9560       do i=1,4*nres
9561         write (iout,*) i,gloc(i,icg)
9562       enddo
9563 #endif
9564       endif
9565 #endif
9566       if (gnorm_check) then
9567 !
9568 ! Compute the maximum elements of the gradient
9569 !
9570       gvdwc_max=0.0d0
9571       gvdwc_scp_max=0.0d0
9572       gelc_max=0.0d0
9573       gvdwpp_max=0.0d0
9574       gradb_max=0.0d0
9575       ghpbc_max=0.0d0
9576       gradcorr_max=0.0d0
9577       gel_loc_max=0.0d0
9578       gcorr3_turn_max=0.0d0
9579       gcorr4_turn_max=0.0d0
9580       gradcorr5_max=0.0d0
9581       gradcorr6_max=0.0d0
9582       gcorr6_turn_max=0.0d0
9583       gsccorc_max=0.0d0
9584       gscloc_max=0.0d0
9585       gvdwx_max=0.0d0
9586       gradx_scp_max=0.0d0
9587       ghpbx_max=0.0d0
9588       gradxorr_max=0.0d0
9589       gsccorx_max=0.0d0
9590       gsclocx_max=0.0d0
9591       do i=1,nct
9592         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9593         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9594         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9595         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9596          gvdwc_scp_max=gvdwc_scp_norm
9597         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9598         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9599         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9600         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9601         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9602         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9603         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9604         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9605         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9606         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9607         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9608         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9609         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9610           gcorr3_turn(1,i)))
9611         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9612           gcorr3_turn_max=gcorr3_turn_norm
9613         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9614           gcorr4_turn(1,i)))
9615         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9616           gcorr4_turn_max=gcorr4_turn_norm
9617         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9618         if (gradcorr5_norm.gt.gradcorr5_max) &
9619           gradcorr5_max=gradcorr5_norm
9620         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9621         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9622         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9623           gcorr6_turn(1,i)))
9624         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9625           gcorr6_turn_max=gcorr6_turn_norm
9626         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9627         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9628         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9629         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9630         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9631         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9632         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9633         if (gradx_scp_norm.gt.gradx_scp_max) &
9634           gradx_scp_max=gradx_scp_norm
9635         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9636         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9637         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9638         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9639         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9640         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9641         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9642         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9643       enddo
9644       if (gradout) then
9645 #ifdef AIX
9646         open(istat,file=statname,position="append")
9647 #else
9648         open(istat,file=statname,access="append")
9649 #endif
9650         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9651            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9652            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9653            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9654            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9655            gsccorx_max,gsclocx_max
9656         close(istat)
9657         if (gvdwc_max.gt.1.0d4) then
9658           write (iout,*) "gvdwc gvdwx gradb gradbx"
9659           do i=nnt,nct
9660             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9661               gradb(j,i),gradbx(j,i),j=1,3)
9662           enddo
9663           call pdbout(0.0d0,'cipiszcze',iout)
9664           call flush(iout)
9665         endif
9666       endif
9667       endif
9668 !el#define DEBUG
9669 #ifdef DEBUG
9670       write (iout,*) "gradc gradx gloc"
9671       do i=1,nres
9672         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9673          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9674       enddo
9675 #endif
9676 !el#undef DEBUG
9677 #ifdef TIMING
9678       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9679 #endif
9680       return
9681       end subroutine sum_gradient
9682 !-----------------------------------------------------------------------------
9683       subroutine sc_grad
9684 !      implicit real*8 (a-h,o-z)
9685       use calc_data
9686 !      include 'DIMENSIONS'
9687 !      include 'COMMON.CHAIN'
9688 !      include 'COMMON.DERIV'
9689 !      include 'COMMON.CALC'
9690 !      include 'COMMON.IOUNITS'
9691       real(kind=8), dimension(3) :: dcosom1,dcosom2
9692
9693       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9694       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9695       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9696            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9697 ! diagnostics only
9698 !      eom1=0.0d0
9699 !      eom2=0.0d0
9700 !      eom12=evdwij*eps1_om12
9701 ! end diagnostics
9702 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9703 !       " sigder",sigder
9704 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9705 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9706 !C      print *,sss_ele_cut,'in sc_grad'
9707       do k=1,3
9708         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9709         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9710       enddo
9711       do k=1,3
9712         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9713 !C      print *,'gg',k,gg(k)
9714       enddo
9715 !      write (iout,*) "gg",(gg(k),k=1,3)
9716       do k=1,3
9717         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9718                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9719                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9720                   *sss_ele_cut
9721
9722         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9723                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9724                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9725                   *sss_ele_cut
9726
9727 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9728 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9729 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9730 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9731       enddo
9732 !
9733 ! Calculate the components of the gradient in DC and X
9734 !
9735 !grad      do k=i,j-1
9736 !grad        do l=1,3
9737 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9738 !grad        enddo
9739 !grad      enddo
9740       do l=1,3
9741         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9742         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9743       enddo
9744       return
9745       end subroutine sc_grad
9746 #ifdef CRYST_THETA
9747 !-----------------------------------------------------------------------------
9748       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9749
9750       use comm_calcthet
9751 !      implicit real*8 (a-h,o-z)
9752 !      include 'DIMENSIONS'
9753 !      include 'COMMON.LOCAL'
9754 !      include 'COMMON.IOUNITS'
9755 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9756 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9757 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9758       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9759       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9760 !el      integer :: it
9761 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9762 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9763 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9764 !el local variables
9765
9766       delthec=thetai-thet_pred_mean
9767       delthe0=thetai-theta0i
9768 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9769       t3 = thetai-thet_pred_mean
9770       t6 = t3**2
9771       t9 = term1
9772       t12 = t3*sigcsq
9773       t14 = t12+t6*sigsqtc
9774       t16 = 1.0d0
9775       t21 = thetai-theta0i
9776       t23 = t21**2
9777       t26 = term2
9778       t27 = t21*t26
9779       t32 = termexp
9780       t40 = t32**2
9781       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9782        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9783        *(-t12*t9-ak*sig0inv*t27)
9784       return
9785       end subroutine mixder
9786 #endif
9787 !-----------------------------------------------------------------------------
9788 ! cartder.F
9789 !-----------------------------------------------------------------------------
9790       subroutine cartder
9791 !-----------------------------------------------------------------------------
9792 ! This subroutine calculates the derivatives of the consecutive virtual
9793 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9794 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9795 ! in the angles alpha and omega, describing the location of a side chain
9796 ! in its local coordinate system.
9797 !
9798 ! The derivatives are stored in the following arrays:
9799 !
9800 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9801 ! The structure is as follows:
9802 !
9803 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9804 ! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4)
9805 !         . . . . . . . . . . . .  . . . . . .
9806 ! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4)
9807 !                          .
9808 !                          .
9809 !                          .
9810 ! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N)
9811 !
9812 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9813 ! The structure is same as above.
9814 !
9815 ! DCDS - the derivatives of the side chain vectors in the local spherical
9816 ! andgles alph and omega:
9817 !
9818 ! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2)
9819 ! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3)
9820 !                          .
9821 !                          .
9822 !                          .
9823 ! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1)
9824 !
9825 ! Version of March '95, based on an early version of November '91.
9826 !
9827 !**********************************************************************
9828 !      implicit real*8 (a-h,o-z)
9829 !      include 'DIMENSIONS'
9830 !      include 'COMMON.VAR'
9831 !      include 'COMMON.CHAIN'
9832 !      include 'COMMON.DERIV'
9833 !      include 'COMMON.GEO'
9834 !      include 'COMMON.LOCAL'
9835 !      include 'COMMON.INTERACT'
9836       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9837       real(kind=8),dimension(3,3) :: dp,temp
9838 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9839       real(kind=8),dimension(3) :: xx,xx1
9840 !el local variables
9841       integer :: i,k,l,j,m,ind,ind1,jjj
9842       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9843                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9844                  sint2,xp,yp,xxp,yyp,zzp,dj
9845
9846 !      common /przechowalnia/ fromto
9847       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9848 ! get the position of the jth ijth fragment of the chain coordinate system
9849 ! in the fromto array.
9850 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9851 !
9852 !      maxdim=(nres-1)*(nres-2)/2
9853 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9854 ! calculate the derivatives of transformation matrix elements in theta
9855 !
9856
9857 !el      call flush(iout) !el
9858       do i=1,nres-2
9859         rdt(1,1,i)=-rt(1,2,i)
9860         rdt(1,2,i)= rt(1,1,i)
9861         rdt(1,3,i)= 0.0d0
9862         rdt(2,1,i)=-rt(2,2,i)
9863         rdt(2,2,i)= rt(2,1,i)
9864         rdt(2,3,i)= 0.0d0
9865         rdt(3,1,i)=-rt(3,2,i)
9866         rdt(3,2,i)= rt(3,1,i)
9867         rdt(3,3,i)= 0.0d0
9868       enddo
9869 !
9870 ! derivatives in phi
9871 !
9872       do i=2,nres-2
9873         drt(1,1,i)= 0.0d0
9874         drt(1,2,i)= 0.0d0
9875         drt(1,3,i)= 0.0d0
9876         drt(2,1,i)= rt(3,1,i)
9877         drt(2,2,i)= rt(3,2,i)
9878         drt(2,3,i)= rt(3,3,i)
9879         drt(3,1,i)=-rt(2,1,i)
9880         drt(3,2,i)=-rt(2,2,i)
9881         drt(3,3,i)=-rt(2,3,i)
9882       enddo
9883 !
9884 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9885 !
9886       do i=2,nres-2
9887         ind=indmat(i,i+1)
9888         do k=1,3
9889           do l=1,3
9890             temp(k,l)=rt(k,l,i)
9891           enddo
9892         enddo
9893         do k=1,3
9894           do l=1,3
9895             fromto(k,l,ind)=temp(k,l)
9896           enddo
9897         enddo
9898         do j=i+1,nres-2
9899           ind=indmat(i,j+1)
9900           do k=1,3
9901             do l=1,3
9902               dpkl=0.0d0
9903               do m=1,3
9904                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9905               enddo
9906               dp(k,l)=dpkl
9907               fromto(k,l,ind)=dpkl
9908             enddo
9909           enddo
9910           do k=1,3
9911             do l=1,3
9912               temp(k,l)=dp(k,l)
9913             enddo
9914           enddo
9915         enddo
9916       enddo
9917 !
9918 ! Calculate derivatives.
9919 !
9920       ind1=0
9921       do i=1,nres-2
9922         ind1=ind1+1
9923 !
9924 ! Derivatives of DC(i+1) in theta(i+2)
9925 !
9926         do j=1,3
9927           do k=1,2
9928             dpjk=0.0D0
9929             do l=1,3
9930               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9931             enddo
9932             dp(j,k)=dpjk
9933             prordt(j,k,i)=dp(j,k)
9934           enddo
9935           dp(j,3)=0.0D0
9936           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9937         enddo
9938 !
9939 ! Derivatives of SC(i+1) in theta(i+2)
9940 !
9941         xx1(1)=-0.5D0*xloc(2,i+1)
9942         xx1(2)= 0.5D0*xloc(1,i+1)
9943         do j=1,3
9944           xj=0.0D0
9945           do k=1,2
9946             xj=xj+r(j,k,i)*xx1(k)
9947           enddo
9948           xx(j)=xj
9949         enddo
9950         do j=1,3
9951           rj=0.0D0
9952           do k=1,3
9953             rj=rj+prod(j,k,i)*xx(k)
9954           enddo
9955           dxdv(j,ind1)=rj
9956         enddo
9957 !
9958 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9959 ! than the other off-diagonal derivatives.
9960 !
9961         do j=1,3
9962           dxoiij=0.0D0
9963           do k=1,3
9964             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9965           enddo
9966           dxdv(j,ind1+1)=dxoiij
9967         enddo
9968 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9969 !
9970 ! Derivatives of DC(i+1) in phi(i+2)
9971 !
9972         do j=1,3
9973           do k=1,3
9974             dpjk=0.0
9975             do l=2,3
9976               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9977             enddo
9978             dp(j,k)=dpjk
9979             prodrt(j,k,i)=dp(j,k)
9980           enddo
9981           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9982         enddo
9983 !
9984 ! Derivatives of SC(i+1) in phi(i+2)
9985 !
9986         xx(1)= 0.0D0
9987         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9988         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9989         do j=1,3
9990           rj=0.0D0
9991           do k=2,3
9992             rj=rj+prod(j,k,i)*xx(k)
9993           enddo
9994           dxdv(j+3,ind1)=-rj
9995         enddo
9996 !
9997 ! Derivatives of SC(i+1) in phi(i+3).
9998 !
9999         do j=1,3
10000           dxoiij=0.0D0
10001           do k=1,3
10002             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10003           enddo
10004           dxdv(j+3,ind1+1)=dxoiij
10005         enddo
10006 !
10007 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10008 ! theta(nres) and phi(i+3) thru phi(nres).
10009 !
10010         do j=i+1,nres-2
10011           ind1=ind1+1
10012           ind=indmat(i+1,j+1)
10013 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10014           do k=1,3
10015             do l=1,3
10016               tempkl=0.0D0
10017               do m=1,2
10018                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10019               enddo
10020               temp(k,l)=tempkl
10021             enddo
10022           enddo
10023 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10024 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10025 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10026 ! Derivatives of virtual-bond vectors in theta
10027           do k=1,3
10028             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10029           enddo
10030 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10031 ! Derivatives of SC vectors in theta
10032           do k=1,3
10033             dxoijk=0.0D0
10034             do l=1,3
10035               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10036             enddo
10037             dxdv(k,ind1+1)=dxoijk
10038           enddo
10039 !
10040 !--- Calculate the derivatives in phi
10041 !
10042           do k=1,3
10043             do l=1,3
10044               tempkl=0.0D0
10045               do m=1,3
10046                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10047               enddo
10048               temp(k,l)=tempkl
10049             enddo
10050           enddo
10051           do k=1,3
10052             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10053           enddo
10054           do k=1,3
10055             dxoijk=0.0D0
10056             do l=1,3
10057               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10058             enddo
10059             dxdv(k+3,ind1+1)=dxoijk
10060           enddo
10061         enddo
10062       enddo
10063 !
10064 ! Derivatives in alpha and omega:
10065 !
10066       do i=2,nres-1
10067 !       dsci=dsc(itype(i))
10068         dsci=vbld(i+nres)
10069 #ifdef OSF
10070         alphi=alph(i)
10071         omegi=omeg(i)
10072         if(alphi.ne.alphi) alphi=100.0
10073         if(omegi.ne.omegi) omegi=-100.0
10074 #else
10075         alphi=alph(i)
10076         omegi=omeg(i)
10077 #endif
10078 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10079         cosalphi=dcos(alphi)
10080         sinalphi=dsin(alphi)
10081         cosomegi=dcos(omegi)
10082         sinomegi=dsin(omegi)
10083         temp(1,1)=-dsci*sinalphi
10084         temp(2,1)= dsci*cosalphi*cosomegi
10085         temp(3,1)=-dsci*cosalphi*sinomegi
10086         temp(1,2)=0.0D0
10087         temp(2,2)=-dsci*sinalphi*sinomegi
10088         temp(3,2)=-dsci*sinalphi*cosomegi
10089         theta2=pi-0.5D0*theta(i+1)
10090         cost2=dcos(theta2)
10091         sint2=dsin(theta2)
10092         jjj=0
10093 !d      print *,((temp(l,k),l=1,3),k=1,2)
10094         do j=1,2
10095           xp=temp(1,j)
10096           yp=temp(2,j)
10097           xxp= xp*cost2+yp*sint2
10098           yyp=-xp*sint2+yp*cost2
10099           zzp=temp(3,j)
10100           xx(1)=xxp
10101           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10102           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10103           do k=1,3
10104             dj=0.0D0
10105             do l=1,3
10106               dj=dj+prod(k,l,i-1)*xx(l)
10107             enddo
10108             dxds(jjj+k,i)=dj
10109           enddo
10110           jjj=jjj+3
10111         enddo
10112       enddo
10113       return
10114       end subroutine cartder
10115 !-----------------------------------------------------------------------------
10116 ! checkder_p.F
10117 !-----------------------------------------------------------------------------
10118       subroutine check_cartgrad
10119 ! Check the gradient of Cartesian coordinates in internal coordinates.
10120 !      implicit real*8 (a-h,o-z)
10121 !      include 'DIMENSIONS'
10122 !      include 'COMMON.IOUNITS'
10123 !      include 'COMMON.VAR'
10124 !      include 'COMMON.CHAIN'
10125 !      include 'COMMON.GEO'
10126 !      include 'COMMON.LOCAL'
10127 !      include 'COMMON.DERIV'
10128       real(kind=8),dimension(6,nres) :: temp
10129       real(kind=8),dimension(3) :: xx,gg
10130       integer :: i,k,j,ii
10131       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10132 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10133 !
10134 ! Check the gradient of the virtual-bond and SC vectors in the internal
10135 ! coordinates.
10136 !
10137       aincr=1.0d-7
10138       aincr2=5.0d-8
10139       call cartder
10140       write (iout,'(a)') '**************** dx/dalpha'
10141       write (iout,'(a)')
10142       do i=2,nres-1
10143         alphi=alph(i)
10144         alph(i)=alph(i)+aincr
10145         do k=1,3
10146           temp(k,i)=dc(k,nres+i)
10147         enddo
10148         call chainbuild
10149         do k=1,3
10150           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10151           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10152         enddo
10153         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10154         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10155         write (iout,'(a)')
10156         alph(i)=alphi
10157         call chainbuild
10158       enddo
10159       write (iout,'(a)')
10160       write (iout,'(a)') '**************** dx/domega'
10161       write (iout,'(a)')
10162       do i=2,nres-1
10163         omegi=omeg(i)
10164         omeg(i)=omeg(i)+aincr
10165         do k=1,3
10166           temp(k,i)=dc(k,nres+i)
10167         enddo
10168         call chainbuild
10169         do k=1,3
10170           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10171           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10172                 (aincr*dabs(dxds(k+3,i))+aincr))
10173         enddo
10174         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10175             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10176         write (iout,'(a)')
10177         omeg(i)=omegi
10178         call chainbuild
10179       enddo
10180       write (iout,'(a)')
10181       write (iout,'(a)') '**************** dx/dtheta'
10182       write (iout,'(a)')
10183       do i=3,nres
10184         theti=theta(i)
10185         theta(i)=theta(i)+aincr
10186         do j=i-1,nres-1
10187           do k=1,3
10188             temp(k,j)=dc(k,nres+j)
10189           enddo
10190         enddo
10191         call chainbuild
10192         do j=i-1,nres-1
10193           ii = indmat(i-2,j)
10194 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10195           do k=1,3
10196             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10197             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10198                   (aincr*dabs(dxdv(k,ii))+aincr))
10199           enddo
10200           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10201               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10202           write(iout,'(a)')
10203         enddo
10204         write (iout,'(a)')
10205         theta(i)=theti
10206         call chainbuild
10207       enddo
10208       write (iout,'(a)') '***************** dx/dphi'
10209       write (iout,'(a)')
10210       do i=4,nres
10211         phi(i)=phi(i)+aincr
10212         do j=i-1,nres-1
10213           do k=1,3
10214             temp(k,j)=dc(k,nres+j)
10215           enddo
10216         enddo
10217         call chainbuild
10218         do j=i-1,nres-1
10219           ii = indmat(i-2,j)
10220 !         print *,'ii=',ii
10221           do k=1,3
10222             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10223             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10224                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10225           enddo
10226           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10227               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10228           write(iout,'(a)')
10229         enddo
10230         phi(i)=phi(i)-aincr
10231         call chainbuild
10232       enddo
10233       write (iout,'(a)') '****************** ddc/dtheta'
10234       do i=1,nres-2
10235         thet=theta(i+2)
10236         theta(i+2)=thet+aincr
10237         do j=i,nres
10238           do k=1,3
10239             temp(k,j)=dc(k,j)
10240           enddo
10241         enddo
10242         call chainbuild
10243         do j=i+1,nres-1
10244           ii = indmat(i,j)
10245 !         print *,'ii=',ii
10246           do k=1,3
10247             gg(k)=(dc(k,j)-temp(k,j))/aincr
10248             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10249                  (aincr*dabs(dcdv(k,ii))+aincr))
10250           enddo
10251           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10252                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10253           write (iout,'(a)')
10254         enddo
10255         do j=1,nres
10256           do k=1,3
10257             dc(k,j)=temp(k,j)
10258           enddo
10259         enddo
10260         theta(i+2)=thet
10261       enddo
10262       write (iout,'(a)') '******************* ddc/dphi'
10263       do i=1,nres-3
10264         phii=phi(i+3)
10265         phi(i+3)=phii+aincr
10266         do j=1,nres
10267           do k=1,3
10268             temp(k,j)=dc(k,j)
10269           enddo
10270         enddo
10271         call chainbuild
10272         do j=i+2,nres-1
10273           ii = indmat(i+1,j)
10274 !         print *,'ii=',ii
10275           do k=1,3
10276             gg(k)=(dc(k,j)-temp(k,j))/aincr
10277             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10278                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10279           enddo
10280           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10281                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10282           write (iout,'(a)')
10283         enddo
10284         do j=1,nres
10285           do k=1,3
10286             dc(k,j)=temp(k,j)
10287           enddo
10288         enddo
10289         phi(i+3)=phii
10290       enddo
10291       return
10292       end subroutine check_cartgrad
10293 !-----------------------------------------------------------------------------
10294       subroutine check_ecart
10295 ! Check the gradient of the energy in Cartesian coordinates.
10296 !     implicit real*8 (a-h,o-z)
10297 !     include 'DIMENSIONS'
10298 !     include 'COMMON.CHAIN'
10299 !     include 'COMMON.DERIV'
10300 !     include 'COMMON.IOUNITS'
10301 !     include 'COMMON.VAR'
10302 !     include 'COMMON.CONTACTS'
10303       use comm_srutu
10304 !el      integer :: icall
10305 !el      common /srutu/ icall
10306       real(kind=8),dimension(6) :: ggg
10307       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10308       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10309       real(kind=8),dimension(6,nres) :: grad_s
10310       real(kind=8),dimension(0:n_ene) :: energia,energia1
10311       integer :: uiparm(1)
10312       real(kind=8) :: urparm(1)
10313 !EL      external fdum
10314       integer :: nf,i,j,k
10315       real(kind=8) :: aincr,etot,etot1
10316       icg=1
10317       nf=0
10318       nfl=0
10319       call zerograd
10320       aincr=1.0D-7
10321       print '(a)','CG processor',me,' calling CHECK_CART.'
10322       nf=0
10323       icall=0
10324       call geom_to_var(nvar,x)
10325       call etotal(energia)
10326       etot=energia(0)
10327 !el      call enerprint(energia)
10328       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10329       icall =1
10330       do i=1,nres
10331         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10332       enddo
10333       do i=1,nres
10334         do j=1,3
10335           grad_s(j,i)=gradc(j,i,icg)
10336           grad_s(j+3,i)=gradx(j,i,icg)
10337         enddo
10338       enddo
10339       call flush(iout)
10340       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10341       do i=1,nres
10342         do j=1,3
10343           xx(j)=c(j,i+nres)
10344           ddc(j)=dc(j,i)
10345           ddx(j)=dc(j,i+nres)
10346         enddo
10347         do j=1,3
10348           dc(j,i)=dc(j,i)+aincr
10349           do k=i+1,nres
10350             c(j,k)=c(j,k)+aincr
10351             c(j,k+nres)=c(j,k+nres)+aincr
10352           enddo
10353           call etotal(energia1)
10354           etot1=energia1(0)
10355           ggg(j)=(etot1-etot)/aincr
10356           dc(j,i)=ddc(j)
10357           do k=i+1,nres
10358             c(j,k)=c(j,k)-aincr
10359             c(j,k+nres)=c(j,k+nres)-aincr
10360           enddo
10361         enddo
10362         do j=1,3
10363           c(j,i+nres)=c(j,i+nres)+aincr
10364           dc(j,i+nres)=dc(j,i+nres)+aincr
10365           call etotal(energia1)
10366           etot1=energia1(0)
10367           ggg(j+3)=(etot1-etot)/aincr
10368           c(j,i+nres)=xx(j)
10369           dc(j,i+nres)=ddx(j)
10370         enddo
10371         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10372          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10373       enddo
10374       return
10375       end subroutine check_ecart
10376 #ifdef CARGRAD
10377 !-----------------------------------------------------------------------------
10378       subroutine check_ecartint
10379 ! Check the gradient of the energy in Cartesian coordinates.
10380       use io_base, only: intout
10381 !      implicit real*8 (a-h,o-z)
10382 !      include 'DIMENSIONS'
10383 !      include 'COMMON.CONTROL'
10384 !      include 'COMMON.CHAIN'
10385 !      include 'COMMON.DERIV'
10386 !      include 'COMMON.IOUNITS'
10387 !      include 'COMMON.VAR'
10388 !      include 'COMMON.CONTACTS'
10389 !      include 'COMMON.MD'
10390 !      include 'COMMON.LOCAL'
10391 !      include 'COMMON.SPLITELE'
10392       use comm_srutu
10393 !el      integer :: icall
10394 !el      common /srutu/ icall
10395       real(kind=8),dimension(6) :: ggg,ggg1
10396       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10397       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10398       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10399       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10400       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10401       real(kind=8),dimension(0:n_ene) :: energia,energia1
10402       integer :: uiparm(1)
10403       real(kind=8) :: urparm(1)
10404 !EL      external fdum
10405       integer :: i,j,k,nf
10406       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10407                    etot21,etot22
10408       r_cut=2.0d0
10409       rlambd=0.3d0
10410       icg=1
10411       nf=0
10412       nfl=0
10413       call intout
10414 !      call intcartderiv
10415 !      call checkintcartgrad
10416       call zerograd
10417       aincr=1.0D-5
10418       write(iout,*) 'Calling CHECK_ECARTINT.'
10419       nf=0
10420       icall=0
10421       write (iout,*) "Before geom_to_var"
10422       call geom_to_var(nvar,x)
10423       write (iout,*) "after geom_to_var"
10424       write (iout,*) "split_ene ",split_ene
10425       call flush(iout)
10426       if (.not.split_ene) then
10427         write(iout,*) 'Calling CHECK_ECARTINT if'
10428         call etotal(energia)
10429 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10430         etot=energia(0)
10431         write (iout,*) "etot",etot
10432         call flush(iout)
10433 !el        call enerprint(energia)
10434 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10435         call flush(iout)
10436         write (iout,*) "enter cartgrad"
10437         call flush(iout)
10438         call cartgrad
10439 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10440         write (iout,*) "exit cartgrad"
10441         call flush(iout)
10442         icall =1
10443         do i=1,nres
10444           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10445         enddo
10446         do j=1,3
10447           grad_s(j,0)=gcart(j,0)
10448         enddo
10449 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10450         do i=1,nres
10451           do j=1,3
10452             grad_s(j,i)=gcart(j,i)
10453             grad_s(j+3,i)=gxcart(j,i)
10454           enddo
10455         enddo
10456       else
10457 write(iout,*) 'Calling CHECK_ECARTIN else.'
10458 !- split gradient check
10459         call zerograd
10460         call etotal_long(energia)
10461 !el        call enerprint(energia)
10462         call flush(iout)
10463         write (iout,*) "enter cartgrad"
10464         call flush(iout)
10465         call cartgrad
10466         write (iout,*) "exit cartgrad"
10467         call flush(iout)
10468         icall =1
10469         write (iout,*) "longrange grad"
10470         do i=1,nres
10471           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10472           (gxcart(j,i),j=1,3)
10473         enddo
10474         do j=1,3
10475           grad_s(j,0)=gcart(j,0)
10476         enddo
10477         do i=1,nres
10478           do j=1,3
10479             grad_s(j,i)=gcart(j,i)
10480             grad_s(j+3,i)=gxcart(j,i)
10481           enddo
10482         enddo
10483         call zerograd
10484         call etotal_short(energia)
10485 !el        call enerprint(energia)
10486         call flush(iout)
10487         write (iout,*) "enter cartgrad"
10488         call flush(iout)
10489         call cartgrad
10490         write (iout,*) "exit cartgrad"
10491         call flush(iout)
10492         icall =1
10493         write (iout,*) "shortrange grad"
10494         do i=1,nres
10495           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10496           (gxcart(j,i),j=1,3)
10497         enddo
10498         do j=1,3
10499           grad_s1(j,0)=gcart(j,0)
10500         enddo
10501         do i=1,nres
10502           do j=1,3
10503             grad_s1(j,i)=gcart(j,i)
10504             grad_s1(j+3,i)=gxcart(j,i)
10505           enddo
10506         enddo
10507       endif
10508       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10509 !      do i=1,nres
10510       do i=nnt,nct
10511         do j=1,3
10512           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10513           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10514           ddc(j)=c(j,i)
10515           ddx(j)=c(j,i+nres)
10516           dcnorm_safe1(j)=dc_norm(j,i-1)
10517           dcnorm_safe2(j)=dc_norm(j,i)
10518           dxnorm_safe(j)=dc_norm(j,i+nres)
10519         enddo
10520         do j=1,3
10521           c(j,i)=ddc(j)+aincr
10522           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10523           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10524           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10525           dc(j,i)=c(j,i+1)-c(j,i)
10526           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10527           call int_from_cart1(.false.)
10528           if (.not.split_ene) then
10529             call etotal(energia1)
10530             etot1=energia1(0)
10531             write (iout,*) "ij",i,j," etot1",etot1
10532           else
10533 !- split gradient
10534             call etotal_long(energia1)
10535             etot11=energia1(0)
10536             call etotal_short(energia1)
10537             etot12=energia1(0)
10538           endif
10539 !- end split gradient
10540 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10541           c(j,i)=ddc(j)-aincr
10542           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10543           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10544           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10545           dc(j,i)=c(j,i+1)-c(j,i)
10546           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10547           call int_from_cart1(.false.)
10548           if (.not.split_ene) then
10549             call etotal(energia1)
10550             etot2=energia1(0)
10551             write (iout,*) "ij",i,j," etot2",etot2
10552             ggg(j)=(etot1-etot2)/(2*aincr)
10553           else
10554 !- split gradient
10555             call etotal_long(energia1)
10556             etot21=energia1(0)
10557             ggg(j)=(etot11-etot21)/(2*aincr)
10558             call etotal_short(energia1)
10559             etot22=energia1(0)
10560             ggg1(j)=(etot12-etot22)/(2*aincr)
10561 !- end split gradient
10562 !            write (iout,*) "etot21",etot21," etot22",etot22
10563           endif
10564 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10565           c(j,i)=ddc(j)
10566           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10567           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10568           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10569           dc(j,i)=c(j,i+1)-c(j,i)
10570           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10571           dc_norm(j,i-1)=dcnorm_safe1(j)
10572           dc_norm(j,i)=dcnorm_safe2(j)
10573           dc_norm(j,i+nres)=dxnorm_safe(j)
10574         enddo
10575         do j=1,3
10576           c(j,i+nres)=ddx(j)+aincr
10577           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10578           call int_from_cart1(.false.)
10579           if (.not.split_ene) then
10580             call etotal(energia1)
10581             etot1=energia1(0)
10582           else
10583 !- split gradient
10584             call etotal_long(energia1)
10585             etot11=energia1(0)
10586             call etotal_short(energia1)
10587             etot12=energia1(0)
10588           endif
10589 !- end split gradient
10590           c(j,i+nres)=ddx(j)-aincr
10591           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10592           call int_from_cart1(.false.)
10593           if (.not.split_ene) then
10594             call etotal(energia1)
10595             etot2=energia1(0)
10596             ggg(j+3)=(etot1-etot2)/(2*aincr)
10597           else
10598 !- split gradient
10599             call etotal_long(energia1)
10600             etot21=energia1(0)
10601             ggg(j+3)=(etot11-etot21)/(2*aincr)
10602             call etotal_short(energia1)
10603             etot22=energia1(0)
10604             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10605 !- end split gradient
10606           endif
10607 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10608           c(j,i+nres)=ddx(j)
10609           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10610           dc_norm(j,i+nres)=dxnorm_safe(j)
10611           call int_from_cart1(.false.)
10612         enddo
10613         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10614          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10615         if (split_ene) then
10616           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10617          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10618          k=1,6)
10619          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10620          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10621          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10622         endif
10623       enddo
10624       return
10625       end subroutine check_ecartint
10626 #else
10627 !-----------------------------------------------------------------------------
10628       subroutine check_ecartint
10629 ! Check the gradient of the energy in Cartesian coordinates.
10630       use io_base, only: intout
10631 !      implicit real*8 (a-h,o-z)
10632 !      include 'DIMENSIONS'
10633 !      include 'COMMON.CONTROL'
10634 !      include 'COMMON.CHAIN'
10635 !      include 'COMMON.DERIV'
10636 !      include 'COMMON.IOUNITS'
10637 !      include 'COMMON.VAR'
10638 !      include 'COMMON.CONTACTS'
10639 !      include 'COMMON.MD'
10640 !      include 'COMMON.LOCAL'
10641 !      include 'COMMON.SPLITELE'
10642       use comm_srutu
10643 !el      integer :: icall
10644 !el      common /srutu/ icall
10645       real(kind=8),dimension(6) :: ggg,ggg1
10646       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10647       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10648       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10649       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10650       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10651       real(kind=8),dimension(0:n_ene) :: energia,energia1
10652       integer :: uiparm(1)
10653       real(kind=8) :: urparm(1)
10654 !EL      external fdum
10655       integer :: i,j,k,nf
10656       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10657                    etot21,etot22
10658       r_cut=2.0d0
10659       rlambd=0.3d0
10660       icg=1
10661       nf=0
10662       nfl=0
10663       call intout
10664 !      call intcartderiv
10665 !      call checkintcartgrad
10666       call zerograd
10667       aincr=1.0D-6
10668       write(iout,*) 'Calling CHECK_ECARTINT.'
10669       nf=0
10670       icall=0
10671       call geom_to_var(nvar,x)
10672       if (.not.split_ene) then
10673         call etotal(energia)
10674         etot=energia(0)
10675 !el        call enerprint(energia)
10676         call flush(iout)
10677         write (iout,*) "enter cartgrad"
10678         call flush(iout)
10679         call cartgrad
10680         write (iout,*) "exit cartgrad"
10681         call flush(iout)
10682         icall =1
10683         do i=1,nres
10684           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10685         enddo
10686         do j=1,3
10687           grad_s(j,0)=gcart(j,0)
10688         enddo
10689         do i=1,nres
10690           do j=1,3
10691             grad_s(j,i)=gcart(j,i)
10692             grad_s(j+3,i)=gxcart(j,i)
10693           enddo
10694         enddo
10695       else
10696 !- split gradient check
10697         call zerograd
10698         call etotal_long(energia)
10699 !el        call enerprint(energia)
10700         call flush(iout)
10701         write (iout,*) "enter cartgrad"
10702         call flush(iout)
10703         call cartgrad
10704         write (iout,*) "exit cartgrad"
10705         call flush(iout)
10706         icall =1
10707         write (iout,*) "longrange grad"
10708         do i=1,nres
10709           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10710           (gxcart(j,i),j=1,3)
10711         enddo
10712         do j=1,3
10713           grad_s(j,0)=gcart(j,0)
10714         enddo
10715         do i=1,nres
10716           do j=1,3
10717             grad_s(j,i)=gcart(j,i)
10718             grad_s(j+3,i)=gxcart(j,i)
10719           enddo
10720         enddo
10721         call zerograd
10722         call etotal_short(energia)
10723 !el        call enerprint(energia)
10724         call flush(iout)
10725         write (iout,*) "enter cartgrad"
10726         call flush(iout)
10727         call cartgrad
10728         write (iout,*) "exit cartgrad"
10729         call flush(iout)
10730         icall =1
10731         write (iout,*) "shortrange grad"
10732         do i=1,nres
10733           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10734           (gxcart(j,i),j=1,3)
10735         enddo
10736         do j=1,3
10737           grad_s1(j,0)=gcart(j,0)
10738         enddo
10739         do i=1,nres
10740           do j=1,3
10741             grad_s1(j,i)=gcart(j,i)
10742             grad_s1(j+3,i)=gxcart(j,i)
10743           enddo
10744         enddo
10745       endif
10746       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10747       do i=0,nres
10748         do j=1,3
10749           xx(j)=c(j,i+nres)
10750           ddc(j)=dc(j,i)
10751           ddx(j)=dc(j,i+nres)
10752           do k=1,3
10753             dcnorm_safe(k)=dc_norm(k,i)
10754             dxnorm_safe(k)=dc_norm(k,i+nres)
10755           enddo
10756         enddo
10757         do j=1,3
10758           dc(j,i)=ddc(j)+aincr
10759           call chainbuild_cart
10760 #ifdef MPI
10761 ! Broadcast the order to compute internal coordinates to the slaves.
10762 !          if (nfgtasks.gt.1)
10763 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10764 #endif
10765 !          call int_from_cart1(.false.)
10766           if (.not.split_ene) then
10767             call etotal(energia1)
10768             etot1=energia1(0)
10769           else
10770 !- split gradient
10771             call etotal_long(energia1)
10772             etot11=energia1(0)
10773             call etotal_short(energia1)
10774             etot12=energia1(0)
10775 !            write (iout,*) "etot11",etot11," etot12",etot12
10776           endif
10777 !- end split gradient
10778 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10779           dc(j,i)=ddc(j)-aincr
10780           call chainbuild_cart
10781 !          call int_from_cart1(.false.)
10782           if (.not.split_ene) then
10783             call etotal(energia1)
10784             etot2=energia1(0)
10785             ggg(j)=(etot1-etot2)/(2*aincr)
10786           else
10787 !- split gradient
10788             call etotal_long(energia1)
10789             etot21=energia1(0)
10790             ggg(j)=(etot11-etot21)/(2*aincr)
10791             call etotal_short(energia1)
10792             etot22=energia1(0)
10793             ggg1(j)=(etot12-etot22)/(2*aincr)
10794 !- end split gradient
10795 !            write (iout,*) "etot21",etot21," etot22",etot22
10796           endif
10797 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10798           dc(j,i)=ddc(j)
10799           call chainbuild_cart
10800         enddo
10801         do j=1,3
10802           dc(j,i+nres)=ddx(j)+aincr
10803           call chainbuild_cart
10804 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10805 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10806 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10807 !          write (iout,*) "dxnormnorm",dsqrt(
10808 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10809 !          write (iout,*) "dxnormnormsafe",dsqrt(
10810 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10811 !          write (iout,*)
10812           if (.not.split_ene) then
10813             call etotal(energia1)
10814             etot1=energia1(0)
10815           else
10816 !- split gradient
10817             call etotal_long(energia1)
10818             etot11=energia1(0)
10819             call etotal_short(energia1)
10820             etot12=energia1(0)
10821           endif
10822 !- end split gradient
10823 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10824           dc(j,i+nres)=ddx(j)-aincr
10825           call chainbuild_cart
10826 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10827 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10828 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10829 !          write (iout,*)
10830 !          write (iout,*) "dxnormnorm",dsqrt(
10831 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10832 !          write (iout,*) "dxnormnormsafe",dsqrt(
10833 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10834           if (.not.split_ene) then
10835             call etotal(energia1)
10836             etot2=energia1(0)
10837             ggg(j+3)=(etot1-etot2)/(2*aincr)
10838           else
10839 !- split gradient
10840             call etotal_long(energia1)
10841             etot21=energia1(0)
10842             ggg(j+3)=(etot11-etot21)/(2*aincr)
10843             call etotal_short(energia1)
10844             etot22=energia1(0)
10845             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10846 !- end split gradient
10847           endif
10848 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10849           dc(j,i+nres)=ddx(j)
10850           call chainbuild_cart
10851         enddo
10852         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10853          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10854         if (split_ene) then
10855           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10856          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10857          k=1,6)
10858          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10859          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10860          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10861         endif
10862       enddo
10863       return
10864       end subroutine check_ecartint
10865 #endif
10866 !-----------------------------------------------------------------------------
10867       subroutine check_eint
10868 ! Check the gradient of energy in internal coordinates.
10869 !      implicit real*8 (a-h,o-z)
10870 !      include 'DIMENSIONS'
10871 !      include 'COMMON.CHAIN'
10872 !      include 'COMMON.DERIV'
10873 !      include 'COMMON.IOUNITS'
10874 !      include 'COMMON.VAR'
10875 !      include 'COMMON.GEO'
10876       use comm_srutu
10877 !el      integer :: icall
10878 !el      common /srutu/ icall
10879       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10880       integer :: uiparm(1)
10881       real(kind=8) :: urparm(1)
10882       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10883       character(len=6) :: key
10884 !EL      external fdum
10885       integer :: i,ii,nf
10886       real(kind=8) :: xi,aincr,etot,etot1,etot2
10887       call zerograd
10888       aincr=1.0D-7
10889       print '(a)','Calling CHECK_INT.'
10890       nf=0
10891       nfl=0
10892       icg=1
10893       call geom_to_var(nvar,x)
10894       call var_to_geom(nvar,x)
10895       call chainbuild
10896       icall=1
10897       print *,'ICG=',ICG
10898       call etotal(energia)
10899       etot = energia(0)
10900 !el      call enerprint(energia)
10901       print *,'ICG=',ICG
10902 #ifdef MPL
10903       if (MyID.ne.BossID) then
10904         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10905         nf=x(nvar+1)
10906         nfl=x(nvar+2)
10907         icg=x(nvar+3)
10908       endif
10909 #endif
10910       nf=1
10911       nfl=3
10912 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10913       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10914 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10915       icall=1
10916       do i=1,nvar
10917         xi=x(i)
10918         x(i)=xi-0.5D0*aincr
10919         call var_to_geom(nvar,x)
10920         call chainbuild
10921         call etotal(energia1)
10922         etot1=energia1(0)
10923         x(i)=xi+0.5D0*aincr
10924         call var_to_geom(nvar,x)
10925         call chainbuild
10926         call etotal(energia2)
10927         etot2=energia2(0)
10928         gg(i)=(etot2-etot1)/aincr
10929         write (iout,*) i,etot1,etot2
10930         x(i)=xi
10931       enddo
10932       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10933           '     RelDiff*100% '
10934       do i=1,nvar
10935         if (i.le.nphi) then
10936           ii=i
10937           key = ' phi'
10938         else if (i.le.nphi+ntheta) then
10939           ii=i-nphi
10940           key=' theta'
10941         else if (i.le.nphi+ntheta+nside) then
10942            ii=i-(nphi+ntheta)
10943            key=' alpha'
10944         else
10945            ii=i-(nphi+ntheta+nside)
10946            key=' omega'
10947         endif
10948         write (iout,'(i3,a,i3,3(1pd16.6))') &
10949        i,key,ii,gg(i),gana(i),&
10950        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10951       enddo
10952       return
10953       end subroutine check_eint
10954 !-----------------------------------------------------------------------------
10955 ! econstr_local.F
10956 !-----------------------------------------------------------------------------
10957       subroutine Econstr_back
10958 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10959 !      implicit real*8 (a-h,o-z)
10960 !      include 'DIMENSIONS'
10961 !      include 'COMMON.CONTROL'
10962 !      include 'COMMON.VAR'
10963 !      include 'COMMON.MD'
10964       use MD_data
10965 !#ifndef LANG0
10966 !      include 'COMMON.LANGEVIN'
10967 !#else
10968 !      include 'COMMON.LANGEVIN.lang0'
10969 !#endif
10970 !      include 'COMMON.CHAIN'
10971 !      include 'COMMON.DERIV'
10972 !      include 'COMMON.GEO'
10973 !      include 'COMMON.LOCAL'
10974 !      include 'COMMON.INTERACT'
10975 !      include 'COMMON.IOUNITS'
10976 !      include 'COMMON.NAMES'
10977 !      include 'COMMON.TIME1'
10978       integer :: i,j,ii,k
10979       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10980
10981       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10982       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10983       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10984
10985       Uconst_back=0.0d0
10986       do i=1,nres
10987         dutheta(i)=0.0d0
10988         dugamma(i)=0.0d0
10989         do j=1,3
10990           duscdiff(j,i)=0.0d0
10991           duscdiffx(j,i)=0.0d0
10992         enddo
10993       enddo
10994       do i=1,nfrag_back
10995         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10996 !
10997 ! Deviations from theta angles
10998 !
10999         utheta_i=0.0d0
11000         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11001           dtheta_i=theta(j)-thetaref(j)
11002           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11003           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11004         enddo
11005         utheta(i)=utheta_i/(ii-1)
11006 !
11007 ! Deviations from gamma angles
11008 !
11009         ugamma_i=0.0d0
11010         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11011           dgamma_i=pinorm(phi(j)-phiref(j))
11012 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11013           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11014           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11015 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11016         enddo
11017         ugamma(i)=ugamma_i/(ii-2)
11018 !
11019 ! Deviations from local SC geometry
11020 !
11021         uscdiff(i)=0.0d0
11022         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11023           dxx=xxtab(j)-xxref(j)
11024           dyy=yytab(j)-yyref(j)
11025           dzz=zztab(j)-zzref(j)
11026           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11027           do k=1,3
11028             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11029              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11030              (ii-1)
11031             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11032              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11033              (ii-1)
11034             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11035            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11036             /(ii-1)
11037           enddo
11038 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11039 !     &      xxref(j),yyref(j),zzref(j)
11040         enddo
11041         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11042 !        write (iout,*) i," uscdiff",uscdiff(i)
11043 !
11044 ! Put together deviations from local geometry
11045 !
11046         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11047           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11048 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11049 !     &   " uconst_back",uconst_back
11050         utheta(i)=dsqrt(utheta(i))
11051         ugamma(i)=dsqrt(ugamma(i))
11052         uscdiff(i)=dsqrt(uscdiff(i))
11053       enddo
11054       return
11055       end subroutine Econstr_back
11056 !-----------------------------------------------------------------------------
11057 ! energy_p_new-sep_barrier.F
11058 !-----------------------------------------------------------------------------
11059       real(kind=8) function sscale(r)
11060 !      include "COMMON.SPLITELE"
11061       real(kind=8) :: r,gamm
11062       if(r.lt.r_cut-rlamb) then
11063         sscale=1.0d0
11064       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11065         gamm=(r-(r_cut-rlamb))/rlamb
11066         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11067       else
11068         sscale=0d0
11069       endif
11070       return
11071       end function sscale
11072       real(kind=8) function sscale_grad(r)
11073 !      include "COMMON.SPLITELE"
11074       real(kind=8) :: r,gamm
11075       if(r.lt.r_cut-rlamb) then
11076         sscale_grad=0.0d0
11077       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11078         gamm=(r-(r_cut-rlamb))/rlamb
11079         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11080       else
11081         sscale_grad=0d0
11082       endif
11083       return
11084       end function sscale_grad
11085
11086 !!!!!!!!!! PBCSCALE
11087       real(kind=8) function sscale_ele(r)
11088 !      include "COMMON.SPLITELE"
11089       real(kind=8) :: r,gamm
11090       if(r.lt.r_cut_ele-rlamb_ele) then
11091         sscale_ele=1.0d0
11092       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11093         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11094         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11095       else
11096         sscale_ele=0d0
11097       endif
11098       return
11099       end function sscale_ele
11100
11101       real(kind=8)  function sscagrad_ele(r)
11102       real(kind=8) :: r,gamm
11103 !      include "COMMON.SPLITELE"
11104       if(r.lt.r_cut_ele-rlamb_ele) then
11105         sscagrad_ele=0.0d0
11106       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11107         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11108         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11109       else
11110         sscagrad_ele=0.0d0
11111       endif
11112       return
11113       end function sscagrad_ele
11114 !!!!!!!!!!!!!!!
11115 !-----------------------------------------------------------------------------
11116       subroutine elj_long(evdw)
11117 !
11118 ! This subroutine calculates the interaction energy of nonbonded side chains
11119 ! assuming the LJ potential of interaction.
11120 !
11121 !      implicit real*8 (a-h,o-z)
11122 !      include 'DIMENSIONS'
11123 !      include 'COMMON.GEO'
11124 !      include 'COMMON.VAR'
11125 !      include 'COMMON.LOCAL'
11126 !      include 'COMMON.CHAIN'
11127 !      include 'COMMON.DERIV'
11128 !      include 'COMMON.INTERACT'
11129 !      include 'COMMON.TORSION'
11130 !      include 'COMMON.SBRIDGE'
11131 !      include 'COMMON.NAMES'
11132 !      include 'COMMON.IOUNITS'
11133 !      include 'COMMON.CONTACTS'
11134       real(kind=8),parameter :: accur=1.0d-10
11135       real(kind=8),dimension(3) :: gg
11136 !el local variables
11137       integer :: i,iint,j,k,itypi,itypi1,itypj
11138       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11139       real(kind=8) :: e1,e2,evdwij,evdw
11140 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11141       evdw=0.0D0
11142       do i=iatsc_s,iatsc_e
11143         itypi=itype(i)
11144         if (itypi.eq.ntyp1) cycle
11145         itypi1=itype(i+1)
11146         xi=c(1,nres+i)
11147         yi=c(2,nres+i)
11148         zi=c(3,nres+i)
11149 !
11150 ! Calculate SC interaction energy.
11151 !
11152         do iint=1,nint_gr(i)
11153 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11154 !d   &                  'iend=',iend(i,iint)
11155           do j=istart(i,iint),iend(i,iint)
11156             itypj=itype(j)
11157             if (itypj.eq.ntyp1) cycle
11158             xj=c(1,nres+j)-xi
11159             yj=c(2,nres+j)-yi
11160             zj=c(3,nres+j)-zi
11161             rij=xj*xj+yj*yj+zj*zj
11162             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11163             if (sss.lt.1.0d0) then
11164               rrij=1.0D0/rij
11165               eps0ij=eps(itypi,itypj)
11166               fac=rrij**expon2
11167               e1=fac*fac*aa(itypi,itypj)
11168               e2=fac*bb(itypi,itypj)
11169               evdwij=e1+e2
11170               evdw=evdw+(1.0d0-sss)*evdwij
11171 !
11172 ! Calculate the components of the gradient in DC and X
11173 !
11174               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11175               gg(1)=xj*fac
11176               gg(2)=yj*fac
11177               gg(3)=zj*fac
11178               do k=1,3
11179                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11180                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11181                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11182                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11183               enddo
11184             endif
11185           enddo      ! j
11186         enddo        ! iint
11187       enddo          ! i
11188       do i=1,nct
11189         do j=1,3
11190           gvdwc(j,i)=expon*gvdwc(j,i)
11191           gvdwx(j,i)=expon*gvdwx(j,i)
11192         enddo
11193       enddo
11194 !******************************************************************************
11195 !
11196 !                              N O T E !!!
11197 !
11198 ! To save time, the factor of EXPON has been extracted from ALL components
11199 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11200 ! use!
11201 !
11202 !******************************************************************************
11203       return
11204       end subroutine elj_long
11205 !-----------------------------------------------------------------------------
11206       subroutine elj_short(evdw)
11207 !
11208 ! This subroutine calculates the interaction energy of nonbonded side chains
11209 ! assuming the LJ potential of interaction.
11210 !
11211 !      implicit real*8 (a-h,o-z)
11212 !      include 'DIMENSIONS'
11213 !      include 'COMMON.GEO'
11214 !      include 'COMMON.VAR'
11215 !      include 'COMMON.LOCAL'
11216 !      include 'COMMON.CHAIN'
11217 !      include 'COMMON.DERIV'
11218 !      include 'COMMON.INTERACT'
11219 !      include 'COMMON.TORSION'
11220 !      include 'COMMON.SBRIDGE'
11221 !      include 'COMMON.NAMES'
11222 !      include 'COMMON.IOUNITS'
11223 !      include 'COMMON.CONTACTS'
11224       real(kind=8),parameter :: accur=1.0d-10
11225       real(kind=8),dimension(3) :: gg
11226 !el local variables
11227       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11228       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11229       real(kind=8) :: e1,e2,evdwij,evdw
11230 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11231       evdw=0.0D0
11232       do i=iatsc_s,iatsc_e
11233         itypi=itype(i)
11234         if (itypi.eq.ntyp1) cycle
11235         itypi1=itype(i+1)
11236         xi=c(1,nres+i)
11237         yi=c(2,nres+i)
11238         zi=c(3,nres+i)
11239 ! Change 12/1/95
11240         num_conti=0
11241 !
11242 ! Calculate SC interaction energy.
11243 !
11244         do iint=1,nint_gr(i)
11245 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11246 !d   &                  'iend=',iend(i,iint)
11247           do j=istart(i,iint),iend(i,iint)
11248             itypj=itype(j)
11249             if (itypj.eq.ntyp1) cycle
11250             xj=c(1,nres+j)-xi
11251             yj=c(2,nres+j)-yi
11252             zj=c(3,nres+j)-zi
11253 ! Change 12/1/95 to calculate four-body interactions
11254             rij=xj*xj+yj*yj+zj*zj
11255             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11256             if (sss.gt.0.0d0) then
11257               rrij=1.0D0/rij
11258               eps0ij=eps(itypi,itypj)
11259               fac=rrij**expon2
11260               e1=fac*fac*aa(itypi,itypj)
11261               e2=fac*bb(itypi,itypj)
11262               evdwij=e1+e2
11263               evdw=evdw+sss*evdwij
11264 !
11265 ! Calculate the components of the gradient in DC and X
11266 !
11267               fac=-rrij*(e1+evdwij)*sss
11268               gg(1)=xj*fac
11269               gg(2)=yj*fac
11270               gg(3)=zj*fac
11271               do k=1,3
11272                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11273                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11274                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11275                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11276               enddo
11277             endif
11278           enddo      ! j
11279         enddo        ! iint
11280       enddo          ! i
11281       do i=1,nct
11282         do j=1,3
11283           gvdwc(j,i)=expon*gvdwc(j,i)
11284           gvdwx(j,i)=expon*gvdwx(j,i)
11285         enddo
11286       enddo
11287 !******************************************************************************
11288 !
11289 !                              N O T E !!!
11290 !
11291 ! To save time, the factor of EXPON has been extracted from ALL components
11292 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11293 ! use!
11294 !
11295 !******************************************************************************
11296       return
11297       end subroutine elj_short
11298 !-----------------------------------------------------------------------------
11299       subroutine eljk_long(evdw)
11300 !
11301 ! This subroutine calculates the interaction energy of nonbonded side chains
11302 ! assuming the LJK potential of interaction.
11303 !
11304 !      implicit real*8 (a-h,o-z)
11305 !      include 'DIMENSIONS'
11306 !      include 'COMMON.GEO'
11307 !      include 'COMMON.VAR'
11308 !      include 'COMMON.LOCAL'
11309 !      include 'COMMON.CHAIN'
11310 !      include 'COMMON.DERIV'
11311 !      include 'COMMON.INTERACT'
11312 !      include 'COMMON.IOUNITS'
11313 !      include 'COMMON.NAMES'
11314       real(kind=8),dimension(3) :: gg
11315       logical :: scheck
11316 !el local variables
11317       integer :: i,iint,j,k,itypi,itypi1,itypj
11318       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11319                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11320 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11321       evdw=0.0D0
11322       do i=iatsc_s,iatsc_e
11323         itypi=itype(i)
11324         if (itypi.eq.ntyp1) cycle
11325         itypi1=itype(i+1)
11326         xi=c(1,nres+i)
11327         yi=c(2,nres+i)
11328         zi=c(3,nres+i)
11329 !
11330 ! Calculate SC interaction energy.
11331 !
11332         do iint=1,nint_gr(i)
11333           do j=istart(i,iint),iend(i,iint)
11334             itypj=itype(j)
11335             if (itypj.eq.ntyp1) cycle
11336             xj=c(1,nres+j)-xi
11337             yj=c(2,nres+j)-yi
11338             zj=c(3,nres+j)-zi
11339             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11340             fac_augm=rrij**expon
11341             e_augm=augm(itypi,itypj)*fac_augm
11342             r_inv_ij=dsqrt(rrij)
11343             rij=1.0D0/r_inv_ij
11344             sss=sscale(rij/sigma(itypi,itypj))
11345             if (sss.lt.1.0d0) then
11346               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11347               fac=r_shift_inv**expon
11348               e1=fac*fac*aa(itypi,itypj)
11349               e2=fac*bb(itypi,itypj)
11350               evdwij=e_augm+e1+e2
11351 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11352 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11353 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11354 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11355 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11356 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11357 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11358               evdw=evdw+(1.0d0-sss)*evdwij
11359 !
11360 ! Calculate the components of the gradient in DC and X
11361 !
11362               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11363               fac=fac*(1.0d0-sss)
11364               gg(1)=xj*fac
11365               gg(2)=yj*fac
11366               gg(3)=zj*fac
11367               do k=1,3
11368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11372               enddo
11373             endif
11374           enddo      ! j
11375         enddo        ! iint
11376       enddo          ! i
11377       do i=1,nct
11378         do j=1,3
11379           gvdwc(j,i)=expon*gvdwc(j,i)
11380           gvdwx(j,i)=expon*gvdwx(j,i)
11381         enddo
11382       enddo
11383       return
11384       end subroutine eljk_long
11385 !-----------------------------------------------------------------------------
11386       subroutine eljk_short(evdw)
11387 !
11388 ! This subroutine calculates the interaction energy of nonbonded side chains
11389 ! assuming the LJK potential of interaction.
11390 !
11391 !      implicit real*8 (a-h,o-z)
11392 !      include 'DIMENSIONS'
11393 !      include 'COMMON.GEO'
11394 !      include 'COMMON.VAR'
11395 !      include 'COMMON.LOCAL'
11396 !      include 'COMMON.CHAIN'
11397 !      include 'COMMON.DERIV'
11398 !      include 'COMMON.INTERACT'
11399 !      include 'COMMON.IOUNITS'
11400 !      include 'COMMON.NAMES'
11401       real(kind=8),dimension(3) :: gg
11402       logical :: scheck
11403 !el local variables
11404       integer :: i,iint,j,k,itypi,itypi1,itypj
11405       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11406                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11407 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11408       evdw=0.0D0
11409       do i=iatsc_s,iatsc_e
11410         itypi=itype(i)
11411         if (itypi.eq.ntyp1) cycle
11412         itypi1=itype(i+1)
11413         xi=c(1,nres+i)
11414         yi=c(2,nres+i)
11415         zi=c(3,nres+i)
11416 !
11417 ! Calculate SC interaction energy.
11418 !
11419         do iint=1,nint_gr(i)
11420           do j=istart(i,iint),iend(i,iint)
11421             itypj=itype(j)
11422             if (itypj.eq.ntyp1) cycle
11423             xj=c(1,nres+j)-xi
11424             yj=c(2,nres+j)-yi
11425             zj=c(3,nres+j)-zi
11426             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11427             fac_augm=rrij**expon
11428             e_augm=augm(itypi,itypj)*fac_augm
11429             r_inv_ij=dsqrt(rrij)
11430             rij=1.0D0/r_inv_ij
11431             sss=sscale(rij/sigma(itypi,itypj))
11432             if (sss.gt.0.0d0) then
11433               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11434               fac=r_shift_inv**expon
11435               e1=fac*fac*aa(itypi,itypj)
11436               e2=fac*bb(itypi,itypj)
11437               evdwij=e_augm+e1+e2
11438 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11439 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11440 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11441 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11442 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11443 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11444 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11445               evdw=evdw+sss*evdwij
11446 !
11447 ! Calculate the components of the gradient in DC and X
11448 !
11449               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11450               fac=fac*sss
11451               gg(1)=xj*fac
11452               gg(2)=yj*fac
11453               gg(3)=zj*fac
11454               do k=1,3
11455                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11456                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11457                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11458                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11459               enddo
11460             endif
11461           enddo      ! j
11462         enddo        ! iint
11463       enddo          ! i
11464       do i=1,nct
11465         do j=1,3
11466           gvdwc(j,i)=expon*gvdwc(j,i)
11467           gvdwx(j,i)=expon*gvdwx(j,i)
11468         enddo
11469       enddo
11470       return
11471       end subroutine eljk_short
11472 !-----------------------------------------------------------------------------
11473       subroutine ebp_long(evdw)
11474 !
11475 ! This subroutine calculates the interaction energy of nonbonded side chains
11476 ! assuming the Berne-Pechukas potential of interaction.
11477 !
11478       use calc_data
11479 !      implicit real*8 (a-h,o-z)
11480 !      include 'DIMENSIONS'
11481 !      include 'COMMON.GEO'
11482 !      include 'COMMON.VAR'
11483 !      include 'COMMON.LOCAL'
11484 !      include 'COMMON.CHAIN'
11485 !      include 'COMMON.DERIV'
11486 !      include 'COMMON.NAMES'
11487 !      include 'COMMON.INTERACT'
11488 !      include 'COMMON.IOUNITS'
11489 !      include 'COMMON.CALC'
11490       use comm_srutu
11491 !el      integer :: icall
11492 !el      common /srutu/ icall
11493 !     double precision rrsave(maxdim)
11494       logical :: lprn
11495 !el local variables
11496       integer :: iint,itypi,itypi1,itypj
11497       real(kind=8) :: rrij,xi,yi,zi,fac
11498       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11499       evdw=0.0D0
11500 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11501       evdw=0.0D0
11502 !     if (icall.eq.0) then
11503 !       lprn=.true.
11504 !     else
11505         lprn=.false.
11506 !     endif
11507 !el      ind=0
11508       do i=iatsc_s,iatsc_e
11509         itypi=itype(i)
11510         if (itypi.eq.ntyp1) cycle
11511         itypi1=itype(i+1)
11512         xi=c(1,nres+i)
11513         yi=c(2,nres+i)
11514         zi=c(3,nres+i)
11515         dxi=dc_norm(1,nres+i)
11516         dyi=dc_norm(2,nres+i)
11517         dzi=dc_norm(3,nres+i)
11518 !        dsci_inv=dsc_inv(itypi)
11519         dsci_inv=vbld_inv(i+nres)
11520 !
11521 ! Calculate SC interaction energy.
11522 !
11523         do iint=1,nint_gr(i)
11524           do j=istart(i,iint),iend(i,iint)
11525 !el            ind=ind+1
11526             itypj=itype(j)
11527             if (itypj.eq.ntyp1) cycle
11528 !            dscj_inv=dsc_inv(itypj)
11529             dscj_inv=vbld_inv(j+nres)
11530             chi1=chi(itypi,itypj)
11531             chi2=chi(itypj,itypi)
11532             chi12=chi1*chi2
11533             chip1=chip(itypi)
11534             chip2=chip(itypj)
11535             chip12=chip1*chip2
11536             alf1=alp(itypi)
11537             alf2=alp(itypj)
11538             alf12=0.5D0*(alf1+alf2)
11539             xj=c(1,nres+j)-xi
11540             yj=c(2,nres+j)-yi
11541             zj=c(3,nres+j)-zi
11542             dxj=dc_norm(1,nres+j)
11543             dyj=dc_norm(2,nres+j)
11544             dzj=dc_norm(3,nres+j)
11545             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11546             rij=dsqrt(rrij)
11547             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11548
11549             if (sss.lt.1.0d0) then
11550
11551 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11552               call sc_angular
11553 ! Calculate whole angle-dependent part of epsilon and contributions
11554 ! to its derivatives
11555               fac=(rrij*sigsq)**expon2
11556               e1=fac*fac*aa(itypi,itypj)
11557               e2=fac*bb(itypi,itypj)
11558               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11559               eps2der=evdwij*eps3rt
11560               eps3der=evdwij*eps2rt
11561               evdwij=evdwij*eps2rt*eps3rt
11562               evdw=evdw+evdwij*(1.0d0-sss)
11563               if (lprn) then
11564               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11565               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11566 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11567 !d     &          restyp(itypi),i,restyp(itypj),j,
11568 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11569 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11570 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11571 !d     &          evdwij
11572               endif
11573 ! Calculate gradient components.
11574               e1=e1*eps1*eps2rt**2*eps3rt**2
11575               fac=-expon*(e1+evdwij)
11576               sigder=fac/sigsq
11577               fac=rrij*fac
11578 ! Calculate radial part of the gradient
11579               gg(1)=xj*fac
11580               gg(2)=yj*fac
11581               gg(3)=zj*fac
11582 ! Calculate the angular part of the gradient and sum add the contributions
11583 ! to the appropriate components of the Cartesian gradient.
11584               call sc_grad_scale(1.0d0-sss)
11585             endif
11586           enddo      ! j
11587         enddo        ! iint
11588       enddo          ! i
11589 !     stop
11590       return
11591       end subroutine ebp_long
11592 !-----------------------------------------------------------------------------
11593       subroutine ebp_short(evdw)
11594 !
11595 ! This subroutine calculates the interaction energy of nonbonded side chains
11596 ! assuming the Berne-Pechukas potential of interaction.
11597 !
11598       use calc_data
11599 !      implicit real*8 (a-h,o-z)
11600 !      include 'DIMENSIONS'
11601 !      include 'COMMON.GEO'
11602 !      include 'COMMON.VAR'
11603 !      include 'COMMON.LOCAL'
11604 !      include 'COMMON.CHAIN'
11605 !      include 'COMMON.DERIV'
11606 !      include 'COMMON.NAMES'
11607 !      include 'COMMON.INTERACT'
11608 !      include 'COMMON.IOUNITS'
11609 !      include 'COMMON.CALC'
11610       use comm_srutu
11611 !el      integer :: icall
11612 !el      common /srutu/ icall
11613 !     double precision rrsave(maxdim)
11614       logical :: lprn
11615 !el local variables
11616       integer :: iint,itypi,itypi1,itypj
11617       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11618       real(kind=8) :: sss,e1,e2,evdw
11619       evdw=0.0D0
11620 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11621       evdw=0.0D0
11622 !     if (icall.eq.0) then
11623 !       lprn=.true.
11624 !     else
11625         lprn=.false.
11626 !     endif
11627 !el      ind=0
11628       do i=iatsc_s,iatsc_e
11629         itypi=itype(i)
11630         if (itypi.eq.ntyp1) cycle
11631         itypi1=itype(i+1)
11632         xi=c(1,nres+i)
11633         yi=c(2,nres+i)
11634         zi=c(3,nres+i)
11635         dxi=dc_norm(1,nres+i)
11636         dyi=dc_norm(2,nres+i)
11637         dzi=dc_norm(3,nres+i)
11638 !        dsci_inv=dsc_inv(itypi)
11639         dsci_inv=vbld_inv(i+nres)
11640 !
11641 ! Calculate SC interaction energy.
11642 !
11643         do iint=1,nint_gr(i)
11644           do j=istart(i,iint),iend(i,iint)
11645 !el            ind=ind+1
11646             itypj=itype(j)
11647             if (itypj.eq.ntyp1) cycle
11648 !            dscj_inv=dsc_inv(itypj)
11649             dscj_inv=vbld_inv(j+nres)
11650             chi1=chi(itypi,itypj)
11651             chi2=chi(itypj,itypi)
11652             chi12=chi1*chi2
11653             chip1=chip(itypi)
11654             chip2=chip(itypj)
11655             chip12=chip1*chip2
11656             alf1=alp(itypi)
11657             alf2=alp(itypj)
11658             alf12=0.5D0*(alf1+alf2)
11659             xj=c(1,nres+j)-xi
11660             yj=c(2,nres+j)-yi
11661             zj=c(3,nres+j)-zi
11662             dxj=dc_norm(1,nres+j)
11663             dyj=dc_norm(2,nres+j)
11664             dzj=dc_norm(3,nres+j)
11665             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11666             rij=dsqrt(rrij)
11667             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11668
11669             if (sss.gt.0.0d0) then
11670
11671 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11672               call sc_angular
11673 ! Calculate whole angle-dependent part of epsilon and contributions
11674 ! to its derivatives
11675               fac=(rrij*sigsq)**expon2
11676               e1=fac*fac*aa(itypi,itypj)
11677               e2=fac*bb(itypi,itypj)
11678               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11679               eps2der=evdwij*eps3rt
11680               eps3der=evdwij*eps2rt
11681               evdwij=evdwij*eps2rt*eps3rt
11682               evdw=evdw+evdwij*sss
11683               if (lprn) then
11684               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11685               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11686 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11687 !d     &          restyp(itypi),i,restyp(itypj),j,
11688 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11689 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11690 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11691 !d     &          evdwij
11692               endif
11693 ! Calculate gradient components.
11694               e1=e1*eps1*eps2rt**2*eps3rt**2
11695               fac=-expon*(e1+evdwij)
11696               sigder=fac/sigsq
11697               fac=rrij*fac
11698 ! Calculate radial part of the gradient
11699               gg(1)=xj*fac
11700               gg(2)=yj*fac
11701               gg(3)=zj*fac
11702 ! Calculate the angular part of the gradient and sum add the contributions
11703 ! to the appropriate components of the Cartesian gradient.
11704               call sc_grad_scale(sss)
11705             endif
11706           enddo      ! j
11707         enddo        ! iint
11708       enddo          ! i
11709 !     stop
11710       return
11711       end subroutine ebp_short
11712 !-----------------------------------------------------------------------------
11713       subroutine egb_long(evdw)
11714 !
11715 ! This subroutine calculates the interaction energy of nonbonded side chains
11716 ! assuming the Gay-Berne potential of interaction.
11717 !
11718       use calc_data
11719 !      implicit real*8 (a-h,o-z)
11720 !      include 'DIMENSIONS'
11721 !      include 'COMMON.GEO'
11722 !      include 'COMMON.VAR'
11723 !      include 'COMMON.LOCAL'
11724 !      include 'COMMON.CHAIN'
11725 !      include 'COMMON.DERIV'
11726 !      include 'COMMON.NAMES'
11727 !      include 'COMMON.INTERACT'
11728 !      include 'COMMON.IOUNITS'
11729 !      include 'COMMON.CALC'
11730 !      include 'COMMON.CONTROL'
11731       logical :: lprn
11732 !el local variables
11733       integer :: iint,itypi,itypi1,itypj,subchap
11734       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11735       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11736       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11737                     dist_temp, dist_init
11738
11739       evdw=0.0D0
11740 !cccc      energy_dec=.false.
11741 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11742       evdw=0.0D0
11743       lprn=.false.
11744 !     if (icall.eq.0) lprn=.false.
11745 !el      ind=0
11746       do i=iatsc_s,iatsc_e
11747         itypi=itype(i)
11748         if (itypi.eq.ntyp1) cycle
11749         itypi1=itype(i+1)
11750         xi=c(1,nres+i)
11751         yi=c(2,nres+i)
11752         zi=c(3,nres+i)
11753           xi=mod(xi,boxxsize)
11754           if (xi.lt.0) xi=xi+boxxsize
11755           yi=mod(yi,boxysize)
11756           if (yi.lt.0) yi=yi+boxysize
11757           zi=mod(zi,boxzsize)
11758           if (zi.lt.0) zi=zi+boxzsize
11759         dxi=dc_norm(1,nres+i)
11760         dyi=dc_norm(2,nres+i)
11761         dzi=dc_norm(3,nres+i)
11762 !        dsci_inv=dsc_inv(itypi)
11763         dsci_inv=vbld_inv(i+nres)
11764 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11765 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11766 !
11767 ! Calculate SC interaction energy.
11768 !
11769         do iint=1,nint_gr(i)
11770           do j=istart(i,iint),iend(i,iint)
11771 !el            ind=ind+1
11772             itypj=itype(j)
11773             if (itypj.eq.ntyp1) cycle
11774 !            dscj_inv=dsc_inv(itypj)
11775             dscj_inv=vbld_inv(j+nres)
11776 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11777 !     &       1.0d0/vbld(j+nres)
11778 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11779             sig0ij=sigma(itypi,itypj)
11780             chi1=chi(itypi,itypj)
11781             chi2=chi(itypj,itypi)
11782             chi12=chi1*chi2
11783             chip1=chip(itypi)
11784             chip2=chip(itypj)
11785             chip12=chip1*chip2
11786             alf1=alp(itypi)
11787             alf2=alp(itypj)
11788             alf12=0.5D0*(alf1+alf2)
11789             xj=c(1,nres+j)
11790             yj=c(2,nres+j)
11791             zj=c(3,nres+j)
11792 ! Searching for nearest neighbour
11793           xj=mod(xj,boxxsize)
11794           if (xj.lt.0) xj=xj+boxxsize
11795           yj=mod(yj,boxysize)
11796           if (yj.lt.0) yj=yj+boxysize
11797           zj=mod(zj,boxzsize)
11798           if (zj.lt.0) zj=zj+boxzsize
11799           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11800           xj_safe=xj
11801           yj_safe=yj
11802           zj_safe=zj
11803           subchap=0
11804           do xshift=-1,1
11805           do yshift=-1,1
11806           do zshift=-1,1
11807           xj=xj_safe+xshift*boxxsize
11808           yj=yj_safe+yshift*boxysize
11809           zj=zj_safe+zshift*boxzsize
11810           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11811           if(dist_temp.lt.dist_init) then
11812             dist_init=dist_temp
11813             xj_temp=xj
11814             yj_temp=yj
11815             zj_temp=zj
11816             subchap=1
11817           endif
11818           enddo
11819           enddo
11820           enddo
11821           if (subchap.eq.1) then
11822           xj=xj_temp-xi
11823           yj=yj_temp-yi
11824           zj=zj_temp-zi
11825           else
11826           xj=xj_safe-xi
11827           yj=yj_safe-yi
11828           zj=zj_safe-zi
11829           endif
11830
11831             dxj=dc_norm(1,nres+j)
11832             dyj=dc_norm(2,nres+j)
11833             dzj=dc_norm(3,nres+j)
11834             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11835             rij=dsqrt(rrij)
11836             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11837             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11838             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11839             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11840             if (sss_ele_cut.le.0.0) cycle
11841             if (sss.lt.1.0d0) then
11842
11843 ! Calculate angle-dependent terms of energy and contributions to their
11844 ! derivatives.
11845               call sc_angular
11846               sigsq=1.0D0/sigsq
11847               sig=sig0ij*dsqrt(sigsq)
11848               rij_shift=1.0D0/rij-sig+sig0ij
11849 ! for diagnostics; uncomment
11850 !              rij_shift=1.2*sig0ij
11851 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11852               if (rij_shift.le.0.0D0) then
11853                 evdw=1.0D20
11854 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11855 !d     &          restyp(itypi),i,restyp(itypj),j,
11856 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11857                 return
11858               endif
11859               sigder=-sig*sigsq
11860 !---------------------------------------------------------------
11861               rij_shift=1.0D0/rij_shift
11862               fac=rij_shift**expon
11863               e1=fac*fac*aa(itypi,itypj)
11864               e2=fac*bb(itypi,itypj)
11865               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11866               eps2der=evdwij*eps3rt
11867               eps3der=evdwij*eps2rt
11868 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11869 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11870               evdwij=evdwij*eps2rt*eps3rt
11871               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11872               if (lprn) then
11873               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11874               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11875               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11876                 restyp(itypi),i,restyp(itypj),j,&
11877                 epsi,sigm,chi1,chi2,chip1,chip2,&
11878                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11879                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11880                 evdwij
11881               endif
11882
11883               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11884                               'evdw',i,j,evdwij
11885 !              if (energy_dec) write (iout,*) &
11886 !                              'evdw',i,j,evdwij,"egb_long"
11887
11888 ! Calculate gradient components.
11889               e1=e1*eps1*eps2rt**2*eps3rt**2
11890               fac=-expon*(e1+evdwij)*rij_shift
11891               sigder=fac*sigder
11892               fac=rij*fac
11893               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
11894             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
11895             /sigmaii(itypi,itypj))
11896 !              fac=0.0d0
11897 ! Calculate the radial part of the gradient
11898               gg(1)=xj*fac
11899               gg(2)=yj*fac
11900               gg(3)=zj*fac
11901 ! Calculate angular part of the gradient.
11902               call sc_grad_scale(1.0d0-sss)
11903             endif
11904           enddo      ! j
11905         enddo        ! iint
11906       enddo          ! i
11907 !      write (iout,*) "Number of loop steps in EGB:",ind
11908 !ccc      energy_dec=.false.
11909       return
11910       end subroutine egb_long
11911 !-----------------------------------------------------------------------------
11912       subroutine egb_short(evdw)
11913 !
11914 ! This subroutine calculates the interaction energy of nonbonded side chains
11915 ! assuming the Gay-Berne potential of interaction.
11916 !
11917       use calc_data
11918 !      implicit real*8 (a-h,o-z)
11919 !      include 'DIMENSIONS'
11920 !      include 'COMMON.GEO'
11921 !      include 'COMMON.VAR'
11922 !      include 'COMMON.LOCAL'
11923 !      include 'COMMON.CHAIN'
11924 !      include 'COMMON.DERIV'
11925 !      include 'COMMON.NAMES'
11926 !      include 'COMMON.INTERACT'
11927 !      include 'COMMON.IOUNITS'
11928 !      include 'COMMON.CALC'
11929 !      include 'COMMON.CONTROL'
11930       logical :: lprn
11931 !el local variables
11932       integer :: iint,itypi,itypi1,itypj,subchap
11933       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11934       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
11935       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11936                     dist_temp, dist_init
11937       evdw=0.0D0
11938 !cccc      energy_dec=.false.
11939 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11940       evdw=0.0D0
11941       lprn=.false.
11942 !     if (icall.eq.0) lprn=.false.
11943 !el      ind=0
11944       do i=iatsc_s,iatsc_e
11945         itypi=itype(i)
11946         if (itypi.eq.ntyp1) cycle
11947         itypi1=itype(i+1)
11948         xi=c(1,nres+i)
11949         yi=c(2,nres+i)
11950         zi=c(3,nres+i)
11951           xi=mod(xi,boxxsize)
11952           if (xi.lt.0) xi=xi+boxxsize
11953           yi=mod(yi,boxysize)
11954           if (yi.lt.0) yi=yi+boxysize
11955           zi=mod(zi,boxzsize)
11956           if (zi.lt.0) zi=zi+boxzsize
11957         dxi=dc_norm(1,nres+i)
11958         dyi=dc_norm(2,nres+i)
11959         dzi=dc_norm(3,nres+i)
11960 !        dsci_inv=dsc_inv(itypi)
11961         dsci_inv=vbld_inv(i+nres)
11962
11963         dxi=dc_norm(1,nres+i)
11964         dyi=dc_norm(2,nres+i)
11965         dzi=dc_norm(3,nres+i)
11966 !        dsci_inv=dsc_inv(itypi)
11967         dsci_inv=vbld_inv(i+nres)
11968 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11969 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11970 !
11971 ! Calculate SC interaction energy.
11972 !
11973         do iint=1,nint_gr(i)
11974           do j=istart(i,iint),iend(i,iint)
11975 !el            ind=ind+1
11976             itypj=itype(j)
11977             if (itypj.eq.ntyp1) cycle
11978 !            dscj_inv=dsc_inv(itypj)
11979             dscj_inv=vbld_inv(j+nres)
11980 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11981 !     &       1.0d0/vbld(j+nres)
11982 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11983             sig0ij=sigma(itypi,itypj)
11984             chi1=chi(itypi,itypj)
11985             chi2=chi(itypj,itypi)
11986             chi12=chi1*chi2
11987             chip1=chip(itypi)
11988             chip2=chip(itypj)
11989             chip12=chip1*chip2
11990             alf1=alp(itypi)
11991             alf2=alp(itypj)
11992             alf12=0.5D0*(alf1+alf2)
11993 !            xj=c(1,nres+j)-xi
11994 !            yj=c(2,nres+j)-yi
11995 !            zj=c(3,nres+j)-zi
11996             xj=c(1,nres+j)
11997             yj=c(2,nres+j)
11998             zj=c(3,nres+j)
11999 ! Searching for nearest neighbour
12000           xj=mod(xj,boxxsize)
12001           if (xj.lt.0) xj=xj+boxxsize
12002           yj=mod(yj,boxysize)
12003           if (yj.lt.0) yj=yj+boxysize
12004           zj=mod(zj,boxzsize)
12005           if (zj.lt.0) zj=zj+boxzsize
12006           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12007           xj_safe=xj
12008           yj_safe=yj
12009           zj_safe=zj
12010           subchap=0
12011           do xshift=-1,1
12012           do yshift=-1,1
12013           do zshift=-1,1
12014           xj=xj_safe+xshift*boxxsize
12015           yj=yj_safe+yshift*boxysize
12016           zj=zj_safe+zshift*boxzsize
12017           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12018           if(dist_temp.lt.dist_init) then
12019             dist_init=dist_temp
12020             xj_temp=xj
12021             yj_temp=yj
12022             zj_temp=zj
12023             subchap=1
12024           endif
12025           enddo
12026           enddo
12027           enddo
12028           if (subchap.eq.1) then
12029           xj=xj_temp-xi
12030           yj=yj_temp-yi
12031           zj=zj_temp-zi
12032           else
12033           xj=xj_safe-xi
12034           yj=yj_safe-yi
12035           zj=zj_safe-zi
12036           endif
12037
12038             dxj=dc_norm(1,nres+j)
12039             dyj=dc_norm(2,nres+j)
12040             dzj=dc_norm(3,nres+j)
12041             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12042             rij=dsqrt(rrij)
12043             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12044             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12045             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12046             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12047             if (sss_ele_cut.le.0.0) cycle
12048
12049             if (sss.gt.0.0d0) then
12050
12051 ! Calculate angle-dependent terms of energy and contributions to their
12052 ! derivatives.
12053               call sc_angular
12054               sigsq=1.0D0/sigsq
12055               sig=sig0ij*dsqrt(sigsq)
12056               rij_shift=1.0D0/rij-sig+sig0ij
12057 ! for diagnostics; uncomment
12058 !              rij_shift=1.2*sig0ij
12059 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12060               if (rij_shift.le.0.0D0) then
12061                 evdw=1.0D20
12062 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12063 !d     &          restyp(itypi),i,restyp(itypj),j,
12064 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12065                 return
12066               endif
12067               sigder=-sig*sigsq
12068 !---------------------------------------------------------------
12069               rij_shift=1.0D0/rij_shift
12070               fac=rij_shift**expon
12071               e1=fac*fac*aa(itypi,itypj)
12072               e2=fac*bb(itypi,itypj)
12073               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12074               eps2der=evdwij*eps3rt
12075               eps3der=evdwij*eps2rt
12076 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12077 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12078               evdwij=evdwij*eps2rt*eps3rt
12079               evdw=evdw+evdwij*sss*sss_ele_cut
12080               if (lprn) then
12081               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12082               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12083               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12084                 restyp(itypi),i,restyp(itypj),j,&
12085                 epsi,sigm,chi1,chi2,chip1,chip2,&
12086                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12087                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12088                 evdwij
12089               endif
12090
12091               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12092                               'evdw',i,j,evdwij
12093 !              if (energy_dec) write (iout,*) &
12094 !                              'evdw',i,j,evdwij,"egb_short"
12095
12096 ! Calculate gradient components.
12097               e1=e1*eps1*eps2rt**2*eps3rt**2
12098               fac=-expon*(e1+evdwij)*rij_shift
12099               sigder=fac*sigder
12100               fac=rij*fac
12101               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12102             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12103             /sigmaii(itypi,itypj))
12104
12105 !              fac=0.0d0
12106 ! Calculate the radial part of the gradient
12107               gg(1)=xj*fac
12108               gg(2)=yj*fac
12109               gg(3)=zj*fac
12110 ! Calculate angular part of the gradient.
12111               call sc_grad_scale(sss)
12112             endif
12113           enddo      ! j
12114         enddo        ! iint
12115       enddo          ! i
12116 !      write (iout,*) "Number of loop steps in EGB:",ind
12117 !ccc      energy_dec=.false.
12118       return
12119       end subroutine egb_short
12120 !-----------------------------------------------------------------------------
12121       subroutine egbv_long(evdw)
12122 !
12123 ! This subroutine calculates the interaction energy of nonbonded side chains
12124 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12125 !
12126       use calc_data
12127 !      implicit real*8 (a-h,o-z)
12128 !      include 'DIMENSIONS'
12129 !      include 'COMMON.GEO'
12130 !      include 'COMMON.VAR'
12131 !      include 'COMMON.LOCAL'
12132 !      include 'COMMON.CHAIN'
12133 !      include 'COMMON.DERIV'
12134 !      include 'COMMON.NAMES'
12135 !      include 'COMMON.INTERACT'
12136 !      include 'COMMON.IOUNITS'
12137 !      include 'COMMON.CALC'
12138       use comm_srutu
12139 !el      integer :: icall
12140 !el      common /srutu/ icall
12141       logical :: lprn
12142 !el local variables
12143       integer :: iint,itypi,itypi1,itypj
12144       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12145       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12146       evdw=0.0D0
12147 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12148       evdw=0.0D0
12149       lprn=.false.
12150 !     if (icall.eq.0) lprn=.true.
12151 !el      ind=0
12152       do i=iatsc_s,iatsc_e
12153         itypi=itype(i)
12154         if (itypi.eq.ntyp1) cycle
12155         itypi1=itype(i+1)
12156         xi=c(1,nres+i)
12157         yi=c(2,nres+i)
12158         zi=c(3,nres+i)
12159         dxi=dc_norm(1,nres+i)
12160         dyi=dc_norm(2,nres+i)
12161         dzi=dc_norm(3,nres+i)
12162 !        dsci_inv=dsc_inv(itypi)
12163         dsci_inv=vbld_inv(i+nres)
12164 !
12165 ! Calculate SC interaction energy.
12166 !
12167         do iint=1,nint_gr(i)
12168           do j=istart(i,iint),iend(i,iint)
12169 !el            ind=ind+1
12170             itypj=itype(j)
12171             if (itypj.eq.ntyp1) cycle
12172 !            dscj_inv=dsc_inv(itypj)
12173             dscj_inv=vbld_inv(j+nres)
12174             sig0ij=sigma(itypi,itypj)
12175             r0ij=r0(itypi,itypj)
12176             chi1=chi(itypi,itypj)
12177             chi2=chi(itypj,itypi)
12178             chi12=chi1*chi2
12179             chip1=chip(itypi)
12180             chip2=chip(itypj)
12181             chip12=chip1*chip2
12182             alf1=alp(itypi)
12183             alf2=alp(itypj)
12184             alf12=0.5D0*(alf1+alf2)
12185             xj=c(1,nres+j)-xi
12186             yj=c(2,nres+j)-yi
12187             zj=c(3,nres+j)-zi
12188             dxj=dc_norm(1,nres+j)
12189             dyj=dc_norm(2,nres+j)
12190             dzj=dc_norm(3,nres+j)
12191             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12192             rij=dsqrt(rrij)
12193
12194             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12195
12196             if (sss.lt.1.0d0) then
12197
12198 ! Calculate angle-dependent terms of energy and contributions to their
12199 ! derivatives.
12200               call sc_angular
12201               sigsq=1.0D0/sigsq
12202               sig=sig0ij*dsqrt(sigsq)
12203               rij_shift=1.0D0/rij-sig+r0ij
12204 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12205               if (rij_shift.le.0.0D0) then
12206                 evdw=1.0D20
12207                 return
12208               endif
12209               sigder=-sig*sigsq
12210 !---------------------------------------------------------------
12211               rij_shift=1.0D0/rij_shift
12212               fac=rij_shift**expon
12213               e1=fac*fac*aa(itypi,itypj)
12214               e2=fac*bb(itypi,itypj)
12215               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12216               eps2der=evdwij*eps3rt
12217               eps3der=evdwij*eps2rt
12218               fac_augm=rrij**expon
12219               e_augm=augm(itypi,itypj)*fac_augm
12220               evdwij=evdwij*eps2rt*eps3rt
12221               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12222               if (lprn) then
12223               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12224               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12225               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12226                 restyp(itypi),i,restyp(itypj),j,&
12227                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12228                 chi1,chi2,chip1,chip2,&
12229                 eps1,eps2rt**2,eps3rt**2,&
12230                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12231                 evdwij+e_augm
12232               endif
12233 ! Calculate gradient components.
12234               e1=e1*eps1*eps2rt**2*eps3rt**2
12235               fac=-expon*(e1+evdwij)*rij_shift
12236               sigder=fac*sigder
12237               fac=rij*fac-2*expon*rrij*e_augm
12238 ! Calculate the radial part of the gradient
12239               gg(1)=xj*fac
12240               gg(2)=yj*fac
12241               gg(3)=zj*fac
12242 ! Calculate angular part of the gradient.
12243               call sc_grad_scale(1.0d0-sss)
12244             endif
12245           enddo      ! j
12246         enddo        ! iint
12247       enddo          ! i
12248       end subroutine egbv_long
12249 !-----------------------------------------------------------------------------
12250       subroutine egbv_short(evdw)
12251 !
12252 ! This subroutine calculates the interaction energy of nonbonded side chains
12253 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12254 !
12255       use calc_data
12256 !      implicit real*8 (a-h,o-z)
12257 !      include 'DIMENSIONS'
12258 !      include 'COMMON.GEO'
12259 !      include 'COMMON.VAR'
12260 !      include 'COMMON.LOCAL'
12261 !      include 'COMMON.CHAIN'
12262 !      include 'COMMON.DERIV'
12263 !      include 'COMMON.NAMES'
12264 !      include 'COMMON.INTERACT'
12265 !      include 'COMMON.IOUNITS'
12266 !      include 'COMMON.CALC'
12267       use comm_srutu
12268 !el      integer :: icall
12269 !el      common /srutu/ icall
12270       logical :: lprn
12271 !el local variables
12272       integer :: iint,itypi,itypi1,itypj
12273       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12274       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12275       evdw=0.0D0
12276 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12277       evdw=0.0D0
12278       lprn=.false.
12279 !     if (icall.eq.0) lprn=.true.
12280 !el      ind=0
12281       do i=iatsc_s,iatsc_e
12282         itypi=itype(i)
12283         if (itypi.eq.ntyp1) cycle
12284         itypi1=itype(i+1)
12285         xi=c(1,nres+i)
12286         yi=c(2,nres+i)
12287         zi=c(3,nres+i)
12288         dxi=dc_norm(1,nres+i)
12289         dyi=dc_norm(2,nres+i)
12290         dzi=dc_norm(3,nres+i)
12291 !        dsci_inv=dsc_inv(itypi)
12292         dsci_inv=vbld_inv(i+nres)
12293 !
12294 ! Calculate SC interaction energy.
12295 !
12296         do iint=1,nint_gr(i)
12297           do j=istart(i,iint),iend(i,iint)
12298 !el            ind=ind+1
12299             itypj=itype(j)
12300             if (itypj.eq.ntyp1) cycle
12301 !            dscj_inv=dsc_inv(itypj)
12302             dscj_inv=vbld_inv(j+nres)
12303             sig0ij=sigma(itypi,itypj)
12304             r0ij=r0(itypi,itypj)
12305             chi1=chi(itypi,itypj)
12306             chi2=chi(itypj,itypi)
12307             chi12=chi1*chi2
12308             chip1=chip(itypi)
12309             chip2=chip(itypj)
12310             chip12=chip1*chip2
12311             alf1=alp(itypi)
12312             alf2=alp(itypj)
12313             alf12=0.5D0*(alf1+alf2)
12314             xj=c(1,nres+j)-xi
12315             yj=c(2,nres+j)-yi
12316             zj=c(3,nres+j)-zi
12317             dxj=dc_norm(1,nres+j)
12318             dyj=dc_norm(2,nres+j)
12319             dzj=dc_norm(3,nres+j)
12320             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12321             rij=dsqrt(rrij)
12322
12323             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12324
12325             if (sss.gt.0.0d0) then
12326
12327 ! Calculate angle-dependent terms of energy and contributions to their
12328 ! derivatives.
12329               call sc_angular
12330               sigsq=1.0D0/sigsq
12331               sig=sig0ij*dsqrt(sigsq)
12332               rij_shift=1.0D0/rij-sig+r0ij
12333 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12334               if (rij_shift.le.0.0D0) then
12335                 evdw=1.0D20
12336                 return
12337               endif
12338               sigder=-sig*sigsq
12339 !---------------------------------------------------------------
12340               rij_shift=1.0D0/rij_shift
12341               fac=rij_shift**expon
12342               e1=fac*fac*aa(itypi,itypj)
12343               e2=fac*bb(itypi,itypj)
12344               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12345               eps2der=evdwij*eps3rt
12346               eps3der=evdwij*eps2rt
12347               fac_augm=rrij**expon
12348               e_augm=augm(itypi,itypj)*fac_augm
12349               evdwij=evdwij*eps2rt*eps3rt
12350               evdw=evdw+(evdwij+e_augm)*sss
12351               if (lprn) then
12352               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12353               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12354               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12355                 restyp(itypi),i,restyp(itypj),j,&
12356                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12357                 chi1,chi2,chip1,chip2,&
12358                 eps1,eps2rt**2,eps3rt**2,&
12359                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12360                 evdwij+e_augm
12361               endif
12362 ! Calculate gradient components.
12363               e1=e1*eps1*eps2rt**2*eps3rt**2
12364               fac=-expon*(e1+evdwij)*rij_shift
12365               sigder=fac*sigder
12366               fac=rij*fac-2*expon*rrij*e_augm
12367 ! Calculate the radial part of the gradient
12368               gg(1)=xj*fac
12369               gg(2)=yj*fac
12370               gg(3)=zj*fac
12371 ! Calculate angular part of the gradient.
12372               call sc_grad_scale(sss)
12373             endif
12374           enddo      ! j
12375         enddo        ! iint
12376       enddo          ! i
12377       end subroutine egbv_short
12378 !-----------------------------------------------------------------------------
12379       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12380 !
12381 ! This subroutine calculates the average interaction energy and its gradient
12382 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12383 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12384 ! The potential depends both on the distance of peptide-group centers and on
12385 ! the orientation of the CA-CA virtual bonds.
12386 !
12387 !      implicit real*8 (a-h,o-z)
12388
12389       use comm_locel
12390 #ifdef MPI
12391       include 'mpif.h'
12392 #endif
12393 !      include 'DIMENSIONS'
12394 !      include 'COMMON.CONTROL'
12395 !      include 'COMMON.SETUP'
12396 !      include 'COMMON.IOUNITS'
12397 !      include 'COMMON.GEO'
12398 !      include 'COMMON.VAR'
12399 !      include 'COMMON.LOCAL'
12400 !      include 'COMMON.CHAIN'
12401 !      include 'COMMON.DERIV'
12402 !      include 'COMMON.INTERACT'
12403 !      include 'COMMON.CONTACTS'
12404 !      include 'COMMON.TORSION'
12405 !      include 'COMMON.VECTORS'
12406 !      include 'COMMON.FFIELD'
12407 !      include 'COMMON.TIME1'
12408       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12409       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12410       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12411 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12412       real(kind=8),dimension(4) :: muij
12413 !el      integer :: num_conti,j1,j2
12414 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12415 !el                   dz_normi,xmedi,ymedi,zmedi
12416 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12417 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12418 !el          num_conti,j1,j2
12419 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12420 #ifdef MOMENT
12421       real(kind=8) :: scal_el=1.0d0
12422 #else
12423       real(kind=8) :: scal_el=0.5d0
12424 #endif
12425 ! 12/13/98
12426 ! 13-go grudnia roku pamietnego...
12427       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12428                                              0.0d0,1.0d0,0.0d0,&
12429                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12430 !el local variables
12431       integer :: i,j,k
12432       real(kind=8) :: fac
12433       real(kind=8) :: dxj,dyj,dzj
12434       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12435
12436 !      allocate(num_cont_hb(nres)) !(maxres)
12437 !d      write(iout,*) 'In EELEC'
12438 !d      do i=1,nloctyp
12439 !d        write(iout,*) 'Type',i
12440 !d        write(iout,*) 'B1',B1(:,i)
12441 !d        write(iout,*) 'B2',B2(:,i)
12442 !d        write(iout,*) 'CC',CC(:,:,i)
12443 !d        write(iout,*) 'DD',DD(:,:,i)
12444 !d        write(iout,*) 'EE',EE(:,:,i)
12445 !d      enddo
12446 !d      call check_vecgrad
12447 !d      stop
12448       if (icheckgrad.eq.1) then
12449         do i=1,nres-1
12450           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12451           do k=1,3
12452             dc_norm(k,i)=dc(k,i)*fac
12453           enddo
12454 !          write (iout,*) 'i',i,' fac',fac
12455         enddo
12456       endif
12457       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12458           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12459           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12460 !        call vec_and_deriv
12461 #ifdef TIMING
12462         time01=MPI_Wtime()
12463 #endif
12464         call set_matrices
12465 #ifdef TIMING
12466         time_mat=time_mat+MPI_Wtime()-time01
12467 #endif
12468       endif
12469 !d      do i=1,nres-1
12470 !d        write (iout,*) 'i=',i
12471 !d        do k=1,3
12472 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12473 !d        enddo
12474 !d        do k=1,3
12475 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12476 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12477 !d        enddo
12478 !d      enddo
12479       t_eelecij=0.0d0
12480       ees=0.0D0
12481       evdw1=0.0D0
12482       eel_loc=0.0d0
12483       eello_turn3=0.0d0
12484       eello_turn4=0.0d0
12485 !el      ind=0
12486       do i=1,nres
12487         num_cont_hb(i)=0
12488       enddo
12489 !d      print '(a)','Enter EELEC'
12490 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12491 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12492 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12493       do i=1,nres
12494         gel_loc_loc(i)=0.0d0
12495         gcorr_loc(i)=0.0d0
12496       enddo
12497 !
12498 !
12499 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12500 !
12501 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12502 !
12503       do i=iturn3_start,iturn3_end
12504         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12505         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12506         dxi=dc(1,i)
12507         dyi=dc(2,i)
12508         dzi=dc(3,i)
12509         dx_normi=dc_norm(1,i)
12510         dy_normi=dc_norm(2,i)
12511         dz_normi=dc_norm(3,i)
12512         xmedi=c(1,i)+0.5d0*dxi
12513         ymedi=c(2,i)+0.5d0*dyi
12514         zmedi=c(3,i)+0.5d0*dzi
12515         num_conti=0
12516         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12517         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12518         num_cont_hb(i)=num_conti
12519       enddo
12520       do i=iturn4_start,iturn4_end
12521         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12522           .or. itype(i+3).eq.ntyp1 &
12523           .or. itype(i+4).eq.ntyp1) cycle
12524         dxi=dc(1,i)
12525         dyi=dc(2,i)
12526         dzi=dc(3,i)
12527         dx_normi=dc_norm(1,i)
12528         dy_normi=dc_norm(2,i)
12529         dz_normi=dc_norm(3,i)
12530         xmedi=c(1,i)+0.5d0*dxi
12531         ymedi=c(2,i)+0.5d0*dyi
12532         zmedi=c(3,i)+0.5d0*dzi
12533         num_conti=num_cont_hb(i)
12534         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12535         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12536           call eturn4(i,eello_turn4)
12537         num_cont_hb(i)=num_conti
12538       enddo   ! i
12539 !
12540 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12541 !
12542       do i=iatel_s,iatel_e
12543         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12544         dxi=dc(1,i)
12545         dyi=dc(2,i)
12546         dzi=dc(3,i)
12547         dx_normi=dc_norm(1,i)
12548         dy_normi=dc_norm(2,i)
12549         dz_normi=dc_norm(3,i)
12550         xmedi=c(1,i)+0.5d0*dxi
12551         ymedi=c(2,i)+0.5d0*dyi
12552         zmedi=c(3,i)+0.5d0*dzi
12553 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12554         num_conti=num_cont_hb(i)
12555         do j=ielstart(i),ielend(i)
12556           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12557           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12558         enddo ! j
12559         num_cont_hb(i)=num_conti
12560       enddo   ! i
12561 !      write (iout,*) "Number of loop steps in EELEC:",ind
12562 !d      do i=1,nres
12563 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12564 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12565 !d      enddo
12566 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12567 !cc      eel_loc=eel_loc+eello_turn3
12568 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12569       return
12570       end subroutine eelec_scale
12571 !-----------------------------------------------------------------------------
12572       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12573 !      implicit real*8 (a-h,o-z)
12574
12575       use comm_locel
12576 !      include 'DIMENSIONS'
12577 #ifdef MPI
12578       include "mpif.h"
12579 #endif
12580 !      include 'COMMON.CONTROL'
12581 !      include 'COMMON.IOUNITS'
12582 !      include 'COMMON.GEO'
12583 !      include 'COMMON.VAR'
12584 !      include 'COMMON.LOCAL'
12585 !      include 'COMMON.CHAIN'
12586 !      include 'COMMON.DERIV'
12587 !      include 'COMMON.INTERACT'
12588 !      include 'COMMON.CONTACTS'
12589 !      include 'COMMON.TORSION'
12590 !      include 'COMMON.VECTORS'
12591 !      include 'COMMON.FFIELD'
12592 !      include 'COMMON.TIME1'
12593       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12594       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12595       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12596 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12597       real(kind=8),dimension(4) :: muij
12598 !el      integer :: num_conti,j1,j2
12599 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12600 !el                   dz_normi,xmedi,ymedi,zmedi
12601 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12602 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12603 !el          num_conti,j1,j2
12604 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12605 #ifdef MOMENT
12606       real(kind=8) :: scal_el=1.0d0
12607 #else
12608       real(kind=8) :: scal_el=0.5d0
12609 #endif
12610 ! 12/13/98
12611 ! 13-go grudnia roku pamietnego...
12612       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12613                                              0.0d0,1.0d0,0.0d0,&
12614                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12615 !el local variables
12616       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12617       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12618       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12619       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12620       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12621       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12622       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12623                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12624                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12625                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12626                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12627                   ecosam,ecosbm,ecosgm,ghalf,time00
12628 !      integer :: maxconts
12629 !      maxconts = nres/4
12630 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12631 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12632 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12633 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12634 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12635 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12636 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12637 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12638 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12639 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12640 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12641 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12642 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12643
12644 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12645 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12646
12647 #ifdef MPI
12648           time00=MPI_Wtime()
12649 #endif
12650 !d      write (iout,*) "eelecij",i,j
12651 !el          ind=ind+1
12652           iteli=itel(i)
12653           itelj=itel(j)
12654           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12655           aaa=app(iteli,itelj)
12656           bbb=bpp(iteli,itelj)
12657           ael6i=ael6(iteli,itelj)
12658           ael3i=ael3(iteli,itelj)
12659           dxj=dc(1,j)
12660           dyj=dc(2,j)
12661           dzj=dc(3,j)
12662           dx_normj=dc_norm(1,j)
12663           dy_normj=dc_norm(2,j)
12664           dz_normj=dc_norm(3,j)
12665           xj=c(1,j)+0.5D0*dxj-xmedi
12666           yj=c(2,j)+0.5D0*dyj-ymedi
12667           zj=c(3,j)+0.5D0*dzj-zmedi
12668           rij=xj*xj+yj*yj+zj*zj
12669           rrmij=1.0D0/rij
12670           rij=dsqrt(rij)
12671           rmij=1.0D0/rij
12672 ! For extracting the short-range part of Evdwpp
12673           sss=sscale(rij/rpp(iteli,itelj))
12674
12675           r3ij=rrmij*rmij
12676           r6ij=r3ij*r3ij
12677           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12678           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12679           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12680           fac=cosa-3.0D0*cosb*cosg
12681           ev1=aaa*r6ij*r6ij
12682 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12683           if (j.eq.i+2) ev1=scal_el*ev1
12684           ev2=bbb*r6ij
12685           fac3=ael6i*r6ij
12686           fac4=ael3i*r3ij
12687           evdwij=ev1+ev2
12688           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12689           el2=fac4*fac
12690           eesij=el1+el2
12691 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12692           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12693           ees=ees+eesij
12694           evdw1=evdw1+evdwij*(1.0d0-sss)
12695 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12696 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12697 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12698 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12699
12700           if (energy_dec) then
12701               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12702               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12703           endif
12704
12705 !
12706 ! Calculate contributions to the Cartesian gradient.
12707 !
12708 #ifdef SPLITELE
12709           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12710           facel=-3*rrmij*(el1+eesij)
12711           fac1=fac
12712           erij(1)=xj*rmij
12713           erij(2)=yj*rmij
12714           erij(3)=zj*rmij
12715 !
12716 ! Radial derivatives. First process both termini of the fragment (i,j)
12717 !
12718           ggg(1)=facel*xj
12719           ggg(2)=facel*yj
12720           ggg(3)=facel*zj
12721 !          do k=1,3
12722 !            ghalf=0.5D0*ggg(k)
12723 !            gelc(k,i)=gelc(k,i)+ghalf
12724 !            gelc(k,j)=gelc(k,j)+ghalf
12725 !          enddo
12726 ! 9/28/08 AL Gradient compotents will be summed only at the end
12727           do k=1,3
12728             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12729             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12730           enddo
12731 !
12732 ! Loop over residues i+1 thru j-1.
12733 !
12734 !grad          do k=i+1,j-1
12735 !grad            do l=1,3
12736 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12737 !grad            enddo
12738 !grad          enddo
12739           ggg(1)=facvdw*xj
12740           ggg(2)=facvdw*yj
12741           ggg(3)=facvdw*zj
12742 !          do k=1,3
12743 !            ghalf=0.5D0*ggg(k)
12744 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12745 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12746 !          enddo
12747 ! 9/28/08 AL Gradient compotents will be summed only at the end
12748           do k=1,3
12749             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12750             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12751           enddo
12752 !
12753 ! Loop over residues i+1 thru j-1.
12754 !
12755 !grad          do k=i+1,j-1
12756 !grad            do l=1,3
12757 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12758 !grad            enddo
12759 !grad          enddo
12760 #else
12761           facvdw=ev1+evdwij*(1.0d0-sss)
12762           facel=el1+eesij
12763           fac1=fac
12764           fac=-3*rrmij*(facvdw+facvdw+facel)
12765           erij(1)=xj*rmij
12766           erij(2)=yj*rmij
12767           erij(3)=zj*rmij
12768 !
12769 ! Radial derivatives. First process both termini of the fragment (i,j)
12770 !
12771           ggg(1)=fac*xj
12772           ggg(2)=fac*yj
12773           ggg(3)=fac*zj
12774 !          do k=1,3
12775 !            ghalf=0.5D0*ggg(k)
12776 !            gelc(k,i)=gelc(k,i)+ghalf
12777 !            gelc(k,j)=gelc(k,j)+ghalf
12778 !          enddo
12779 ! 9/28/08 AL Gradient compotents will be summed only at the end
12780           do k=1,3
12781             gelc_long(k,j)=gelc(k,j)+ggg(k)
12782             gelc_long(k,i)=gelc(k,i)-ggg(k)
12783           enddo
12784 !
12785 ! Loop over residues i+1 thru j-1.
12786 !
12787 !grad          do k=i+1,j-1
12788 !grad            do l=1,3
12789 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12790 !grad            enddo
12791 !grad          enddo
12792 ! 9/28/08 AL Gradient compotents will be summed only at the end
12793           ggg(1)=facvdw*xj
12794           ggg(2)=facvdw*yj
12795           ggg(3)=facvdw*zj
12796           do k=1,3
12797             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12798             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12799           enddo
12800 #endif
12801 !
12802 ! Angular part
12803 !
12804           ecosa=2.0D0*fac3*fac1+fac4
12805           fac4=-3.0D0*fac4
12806           fac3=-6.0D0*fac3
12807           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12808           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12809           do k=1,3
12810             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12811             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12812           enddo
12813 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12814 !d   &          (dcosg(k),k=1,3)
12815           do k=1,3
12816             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12817           enddo
12818 !          do k=1,3
12819 !            ghalf=0.5D0*ggg(k)
12820 !            gelc(k,i)=gelc(k,i)+ghalf
12821 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12822 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12823 !            gelc(k,j)=gelc(k,j)+ghalf
12824 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12825 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12826 !          enddo
12827 !grad          do k=i+1,j-1
12828 !grad            do l=1,3
12829 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12830 !grad            enddo
12831 !grad          enddo
12832           do k=1,3
12833             gelc(k,i)=gelc(k,i) &
12834                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12835                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12836             gelc(k,j)=gelc(k,j) &
12837                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12838                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12839             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12840             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12841           enddo
12842           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12843               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12844               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12845 !
12846 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12847 !   energy of a peptide unit is assumed in the form of a second-order
12848 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12849 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12850 !   are computed for EVERY pair of non-contiguous peptide groups.
12851 !
12852           if (j.lt.nres-1) then
12853             j1=j+1
12854             j2=j-1
12855           else
12856             j1=j-1
12857             j2=j-2
12858           endif
12859           kkk=0
12860           do k=1,2
12861             do l=1,2
12862               kkk=kkk+1
12863               muij(kkk)=mu(k,i)*mu(l,j)
12864             enddo
12865           enddo
12866 !d         write (iout,*) 'EELEC: i',i,' j',j
12867 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12868 !d          write(iout,*) 'muij',muij
12869           ury=scalar(uy(1,i),erij)
12870           urz=scalar(uz(1,i),erij)
12871           vry=scalar(uy(1,j),erij)
12872           vrz=scalar(uz(1,j),erij)
12873           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12874           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12875           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12876           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12877           fac=dsqrt(-ael6i)*r3ij
12878           a22=a22*fac
12879           a23=a23*fac
12880           a32=a32*fac
12881           a33=a33*fac
12882 !d          write (iout,'(4i5,4f10.5)')
12883 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12884 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12885 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12886 !d     &      uy(:,j),uz(:,j)
12887 !d          write (iout,'(4f10.5)')
12888 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12889 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12890 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12891 !d           write (iout,'(9f10.5/)')
12892 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12893 ! Derivatives of the elements of A in virtual-bond vectors
12894           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12895           do k=1,3
12896             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12897             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12898             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12899             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12900             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12901             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12902             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12903             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12904             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12905             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12906             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12907             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12908           enddo
12909 ! Compute radial contributions to the gradient
12910           facr=-3.0d0*rrmij
12911           a22der=a22*facr
12912           a23der=a23*facr
12913           a32der=a32*facr
12914           a33der=a33*facr
12915           agg(1,1)=a22der*xj
12916           agg(2,1)=a22der*yj
12917           agg(3,1)=a22der*zj
12918           agg(1,2)=a23der*xj
12919           agg(2,2)=a23der*yj
12920           agg(3,2)=a23der*zj
12921           agg(1,3)=a32der*xj
12922           agg(2,3)=a32der*yj
12923           agg(3,3)=a32der*zj
12924           agg(1,4)=a33der*xj
12925           agg(2,4)=a33der*yj
12926           agg(3,4)=a33der*zj
12927 ! Add the contributions coming from er
12928           fac3=-3.0d0*fac
12929           do k=1,3
12930             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12931             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12932             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12933             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12934           enddo
12935           do k=1,3
12936 ! Derivatives in DC(i)
12937 !grad            ghalf1=0.5d0*agg(k,1)
12938 !grad            ghalf2=0.5d0*agg(k,2)
12939 !grad            ghalf3=0.5d0*agg(k,3)
12940 !grad            ghalf4=0.5d0*agg(k,4)
12941             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12942             -3.0d0*uryg(k,2)*vry)!+ghalf1
12943             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12944             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12945             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12946             -3.0d0*urzg(k,2)*vry)!+ghalf3
12947             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12948             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12949 ! Derivatives in DC(i+1)
12950             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12951             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12952             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12953             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12954             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12955             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12956             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12957             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12958 ! Derivatives in DC(j)
12959             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12960             -3.0d0*vryg(k,2)*ury)!+ghalf1
12961             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12962             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12963             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12964             -3.0d0*vryg(k,2)*urz)!+ghalf3
12965             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12966             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12967 ! Derivatives in DC(j+1) or DC(nres-1)
12968             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12969             -3.0d0*vryg(k,3)*ury)
12970             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12971             -3.0d0*vrzg(k,3)*ury)
12972             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12973             -3.0d0*vryg(k,3)*urz)
12974             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12975             -3.0d0*vrzg(k,3)*urz)
12976 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12977 !grad              do l=1,4
12978 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12979 !grad              enddo
12980 !grad            endif
12981           enddo
12982           acipa(1,1)=a22
12983           acipa(1,2)=a23
12984           acipa(2,1)=a32
12985           acipa(2,2)=a33
12986           a22=-a22
12987           a23=-a23
12988           do l=1,2
12989             do k=1,3
12990               agg(k,l)=-agg(k,l)
12991               aggi(k,l)=-aggi(k,l)
12992               aggi1(k,l)=-aggi1(k,l)
12993               aggj(k,l)=-aggj(k,l)
12994               aggj1(k,l)=-aggj1(k,l)
12995             enddo
12996           enddo
12997           if (j.lt.nres-1) then
12998             a22=-a22
12999             a32=-a32
13000             do l=1,3,2
13001               do k=1,3
13002                 agg(k,l)=-agg(k,l)
13003                 aggi(k,l)=-aggi(k,l)
13004                 aggi1(k,l)=-aggi1(k,l)
13005                 aggj(k,l)=-aggj(k,l)
13006                 aggj1(k,l)=-aggj1(k,l)
13007               enddo
13008             enddo
13009           else
13010             a22=-a22
13011             a23=-a23
13012             a32=-a32
13013             a33=-a33
13014             do l=1,4
13015               do k=1,3
13016                 agg(k,l)=-agg(k,l)
13017                 aggi(k,l)=-aggi(k,l)
13018                 aggi1(k,l)=-aggi1(k,l)
13019                 aggj(k,l)=-aggj(k,l)
13020                 aggj1(k,l)=-aggj1(k,l)
13021               enddo
13022             enddo
13023           endif
13024           ENDIF ! WCORR
13025           IF (wel_loc.gt.0.0d0) THEN
13026 ! Contribution to the local-electrostatic energy coming from the i-j pair
13027           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
13028            +a33*muij(4)
13029 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
13030
13031           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13032                   'eelloc',i,j,eel_loc_ij
13033 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
13034
13035           eel_loc=eel_loc+eel_loc_ij
13036 ! Partial derivatives in virtual-bond dihedral angles gamma
13037           if (i.gt.1) &
13038           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
13039                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
13040                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
13041           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
13042                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
13043                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
13044 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
13045           do l=1,3
13046             ggg(l)=agg(l,1)*muij(1)+ &
13047                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
13048             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
13049             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
13050 !grad            ghalf=0.5d0*ggg(l)
13051 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
13052 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
13053           enddo
13054 !grad          do k=i+1,j2
13055 !grad            do l=1,3
13056 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
13057 !grad            enddo
13058 !grad          enddo
13059 ! Remaining derivatives of eello
13060           do l=1,3
13061             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
13062                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
13063             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
13064                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
13065             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
13066                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
13067             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
13068                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
13069           enddo
13070           ENDIF
13071 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13072 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13073           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13074              .and. num_conti.le.maxconts) then
13075 !            write (iout,*) i,j," entered corr"
13076 !
13077 ! Calculate the contact function. The ith column of the array JCONT will
13078 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13079 ! greater than I). The arrays FACONT and GACONT will contain the values of
13080 ! the contact function and its derivative.
13081 !           r0ij=1.02D0*rpp(iteli,itelj)
13082 !           r0ij=1.11D0*rpp(iteli,itelj)
13083             r0ij=2.20D0*rpp(iteli,itelj)
13084 !           r0ij=1.55D0*rpp(iteli,itelj)
13085             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13086 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13087             if (fcont.gt.0.0D0) then
13088               num_conti=num_conti+1
13089               if (num_conti.gt.maxconts) then
13090 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13091                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13092                                ' will skip next contacts for this conf.',num_conti
13093               else
13094                 jcont_hb(num_conti,i)=j
13095 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13096 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13097                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13098                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13099 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13100 !  terms.
13101                 d_cont(num_conti,i)=rij
13102 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13103 !     --- Electrostatic-interaction matrix ---
13104                 a_chuj(1,1,num_conti,i)=a22
13105                 a_chuj(1,2,num_conti,i)=a23
13106                 a_chuj(2,1,num_conti,i)=a32
13107                 a_chuj(2,2,num_conti,i)=a33
13108 !     --- Gradient of rij
13109                 do kkk=1,3
13110                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13111                 enddo
13112                 kkll=0
13113                 do k=1,2
13114                   do l=1,2
13115                     kkll=kkll+1
13116                     do m=1,3
13117                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13118                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13119                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13120                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13121                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13122                     enddo
13123                   enddo
13124                 enddo
13125                 ENDIF
13126                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13127 ! Calculate contact energies
13128                 cosa4=4.0D0*cosa
13129                 wij=cosa-3.0D0*cosb*cosg
13130                 cosbg1=cosb+cosg
13131                 cosbg2=cosb-cosg
13132 !               fac3=dsqrt(-ael6i)/r0ij**3
13133                 fac3=dsqrt(-ael6i)*r3ij
13134 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13135                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13136                 if (ees0tmp.gt.0) then
13137                   ees0pij=dsqrt(ees0tmp)
13138                 else
13139                   ees0pij=0
13140                 endif
13141 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13142                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13143                 if (ees0tmp.gt.0) then
13144                   ees0mij=dsqrt(ees0tmp)
13145                 else
13146                   ees0mij=0
13147                 endif
13148 !               ees0mij=0.0D0
13149                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13150                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13151 ! Diagnostics. Comment out or remove after debugging!
13152 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13153 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13154 !               ees0m(num_conti,i)=0.0D0
13155 ! End diagnostics.
13156 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13157 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13158 ! Angular derivatives of the contact function
13159                 ees0pij1=fac3/ees0pij
13160                 ees0mij1=fac3/ees0mij
13161                 fac3p=-3.0D0*fac3*rrmij
13162                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13163                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13164 !               ees0mij1=0.0D0
13165                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13166                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13167                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13168                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13169                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13170                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13171                 ecosap=ecosa1+ecosa2
13172                 ecosbp=ecosb1+ecosb2
13173                 ecosgp=ecosg1+ecosg2
13174                 ecosam=ecosa1-ecosa2
13175                 ecosbm=ecosb1-ecosb2
13176                 ecosgm=ecosg1-ecosg2
13177 ! Diagnostics
13178 !               ecosap=ecosa1
13179 !               ecosbp=ecosb1
13180 !               ecosgp=ecosg1
13181 !               ecosam=0.0D0
13182 !               ecosbm=0.0D0
13183 !               ecosgm=0.0D0
13184 ! End diagnostics
13185                 facont_hb(num_conti,i)=fcont
13186                 fprimcont=fprimcont/rij
13187 !d              facont_hb(num_conti,i)=1.0D0
13188 ! Following line is for diagnostics.
13189 !d              fprimcont=0.0D0
13190                 do k=1,3
13191                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13192                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13193                 enddo
13194                 do k=1,3
13195                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13196                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13197                 enddo
13198                 gggp(1)=gggp(1)+ees0pijp*xj
13199                 gggp(2)=gggp(2)+ees0pijp*yj
13200                 gggp(3)=gggp(3)+ees0pijp*zj
13201                 gggm(1)=gggm(1)+ees0mijp*xj
13202                 gggm(2)=gggm(2)+ees0mijp*yj
13203                 gggm(3)=gggm(3)+ees0mijp*zj
13204 ! Derivatives due to the contact function
13205                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13206                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13207                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13208                 do k=1,3
13209 !
13210 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13211 !          following the change of gradient-summation algorithm.
13212 !
13213 !grad                  ghalfp=0.5D0*gggp(k)
13214 !grad                  ghalfm=0.5D0*gggm(k)
13215                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13216                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13217                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13218                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13219                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13220                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13221                   gacontp_hb3(k,num_conti,i)=gggp(k)
13222                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13223                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13224                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13225                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13226                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13227                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13228                   gacontm_hb3(k,num_conti,i)=gggm(k)
13229                 enddo
13230               ENDIF ! wcorr
13231               endif  ! num_conti.le.maxconts
13232             endif  ! fcont.gt.0
13233           endif    ! j.gt.i+1
13234           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13235             do k=1,4
13236               do l=1,3
13237                 ghalf=0.5d0*agg(l,k)
13238                 aggi(l,k)=aggi(l,k)+ghalf
13239                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13240                 aggj(l,k)=aggj(l,k)+ghalf
13241               enddo
13242             enddo
13243             if (j.eq.nres-1 .and. i.lt.j-2) then
13244               do k=1,4
13245                 do l=1,3
13246                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13247                 enddo
13248               enddo
13249             endif
13250           endif
13251 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13252       return
13253       end subroutine eelecij_scale
13254 !-----------------------------------------------------------------------------
13255       subroutine evdwpp_short(evdw1)
13256 !
13257 ! Compute Evdwpp
13258 !
13259 !      implicit real*8 (a-h,o-z)
13260 !      include 'DIMENSIONS'
13261 !      include 'COMMON.CONTROL'
13262 !      include 'COMMON.IOUNITS'
13263 !      include 'COMMON.GEO'
13264 !      include 'COMMON.VAR'
13265 !      include 'COMMON.LOCAL'
13266 !      include 'COMMON.CHAIN'
13267 !      include 'COMMON.DERIV'
13268 !      include 'COMMON.INTERACT'
13269 !      include 'COMMON.CONTACTS'
13270 !      include 'COMMON.TORSION'
13271 !      include 'COMMON.VECTORS'
13272 !      include 'COMMON.FFIELD'
13273       real(kind=8),dimension(3) :: ggg
13274 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13275 #ifdef MOMENT
13276       real(kind=8) :: scal_el=1.0d0
13277 #else
13278       real(kind=8) :: scal_el=0.5d0
13279 #endif
13280 !el local variables
13281       integer :: i,j,k,iteli,itelj,num_conti
13282       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13283       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13284                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13285                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13286
13287       evdw1=0.0D0
13288 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13289 !     & " iatel_e_vdw",iatel_e_vdw
13290       call flush(iout)
13291       do i=iatel_s_vdw,iatel_e_vdw
13292         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13293         dxi=dc(1,i)
13294         dyi=dc(2,i)
13295         dzi=dc(3,i)
13296         dx_normi=dc_norm(1,i)
13297         dy_normi=dc_norm(2,i)
13298         dz_normi=dc_norm(3,i)
13299         xmedi=c(1,i)+0.5d0*dxi
13300         ymedi=c(2,i)+0.5d0*dyi
13301         zmedi=c(3,i)+0.5d0*dzi
13302         num_conti=0
13303 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13304 !     &   ' ielend',ielend_vdw(i)
13305         call flush(iout)
13306         do j=ielstart_vdw(i),ielend_vdw(i)
13307           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13308 !el          ind=ind+1
13309           iteli=itel(i)
13310           itelj=itel(j)
13311           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13312           aaa=app(iteli,itelj)
13313           bbb=bpp(iteli,itelj)
13314           dxj=dc(1,j)
13315           dyj=dc(2,j)
13316           dzj=dc(3,j)
13317           dx_normj=dc_norm(1,j)
13318           dy_normj=dc_norm(2,j)
13319           dz_normj=dc_norm(3,j)
13320           xj=c(1,j)+0.5D0*dxj-xmedi
13321           yj=c(2,j)+0.5D0*dyj-ymedi
13322           zj=c(3,j)+0.5D0*dzj-zmedi
13323           rij=xj*xj+yj*yj+zj*zj
13324           rrmij=1.0D0/rij
13325           rij=dsqrt(rij)
13326           sss=sscale(rij/rpp(iteli,itelj))
13327           if (sss.gt.0.0d0) then
13328             rmij=1.0D0/rij
13329             r3ij=rrmij*rmij
13330             r6ij=r3ij*r3ij
13331             ev1=aaa*r6ij*r6ij
13332 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13333             if (j.eq.i+2) ev1=scal_el*ev1
13334             ev2=bbb*r6ij
13335             evdwij=ev1+ev2
13336             if (energy_dec) then
13337               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13338             endif
13339             evdw1=evdw1+evdwij*sss
13340 !
13341 ! Calculate contributions to the Cartesian gradient.
13342 !
13343             facvdw=-6*rrmij*(ev1+evdwij)*sss
13344             ggg(1)=facvdw*xj
13345             ggg(2)=facvdw*yj
13346             ggg(3)=facvdw*zj
13347             do k=1,3
13348               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13349               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13350             enddo
13351           endif
13352         enddo ! j
13353       enddo   ! i
13354       return
13355       end subroutine evdwpp_short
13356 !-----------------------------------------------------------------------------
13357       subroutine escp_long(evdw2,evdw2_14)
13358 !
13359 ! This subroutine calculates the excluded-volume interaction energy between
13360 ! peptide-group centers and side chains and its gradient in virtual-bond and
13361 ! side-chain vectors.
13362 !
13363 !      implicit real*8 (a-h,o-z)
13364 !      include 'DIMENSIONS'
13365 !      include 'COMMON.GEO'
13366 !      include 'COMMON.VAR'
13367 !      include 'COMMON.LOCAL'
13368 !      include 'COMMON.CHAIN'
13369 !      include 'COMMON.DERIV'
13370 !      include 'COMMON.INTERACT'
13371 !      include 'COMMON.FFIELD'
13372 !      include 'COMMON.IOUNITS'
13373 !      include 'COMMON.CONTROL'
13374       real(kind=8),dimension(3) :: ggg
13375 !el local variables
13376       integer :: i,iint,j,k,iteli,itypj
13377       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13378       real(kind=8) :: evdw2,evdw2_14,evdwij
13379       evdw2=0.0D0
13380       evdw2_14=0.0d0
13381 !d    print '(a)','Enter ESCP'
13382 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13383       do i=iatscp_s,iatscp_e
13384         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13385         iteli=itel(i)
13386         xi=0.5D0*(c(1,i)+c(1,i+1))
13387         yi=0.5D0*(c(2,i)+c(2,i+1))
13388         zi=0.5D0*(c(3,i)+c(3,i+1))
13389
13390         do iint=1,nscp_gr(i)
13391
13392         do j=iscpstart(i,iint),iscpend(i,iint)
13393           itypj=itype(j)
13394           if (itypj.eq.ntyp1) cycle
13395 ! Uncomment following three lines for SC-p interactions
13396 !         xj=c(1,nres+j)-xi
13397 !         yj=c(2,nres+j)-yi
13398 !         zj=c(3,nres+j)-zi
13399 ! Uncomment following three lines for Ca-p interactions
13400           xj=c(1,j)-xi
13401           yj=c(2,j)-yi
13402           zj=c(3,j)-zi
13403           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13404
13405           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13406
13407           if (sss.lt.1.0d0) then
13408
13409             fac=rrij**expon2
13410             e1=fac*fac*aad(itypj,iteli)
13411             e2=fac*bad(itypj,iteli)
13412             if (iabs(j-i) .le. 2) then
13413               e1=scal14*e1
13414               e2=scal14*e2
13415               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13416             endif
13417             evdwij=e1+e2
13418             evdw2=evdw2+evdwij*(1.0d0-sss)
13419             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13420                 'evdw2',i,j,sss,evdwij
13421 !
13422 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13423 !
13424             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13425             ggg(1)=xj*fac
13426             ggg(2)=yj*fac
13427             ggg(3)=zj*fac
13428 ! Uncomment following three lines for SC-p interactions
13429 !           do k=1,3
13430 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13431 !           enddo
13432 ! Uncomment following line for SC-p interactions
13433 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13434             do k=1,3
13435               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13436               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13437             enddo
13438           endif
13439         enddo
13440
13441         enddo ! iint
13442       enddo ! i
13443       do i=1,nct
13444         do j=1,3
13445           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13446           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13447           gradx_scp(j,i)=expon*gradx_scp(j,i)
13448         enddo
13449       enddo
13450 !******************************************************************************
13451 !
13452 !                              N O T E !!!
13453 !
13454 ! To save time the factor EXPON has been extracted from ALL components
13455 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13456 ! use!
13457 !
13458 !******************************************************************************
13459       return
13460       end subroutine escp_long
13461 !-----------------------------------------------------------------------------
13462       subroutine escp_short(evdw2,evdw2_14)
13463 !
13464 ! This subroutine calculates the excluded-volume interaction energy between
13465 ! peptide-group centers and side chains and its gradient in virtual-bond and
13466 ! side-chain vectors.
13467 !
13468 !      implicit real*8 (a-h,o-z)
13469 !      include 'DIMENSIONS'
13470 !      include 'COMMON.GEO'
13471 !      include 'COMMON.VAR'
13472 !      include 'COMMON.LOCAL'
13473 !      include 'COMMON.CHAIN'
13474 !      include 'COMMON.DERIV'
13475 !      include 'COMMON.INTERACT'
13476 !      include 'COMMON.FFIELD'
13477 !      include 'COMMON.IOUNITS'
13478 !      include 'COMMON.CONTROL'
13479       real(kind=8),dimension(3) :: ggg
13480 !el local variables
13481       integer :: i,iint,j,k,iteli,itypj
13482       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13483       real(kind=8) :: evdw2,evdw2_14,evdwij
13484       evdw2=0.0D0
13485       evdw2_14=0.0d0
13486 !d    print '(a)','Enter ESCP'
13487 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13488       do i=iatscp_s,iatscp_e
13489         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13490         iteli=itel(i)
13491         xi=0.5D0*(c(1,i)+c(1,i+1))
13492         yi=0.5D0*(c(2,i)+c(2,i+1))
13493         zi=0.5D0*(c(3,i)+c(3,i+1))
13494
13495         do iint=1,nscp_gr(i)
13496
13497         do j=iscpstart(i,iint),iscpend(i,iint)
13498           itypj=itype(j)
13499           if (itypj.eq.ntyp1) cycle
13500 ! Uncomment following three lines for SC-p interactions
13501 !         xj=c(1,nres+j)-xi
13502 !         yj=c(2,nres+j)-yi
13503 !         zj=c(3,nres+j)-zi
13504 ! Uncomment following three lines for Ca-p interactions
13505           xj=c(1,j)-xi
13506           yj=c(2,j)-yi
13507           zj=c(3,j)-zi
13508           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13509
13510           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13511
13512           if (sss.gt.0.0d0) then
13513
13514             fac=rrij**expon2
13515             e1=fac*fac*aad(itypj,iteli)
13516             e2=fac*bad(itypj,iteli)
13517             if (iabs(j-i) .le. 2) then
13518               e1=scal14*e1
13519               e2=scal14*e2
13520               evdw2_14=evdw2_14+(e1+e2)*sss
13521             endif
13522             evdwij=e1+e2
13523             evdw2=evdw2+evdwij*sss
13524             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13525                 'evdw2',i,j,sss,evdwij
13526 !
13527 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13528 !
13529             fac=-(evdwij+e1)*rrij*sss
13530             ggg(1)=xj*fac
13531             ggg(2)=yj*fac
13532             ggg(3)=zj*fac
13533 ! Uncomment following three lines for SC-p interactions
13534 !           do k=1,3
13535 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13536 !           enddo
13537 ! Uncomment following line for SC-p interactions
13538 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13539             do k=1,3
13540               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13541               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13542             enddo
13543           endif
13544         enddo
13545
13546         enddo ! iint
13547       enddo ! i
13548       do i=1,nct
13549         do j=1,3
13550           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13551           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13552           gradx_scp(j,i)=expon*gradx_scp(j,i)
13553         enddo
13554       enddo
13555 !******************************************************************************
13556 !
13557 !                              N O T E !!!
13558 !
13559 ! To save time the factor EXPON has been extracted from ALL components
13560 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13561 ! use!
13562 !
13563 !******************************************************************************
13564       return
13565       end subroutine escp_short
13566 !-----------------------------------------------------------------------------
13567 ! energy_p_new-sep_barrier.F
13568 !-----------------------------------------------------------------------------
13569       subroutine sc_grad_scale(scalfac)
13570 !      implicit real*8 (a-h,o-z)
13571       use calc_data
13572 !      include 'DIMENSIONS'
13573 !      include 'COMMON.CHAIN'
13574 !      include 'COMMON.DERIV'
13575 !      include 'COMMON.CALC'
13576 !      include 'COMMON.IOUNITS'
13577       real(kind=8),dimension(3) :: dcosom1,dcosom2
13578       real(kind=8) :: scalfac
13579 !el local variables
13580 !      integer :: i,j,k,l
13581
13582       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13583       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13584       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13585            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13586 ! diagnostics only
13587 !      eom1=0.0d0
13588 !      eom2=0.0d0
13589 !      eom12=evdwij*eps1_om12
13590 ! end diagnostics
13591 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13592 !     &  " sigder",sigder
13593 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13594 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13595       do k=1,3
13596         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13597         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13598       enddo
13599       do k=1,3
13600         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13601          *sss_ele_cut
13602       enddo
13603 !      write (iout,*) "gg",(gg(k),k=1,3)
13604       do k=1,3
13605         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13606                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13607                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13608                  *sss_ele_cut
13609         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13610                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13611                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13612          *sss_ele_cut
13613 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13614 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13615 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13616 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13617       enddo
13618 !
13619 ! Calculate the components of the gradient in DC and X
13620 !
13621       do l=1,3
13622         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13623         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13624       enddo
13625       return
13626       end subroutine sc_grad_scale
13627 !-----------------------------------------------------------------------------
13628 ! energy_split-sep.F
13629 !-----------------------------------------------------------------------------
13630       subroutine etotal_long(energia)
13631 !
13632 ! Compute the long-range slow-varying contributions to the energy
13633 !
13634 !      implicit real*8 (a-h,o-z)
13635 !      include 'DIMENSIONS'
13636       use MD_data, only: totT,usampl,eq_time
13637 #ifndef ISNAN
13638       external proc_proc
13639 #ifdef WINPGI
13640 !MS$ATTRIBUTES C ::  proc_proc
13641 #endif
13642 #endif
13643 #ifdef MPI
13644       include "mpif.h"
13645       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13646 #endif
13647 !      include 'COMMON.SETUP'
13648 !      include 'COMMON.IOUNITS'
13649 !      include 'COMMON.FFIELD'
13650 !      include 'COMMON.DERIV'
13651 !      include 'COMMON.INTERACT'
13652 !      include 'COMMON.SBRIDGE'
13653 !      include 'COMMON.CHAIN'
13654 !      include 'COMMON.VAR'
13655 !      include 'COMMON.LOCAL'
13656 !      include 'COMMON.MD'
13657       real(kind=8),dimension(0:n_ene) :: energia
13658 !el local variables
13659       integer :: i,n_corr,n_corr1,ierror,ierr
13660       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13661                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13662                   ecorr,ecorr5,ecorr6,eturn6,time00
13663 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13664 !elwrite(iout,*)"in etotal long"
13665
13666       if (modecalc.eq.12.or.modecalc.eq.14) then
13667 #ifdef MPI
13668 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13669 #else
13670         call int_from_cart1(.false.)
13671 #endif
13672       endif
13673 !elwrite(iout,*)"in etotal long"
13674
13675 #ifdef MPI
13676 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13677 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13678       call flush(iout)
13679       if (nfgtasks.gt.1) then
13680         time00=MPI_Wtime()
13681 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13682         if (fg_rank.eq.0) then
13683           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13684 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13685 !          call flush(iout)
13686 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13687 ! FG slaves as WEIGHTS array.
13688           weights_(1)=wsc
13689           weights_(2)=wscp
13690           weights_(3)=welec
13691           weights_(4)=wcorr
13692           weights_(5)=wcorr5
13693           weights_(6)=wcorr6
13694           weights_(7)=wel_loc
13695           weights_(8)=wturn3
13696           weights_(9)=wturn4
13697           weights_(10)=wturn6
13698           weights_(11)=wang
13699           weights_(12)=wscloc
13700           weights_(13)=wtor
13701           weights_(14)=wtor_d
13702           weights_(15)=wstrain
13703           weights_(16)=wvdwpp
13704           weights_(17)=wbond
13705           weights_(18)=scal14
13706           weights_(21)=wsccor
13707 ! FG Master broadcasts the WEIGHTS_ array
13708           call MPI_Bcast(weights_(1),n_ene,&
13709               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13710         else
13711 ! FG slaves receive the WEIGHTS array
13712           call MPI_Bcast(weights(1),n_ene,&
13713               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13714           wsc=weights(1)
13715           wscp=weights(2)
13716           welec=weights(3)
13717           wcorr=weights(4)
13718           wcorr5=weights(5)
13719           wcorr6=weights(6)
13720           wel_loc=weights(7)
13721           wturn3=weights(8)
13722           wturn4=weights(9)
13723           wturn6=weights(10)
13724           wang=weights(11)
13725           wscloc=weights(12)
13726           wtor=weights(13)
13727           wtor_d=weights(14)
13728           wstrain=weights(15)
13729           wvdwpp=weights(16)
13730           wbond=weights(17)
13731           scal14=weights(18)
13732           wsccor=weights(21)
13733         endif
13734         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13735           king,FG_COMM,IERR)
13736          time_Bcast=time_Bcast+MPI_Wtime()-time00
13737          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13738 !        call chainbuild_cart
13739 !        call int_from_cart1(.false.)
13740       endif
13741 !      write (iout,*) 'Processor',myrank,
13742 !     &  ' calling etotal_short ipot=',ipot
13743 !      call flush(iout)
13744 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13745 #endif
13746 !d    print *,'nnt=',nnt,' nct=',nct
13747 !
13748 !elwrite(iout,*)"in etotal long"
13749 ! Compute the side-chain and electrostatic interaction energy
13750 !
13751       goto (101,102,103,104,105,106) ipot
13752 ! Lennard-Jones potential.
13753   101 call elj_long(evdw)
13754 !d    print '(a)','Exit ELJ'
13755       goto 107
13756 ! Lennard-Jones-Kihara potential (shifted).
13757   102 call eljk_long(evdw)
13758       goto 107
13759 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13760   103 call ebp_long(evdw)
13761       goto 107
13762 ! Gay-Berne potential (shifted LJ, angular dependence).
13763   104 call egb_long(evdw)
13764       goto 107
13765 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13766   105 call egbv_long(evdw)
13767       goto 107
13768 ! Soft-sphere potential
13769   106 call e_softsphere(evdw)
13770 !
13771 ! Calculate electrostatic (H-bonding) energy of the main chain.
13772 !
13773   107 continue
13774       call vec_and_deriv
13775       if (ipot.lt.6) then
13776 #ifdef SPLITELE
13777          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13778              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13779              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13780              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13781 #else
13782          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13783              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13784              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13785              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13786 #endif
13787            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13788          else
13789             ees=0
13790             evdw1=0
13791             eel_loc=0
13792             eello_turn3=0
13793             eello_turn4=0
13794          endif
13795       else
13796 !        write (iout,*) "Soft-spheer ELEC potential"
13797         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13798          eello_turn4)
13799       endif
13800 !
13801 ! Calculate excluded-volume interaction energy between peptide groups
13802 ! and side chains.
13803 !
13804       if (ipot.lt.6) then
13805        if(wscp.gt.0d0) then
13806         call escp_long(evdw2,evdw2_14)
13807        else
13808         evdw2=0
13809         evdw2_14=0
13810        endif
13811       else
13812         call escp_soft_sphere(evdw2,evdw2_14)
13813       endif
13814 !
13815 ! 12/1/95 Multi-body terms
13816 !
13817       n_corr=0
13818       n_corr1=0
13819       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13820           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13821          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13822 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13823 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13824       else
13825          ecorr=0.0d0
13826          ecorr5=0.0d0
13827          ecorr6=0.0d0
13828          eturn6=0.0d0
13829       endif
13830       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13831          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13832       endif
13833 !
13834 ! If performing constraint dynamics, call the constraint energy
13835 !  after the equilibration time
13836       if(usampl.and.totT.gt.eq_time) then
13837          call EconstrQ
13838          call Econstr_back
13839       else
13840          Uconst=0.0d0
13841          Uconst_back=0.0d0
13842       endif
13843 !
13844 ! Sum the energies
13845 !
13846       do i=1,n_ene
13847         energia(i)=0.0d0
13848       enddo
13849       energia(1)=evdw
13850 #ifdef SCP14
13851       energia(2)=evdw2-evdw2_14
13852       energia(18)=evdw2_14
13853 #else
13854       energia(2)=evdw2
13855       energia(18)=0.0d0
13856 #endif
13857 #ifdef SPLITELE
13858       energia(3)=ees
13859       energia(16)=evdw1
13860 #else
13861       energia(3)=ees+evdw1
13862       energia(16)=0.0d0
13863 #endif
13864       energia(4)=ecorr
13865       energia(5)=ecorr5
13866       energia(6)=ecorr6
13867       energia(7)=eel_loc
13868       energia(8)=eello_turn3
13869       energia(9)=eello_turn4
13870       energia(10)=eturn6
13871       energia(20)=Uconst+Uconst_back
13872       call sum_energy(energia,.true.)
13873 !      write (iout,*) "Exit ETOTAL_LONG"
13874       call flush(iout)
13875       return
13876       end subroutine etotal_long
13877 !-----------------------------------------------------------------------------
13878       subroutine etotal_short(energia)
13879 !
13880 ! Compute the short-range fast-varying contributions to the energy
13881 !
13882 !      implicit real*8 (a-h,o-z)
13883 !      include 'DIMENSIONS'
13884 #ifndef ISNAN
13885       external proc_proc
13886 #ifdef WINPGI
13887 !MS$ATTRIBUTES C ::  proc_proc
13888 #endif
13889 #endif
13890 #ifdef MPI
13891       include "mpif.h"
13892       integer :: ierror,ierr
13893       real(kind=8),dimension(n_ene) :: weights_
13894       real(kind=8) :: time00
13895 #endif
13896 !      include 'COMMON.SETUP'
13897 !      include 'COMMON.IOUNITS'
13898 !      include 'COMMON.FFIELD'
13899 !      include 'COMMON.DERIV'
13900 !      include 'COMMON.INTERACT'
13901 !      include 'COMMON.SBRIDGE'
13902 !      include 'COMMON.CHAIN'
13903 !      include 'COMMON.VAR'
13904 !      include 'COMMON.LOCAL'
13905       real(kind=8),dimension(0:n_ene) :: energia
13906 !el local variables
13907       integer :: i,nres6
13908       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13909       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13910       nres6=6*nres
13911
13912 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13913 !      call flush(iout)
13914       if (modecalc.eq.12.or.modecalc.eq.14) then
13915 #ifdef MPI
13916         if (fg_rank.eq.0) call int_from_cart1(.false.)
13917 #else
13918         call int_from_cart1(.false.)
13919 #endif
13920       endif
13921 #ifdef MPI
13922 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13923 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13924 !      call flush(iout)
13925       if (nfgtasks.gt.1) then
13926         time00=MPI_Wtime()
13927 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13928         if (fg_rank.eq.0) then
13929           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13930 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13931 !          call flush(iout)
13932 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13933 ! FG slaves as WEIGHTS array.
13934           weights_(1)=wsc
13935           weights_(2)=wscp
13936           weights_(3)=welec
13937           weights_(4)=wcorr
13938           weights_(5)=wcorr5
13939           weights_(6)=wcorr6
13940           weights_(7)=wel_loc
13941           weights_(8)=wturn3
13942           weights_(9)=wturn4
13943           weights_(10)=wturn6
13944           weights_(11)=wang
13945           weights_(12)=wscloc
13946           weights_(13)=wtor
13947           weights_(14)=wtor_d
13948           weights_(15)=wstrain
13949           weights_(16)=wvdwpp
13950           weights_(17)=wbond
13951           weights_(18)=scal14
13952           weights_(21)=wsccor
13953 ! FG Master broadcasts the WEIGHTS_ array
13954           call MPI_Bcast(weights_(1),n_ene,&
13955               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13956         else
13957 ! FG slaves receive the WEIGHTS array
13958           call MPI_Bcast(weights(1),n_ene,&
13959               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13960           wsc=weights(1)
13961           wscp=weights(2)
13962           welec=weights(3)
13963           wcorr=weights(4)
13964           wcorr5=weights(5)
13965           wcorr6=weights(6)
13966           wel_loc=weights(7)
13967           wturn3=weights(8)
13968           wturn4=weights(9)
13969           wturn6=weights(10)
13970           wang=weights(11)
13971           wscloc=weights(12)
13972           wtor=weights(13)
13973           wtor_d=weights(14)
13974           wstrain=weights(15)
13975           wvdwpp=weights(16)
13976           wbond=weights(17)
13977           scal14=weights(18)
13978           wsccor=weights(21)
13979         endif
13980 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13981         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13982           king,FG_COMM,IERR)
13983 !        write (iout,*) "Processor",myrank," BROADCAST c"
13984         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13985           king,FG_COMM,IERR)
13986 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13987         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13988           king,FG_COMM,IERR)
13989 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13990         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13991           king,FG_COMM,IERR)
13992 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13993         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13994           king,FG_COMM,IERR)
13995 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13996         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13997           king,FG_COMM,IERR)
13998 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13999         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
14000           king,FG_COMM,IERR)
14001 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
14002         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
14003           king,FG_COMM,IERR)
14004 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
14005         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
14006           king,FG_COMM,IERR)
14007          time_Bcast=time_Bcast+MPI_Wtime()-time00
14008 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
14009       endif
14010 !      write (iout,*) 'Processor',myrank,
14011 !     &  ' calling etotal_short ipot=',ipot
14012 !      call flush(iout)
14013 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14014 #endif
14015 !      call int_from_cart1(.false.)
14016 !
14017 ! Compute the side-chain and electrostatic interaction energy
14018 !
14019       goto (101,102,103,104,105,106) ipot
14020 ! Lennard-Jones potential.
14021   101 call elj_short(evdw)
14022 !d    print '(a)','Exit ELJ'
14023       goto 107
14024 ! Lennard-Jones-Kihara potential (shifted).
14025   102 call eljk_short(evdw)
14026       goto 107
14027 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14028   103 call ebp_short(evdw)
14029       goto 107
14030 ! Gay-Berne potential (shifted LJ, angular dependence).
14031   104 call egb_short(evdw)
14032       goto 107
14033 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14034   105 call egbv_short(evdw)
14035       goto 107
14036 ! Soft-sphere potential - already dealt with in the long-range part
14037   106 evdw=0.0d0
14038 !  106 call e_softsphere_short(evdw)
14039 !
14040 ! Calculate electrostatic (H-bonding) energy of the main chain.
14041 !
14042   107 continue
14043 !
14044 ! Calculate the short-range part of Evdwpp
14045 !
14046       call evdwpp_short(evdw1)
14047 !
14048 ! Calculate the short-range part of ESCp
14049 !
14050       if (ipot.lt.6) then
14051         call escp_short(evdw2,evdw2_14)
14052       endif
14053 !
14054 ! Calculate the bond-stretching energy
14055 !
14056       call ebond(estr)
14057 !
14058 ! Calculate the disulfide-bridge and other energy and the contributions
14059 ! from other distance constraints.
14060       call edis(ehpb)
14061 !
14062 ! Calculate the virtual-bond-angle energy.
14063 !
14064       call ebend(ebe)
14065 !
14066 ! Calculate the SC local energy.
14067 !
14068       call vec_and_deriv
14069       call esc(escloc)
14070 !
14071 ! Calculate the virtual-bond torsional energy.
14072 !
14073       call etor(etors,edihcnstr)
14074 !
14075 ! 6/23/01 Calculate double-torsional energy
14076 !
14077       call etor_d(etors_d)
14078 !
14079 ! 21/5/07 Calculate local sicdechain correlation energy
14080 !
14081       if (wsccor.gt.0.0d0) then
14082         call eback_sc_corr(esccor)
14083       else
14084         esccor=0.0d0
14085       endif
14086 !
14087 ! Put energy components into an array
14088 !
14089       do i=1,n_ene
14090         energia(i)=0.0d0
14091       enddo
14092       energia(1)=evdw
14093 #ifdef SCP14
14094       energia(2)=evdw2-evdw2_14
14095       energia(18)=evdw2_14
14096 #else
14097       energia(2)=evdw2
14098       energia(18)=0.0d0
14099 #endif
14100 #ifdef SPLITELE
14101       energia(16)=evdw1
14102 #else
14103       energia(3)=evdw1
14104 #endif
14105       energia(11)=ebe
14106       energia(12)=escloc
14107       energia(13)=etors
14108       energia(14)=etors_d
14109       energia(15)=ehpb
14110       energia(17)=estr
14111       energia(19)=edihcnstr
14112       energia(21)=esccor
14113 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14114       call flush(iout)
14115       call sum_energy(energia,.true.)
14116 !      write (iout,*) "Exit ETOTAL_SHORT"
14117       call flush(iout)
14118       return
14119       end subroutine etotal_short
14120 !-----------------------------------------------------------------------------
14121 ! gnmr1.f
14122 !-----------------------------------------------------------------------------
14123       real(kind=8) function gnmr1(y,ymin,ymax)
14124 !      implicit none
14125       real(kind=8) :: y,ymin,ymax
14126       real(kind=8) :: wykl=4.0d0
14127       if (y.lt.ymin) then
14128         gnmr1=(ymin-y)**wykl/wykl
14129       else if (y.gt.ymax) then
14130         gnmr1=(y-ymax)**wykl/wykl
14131       else
14132         gnmr1=0.0d0
14133       endif
14134       return
14135       end function gnmr1
14136 !-----------------------------------------------------------------------------
14137       real(kind=8) function gnmr1prim(y,ymin,ymax)
14138 !      implicit none
14139       real(kind=8) :: y,ymin,ymax
14140       real(kind=8) :: wykl=4.0d0
14141       if (y.lt.ymin) then
14142         gnmr1prim=-(ymin-y)**(wykl-1)
14143       else if (y.gt.ymax) then
14144         gnmr1prim=(y-ymax)**(wykl-1)
14145       else
14146         gnmr1prim=0.0d0
14147       endif
14148       return
14149       end function gnmr1prim
14150 !-----------------------------------------------------------------------------
14151       real(kind=8) function harmonic(y,ymax)
14152 !      implicit none
14153       real(kind=8) :: y,ymax
14154       real(kind=8) :: wykl=2.0d0
14155       harmonic=(y-ymax)**wykl
14156       return
14157       end function harmonic
14158 !-----------------------------------------------------------------------------
14159       real(kind=8) function harmonicprim(y,ymax)
14160       real(kind=8) :: y,ymin,ymax
14161       real(kind=8) :: wykl=2.0d0
14162       harmonicprim=(y-ymax)*wykl
14163       return
14164       end function harmonicprim
14165 !-----------------------------------------------------------------------------
14166 ! gradient_p.F
14167 !-----------------------------------------------------------------------------
14168       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14169
14170       use io_base, only:intout,briefout
14171 !      implicit real*8 (a-h,o-z)
14172 !      include 'DIMENSIONS'
14173 !      include 'COMMON.CHAIN'
14174 !      include 'COMMON.DERIV'
14175 !      include 'COMMON.VAR'
14176 !      include 'COMMON.INTERACT'
14177 !      include 'COMMON.FFIELD'
14178 !      include 'COMMON.MD'
14179 !      include 'COMMON.IOUNITS'
14180       real(kind=8),external :: ufparm
14181       integer :: uiparm(1)
14182       real(kind=8) :: urparm(1)
14183       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14184       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14185       integer :: n,nf,ind,ind1,i,k,j
14186 !
14187 ! This subroutine calculates total internal coordinate gradient.
14188 ! Depending on the number of function evaluations, either whole energy
14189 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14190 ! internal coordinates are reevaluated or only the cartesian-in-internal
14191 ! coordinate derivatives are evaluated. The subroutine was designed to work
14192 ! with SUMSL.
14193 !
14194 !
14195       icg=mod(nf,2)+1
14196
14197 !d      print *,'grad',nf,icg
14198       if (nf-nfl+1) 20,30,40
14199    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14200 !    write (iout,*) 'grad 20'
14201       if (nf.eq.0) return
14202       goto 40
14203    30 call var_to_geom(n,x)
14204       call chainbuild
14205 !    write (iout,*) 'grad 30'
14206 !
14207 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14208 !
14209    40 call cartder
14210 !     write (iout,*) 'grad 40'
14211 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14212 !
14213 ! Convert the Cartesian gradient into internal-coordinate gradient.
14214 !
14215       ind=0
14216       ind1=0
14217       do i=1,nres-2
14218         gthetai=0.0D0
14219         gphii=0.0D0
14220         do j=i+1,nres-1
14221           ind=ind+1
14222 !         ind=indmat(i,j)
14223 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14224           do k=1,3
14225             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14226           enddo
14227           do k=1,3
14228             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14229           enddo
14230         enddo
14231         do j=i+1,nres-1
14232           ind1=ind1+1
14233 !         ind1=indmat(i,j)
14234 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14235           do k=1,3
14236             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14237             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14238           enddo
14239         enddo
14240         if (i.gt.1) g(i-1)=gphii
14241         if (n.gt.nphi) g(nphi+i)=gthetai
14242       enddo
14243       if (n.le.nphi+ntheta) goto 10
14244       do i=2,nres-1
14245         if (itype(i).ne.10) then
14246           galphai=0.0D0
14247           gomegai=0.0D0
14248           do k=1,3
14249             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14250           enddo
14251           do k=1,3
14252             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14253           enddo
14254           g(ialph(i,1))=galphai
14255           g(ialph(i,1)+nside)=gomegai
14256         endif
14257       enddo
14258 !
14259 ! Add the components corresponding to local energy terms.
14260 !
14261    10 continue
14262       do i=1,nvar
14263 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14264         g(i)=g(i)+gloc(i,icg)
14265       enddo
14266 ! Uncomment following three lines for diagnostics.
14267 !d    call intout
14268 !elwrite(iout,*) "in gradient after calling intout"
14269 !d    call briefout(0,0.0d0)
14270 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14271       return
14272       end subroutine gradient
14273 !-----------------------------------------------------------------------------
14274       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14275
14276       use comm_chu
14277 !      implicit real*8 (a-h,o-z)
14278 !      include 'DIMENSIONS'
14279 !      include 'COMMON.DERIV'
14280 !      include 'COMMON.IOUNITS'
14281 !      include 'COMMON.GEO'
14282       integer :: n,nf
14283 !el      integer :: jjj
14284 !el      common /chuju/ jjj
14285       real(kind=8) :: energia(0:n_ene)
14286       integer :: uiparm(1)
14287       real(kind=8) :: urparm(1)
14288       real(kind=8) :: f
14289       real(kind=8),external :: ufparm
14290       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14291 !     if (jjj.gt.0) then
14292 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14293 !     endif
14294       nfl=nf
14295       icg=mod(nf,2)+1
14296 !d      print *,'func',nf,nfl,icg
14297       call var_to_geom(n,x)
14298       call zerograd
14299       call chainbuild
14300 !d    write (iout,*) 'ETOTAL called from FUNC'
14301       call etotal(energia)
14302       call sum_gradient
14303       f=energia(0)
14304 !     if (jjj.gt.0) then
14305 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14306 !       write (iout,*) 'f=',etot
14307 !       jjj=0
14308 !     endif
14309       return
14310       end subroutine func
14311 !-----------------------------------------------------------------------------
14312       subroutine cartgrad
14313 !      implicit real*8 (a-h,o-z)
14314 !      include 'DIMENSIONS'
14315       use energy_data
14316       use MD_data, only: totT,usampl,eq_time
14317 #ifdef MPI
14318       include 'mpif.h'
14319 #endif
14320 !      include 'COMMON.CHAIN'
14321 !      include 'COMMON.DERIV'
14322 !      include 'COMMON.VAR'
14323 !      include 'COMMON.INTERACT'
14324 !      include 'COMMON.FFIELD'
14325 !      include 'COMMON.MD'
14326 !      include 'COMMON.IOUNITS'
14327 !      include 'COMMON.TIME1'
14328 !
14329       integer :: i,j
14330
14331 ! This subrouting calculates total Cartesian coordinate gradient.
14332 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14333 !
14334 !el#define DEBUG
14335 #ifdef TIMING
14336       time00=MPI_Wtime()
14337 #endif
14338       icg=1
14339       call sum_gradient
14340 #ifdef TIMING
14341 #endif
14342 !el      write (iout,*) "After sum_gradient"
14343 #ifdef DEBUG
14344 !el      write (iout,*) "After sum_gradient"
14345       do i=1,nres-1
14346         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14347         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14348       enddo
14349 #endif
14350 ! If performing constraint dynamics, add the gradients of the constraint energy
14351       if(usampl.and.totT.gt.eq_time) then
14352          do i=1,nct
14353            do j=1,3
14354              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14355              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14356            enddo
14357          enddo
14358          do i=1,nres-3
14359            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14360          enddo
14361          do i=1,nres-2
14362            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14363          enddo
14364       endif
14365 !elwrite (iout,*) "After sum_gradient"
14366 #ifdef TIMING
14367       time01=MPI_Wtime()
14368 #endif
14369       call intcartderiv
14370 !elwrite (iout,*) "After sum_gradient"
14371 #ifdef TIMING
14372       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14373 #endif
14374 !     call checkintcartgrad
14375 !     write(iout,*) 'calling int_to_cart'
14376 #ifdef DEBUG
14377       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14378 #endif
14379       do i=1,nct
14380         do j=1,3
14381           gcart(j,i)=gradc(j,i,icg)
14382           gxcart(j,i)=gradx(j,i,icg)
14383         enddo
14384 #ifdef DEBUG
14385         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14386           (gxcart(j,i),j=1,3),gloc(i,icg)
14387 #endif
14388       enddo
14389 #ifdef TIMING
14390       time01=MPI_Wtime()
14391 #endif
14392       call int_to_cart
14393 #ifdef TIMING
14394       time_inttocart=time_inttocart+MPI_Wtime()-time01
14395 #endif
14396 #ifdef DEBUG
14397       write (iout,*) "gcart and gxcart after int_to_cart"
14398       do i=0,nres-1
14399         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14400             (gxcart(j,i),j=1,3)
14401       enddo
14402 #endif
14403 #ifdef CARGRAD
14404 #ifdef DEBUG
14405       write (iout,*) "CARGRAD"
14406 #endif
14407       do i=nres,1,-1
14408         do j=1,3
14409           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14410 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14411         enddo
14412 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14413 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14414       enddo
14415 ! Correction: dummy residues
14416         if (nnt.gt.1) then
14417           do j=1,3
14418 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14419             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14420           enddo
14421         endif
14422         if (nct.lt.nres) then
14423           do j=1,3
14424 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14425             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14426           enddo
14427         endif
14428 #endif
14429 #ifdef TIMING
14430       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14431 #endif
14432 !el#undef DEBUG
14433       return
14434       end subroutine cartgrad
14435 !-----------------------------------------------------------------------------
14436       subroutine zerograd
14437 !      implicit real*8 (a-h,o-z)
14438 !      include 'DIMENSIONS'
14439 !      include 'COMMON.DERIV'
14440 !      include 'COMMON.CHAIN'
14441 !      include 'COMMON.VAR'
14442 !      include 'COMMON.MD'
14443 !      include 'COMMON.SCCOR'
14444 !
14445 !el local variables
14446       integer :: i,j,intertyp
14447 ! Initialize Cartesian-coordinate gradient
14448 !
14449 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14450 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14451
14452 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14453 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14454 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14455 !      allocate(gradcorr_long(3,nres))
14456 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14457 !      allocate(gcorr6_turn_long(3,nres))
14458 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14459
14460 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14461
14462 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14463 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14464
14465 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14466 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14467
14468 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14469 !      allocate(gscloc(3,nres)) !(3,maxres)
14470 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14471
14472
14473
14474 !      common /deriv_scloc/
14475 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14476 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14477 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14478 !      common /mpgrad/
14479 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14480
14481
14482
14483 !          gradc(j,i,icg)=0.0d0
14484 !          gradx(j,i,icg)=0.0d0
14485
14486 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14487 !elwrite(iout,*) "icg",icg
14488       do i=1,nres
14489         do j=1,3
14490           gvdwx(j,i)=0.0D0
14491           gradx_scp(j,i)=0.0D0
14492           gvdwc(j,i)=0.0D0
14493           gvdwc_scp(j,i)=0.0D0
14494           gvdwc_scpp(j,i)=0.0d0
14495           gelc(j,i)=0.0D0
14496           gelc_long(j,i)=0.0D0
14497           gradb(j,i)=0.0d0
14498           gradbx(j,i)=0.0d0
14499           gvdwpp(j,i)=0.0d0
14500           gel_loc(j,i)=0.0d0
14501           gel_loc_long(j,i)=0.0d0
14502           ghpbc(j,i)=0.0D0
14503           ghpbx(j,i)=0.0D0
14504           gcorr3_turn(j,i)=0.0d0
14505           gcorr4_turn(j,i)=0.0d0
14506           gradcorr(j,i)=0.0d0
14507           gradcorr_long(j,i)=0.0d0
14508           gradcorr5_long(j,i)=0.0d0
14509           gradcorr6_long(j,i)=0.0d0
14510           gcorr6_turn_long(j,i)=0.0d0
14511           gradcorr5(j,i)=0.0d0
14512           gradcorr6(j,i)=0.0d0
14513           gcorr6_turn(j,i)=0.0d0
14514           gsccorc(j,i)=0.0d0
14515           gsccorx(j,i)=0.0d0
14516           gradc(j,i,icg)=0.0d0
14517           gradx(j,i,icg)=0.0d0
14518           gscloc(j,i)=0.0d0
14519           gsclocx(j,i)=0.0d0
14520           do intertyp=1,3
14521            gloc_sc(intertyp,i,icg)=0.0d0
14522           enddo
14523         enddo
14524       enddo
14525 !
14526 ! Initialize the gradient of local energy terms.
14527 !
14528 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14529 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14530 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14531 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14532 !      allocate(gel_loc_turn3(nres))
14533 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14534 !      allocate(gsccor_loc(nres))       !(maxres)
14535
14536       do i=1,4*nres
14537         gloc(i,icg)=0.0D0
14538       enddo
14539       do i=1,nres
14540         gel_loc_loc(i)=0.0d0
14541         gcorr_loc(i)=0.0d0
14542         g_corr5_loc(i)=0.0d0
14543         g_corr6_loc(i)=0.0d0
14544         gel_loc_turn3(i)=0.0d0
14545         gel_loc_turn4(i)=0.0d0
14546         gel_loc_turn6(i)=0.0d0
14547         gsccor_loc(i)=0.0d0
14548       enddo
14549 ! initialize gcart and gxcart
14550 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14551       do i=0,nres
14552         do j=1,3
14553           gcart(j,i)=0.0d0
14554           gxcart(j,i)=0.0d0
14555         enddo
14556       enddo
14557       return
14558       end subroutine zerograd
14559 !-----------------------------------------------------------------------------
14560       real(kind=8) function fdum()
14561       fdum=0.0D0
14562       return
14563       end function fdum
14564 !-----------------------------------------------------------------------------
14565 ! intcartderiv.F
14566 !-----------------------------------------------------------------------------
14567       subroutine intcartderiv
14568 !      implicit real*8 (a-h,o-z)
14569 !      include 'DIMENSIONS'
14570 #ifdef MPI
14571       include 'mpif.h'
14572 #endif
14573 !      include 'COMMON.SETUP'
14574 !      include 'COMMON.CHAIN'
14575 !      include 'COMMON.VAR'
14576 !      include 'COMMON.GEO'
14577 !      include 'COMMON.INTERACT'
14578 !      include 'COMMON.DERIV'
14579 !      include 'COMMON.IOUNITS'
14580 !      include 'COMMON.LOCAL'
14581 !      include 'COMMON.SCCOR'
14582       real(kind=8) :: pi4,pi34
14583       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14584       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14585                     dcosomega,dsinomega !(3,3,maxres)
14586       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14587
14588       integer :: i,j,k
14589       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14590                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14591                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14592                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14593       integer :: nres2
14594       nres2=2*nres
14595
14596 !el from module energy-------------
14597 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14598 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14599 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14600
14601 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14602 !el      allocate(dsintau(3,3,3,0:nres2))
14603 !el      allocate(dtauangle(3,3,3,0:nres2))
14604 !el      allocate(domicron(3,2,2,0:nres2))
14605 !el      allocate(dcosomicron(3,2,2,0:nres2))
14606
14607
14608
14609 #if defined(MPI) && defined(PARINTDER)
14610       if (nfgtasks.gt.1 .and. me.eq.king) &
14611         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14612 #endif
14613       pi4 = 0.5d0*pipol
14614       pi34 = 3*pi4
14615
14616 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14617 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14618
14619 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14620       do i=1,nres
14621         do j=1,3
14622           dtheta(j,1,i)=0.0d0
14623           dtheta(j,2,i)=0.0d0
14624           dphi(j,1,i)=0.0d0
14625           dphi(j,2,i)=0.0d0
14626           dphi(j,3,i)=0.0d0
14627         enddo
14628       enddo
14629 ! Derivatives of theta's
14630 #if defined(MPI) && defined(PARINTDER)
14631 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14632       do i=max0(ithet_start-1,3),ithet_end
14633 #else
14634       do i=3,nres
14635 #endif
14636         cost=dcos(theta(i))
14637         sint=sqrt(1-cost*cost)
14638         do j=1,3
14639           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14640           vbld(i-1)
14641           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14642           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14643           vbld(i)
14644           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14645         enddo
14646       enddo
14647 #if defined(MPI) && defined(PARINTDER)
14648 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14649       do i=max0(ithet_start-1,3),ithet_end
14650 #else
14651       do i=3,nres
14652 #endif
14653       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14654         cost1=dcos(omicron(1,i))
14655         sint1=sqrt(1-cost1*cost1)
14656         cost2=dcos(omicron(2,i))
14657         sint2=sqrt(1-cost2*cost2)
14658        do j=1,3
14659 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14660           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14661           cost1*dc_norm(j,i-2))/ &
14662           vbld(i-1)
14663           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14664           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14665           +cost1*(dc_norm(j,i-1+nres)))/ &
14666           vbld(i-1+nres)
14667           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14668 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14669 !C Looks messy but better than if in loop
14670           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14671           +cost2*dc_norm(j,i-1))/ &
14672           vbld(i)
14673           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14674           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14675            +cost2*(-dc_norm(j,i-1+nres)))/ &
14676           vbld(i-1+nres)
14677 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14678           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14679         enddo
14680        endif
14681       enddo
14682 !elwrite(iout,*) "after vbld write"
14683 ! Derivatives of phi:
14684 ! If phi is 0 or 180 degrees, then the formulas
14685 ! have to be derived by power series expansion of the
14686 ! conventional formulas around 0 and 180.
14687 #ifdef PARINTDER
14688       do i=iphi1_start,iphi1_end
14689 #else
14690       do i=4,nres
14691 #endif
14692 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14693 ! the conventional case
14694         sint=dsin(theta(i))
14695         sint1=dsin(theta(i-1))
14696         sing=dsin(phi(i))
14697         cost=dcos(theta(i))
14698         cost1=dcos(theta(i-1))
14699         cosg=dcos(phi(i))
14700         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14701         fac0=1.0d0/(sint1*sint)
14702         fac1=cost*fac0
14703         fac2=cost1*fac0
14704         fac3=cosg*cost1/(sint1*sint1)
14705         fac4=cosg*cost/(sint*sint)
14706 !    Obtaining the gamma derivatives from sine derivative
14707        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14708            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14709            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14710          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14711          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14712          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14713          do j=1,3
14714             ctgt=cost/sint
14715             ctgt1=cost1/sint1
14716             cosg_inv=1.0d0/cosg
14717             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14718             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14719               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14720             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14721             dsinphi(j,2,i)= &
14722               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14723               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14724             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14725             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14726               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14727 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14728             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14729             endif
14730 ! Bug fixed 3/24/05 (AL)
14731          enddo
14732 !   Obtaining the gamma derivatives from cosine derivative
14733         else
14734            do j=1,3
14735            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14736            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14737            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14738            dc_norm(j,i-3))/vbld(i-2)
14739            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14740            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14741            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14742            dcostheta(j,1,i)
14743            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14744            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14745            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14746            dc_norm(j,i-1))/vbld(i)
14747            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14748            endif
14749          enddo
14750         endif
14751       enddo
14752 !alculate derivative of Tauangle
14753 #ifdef PARINTDER
14754       do i=itau_start,itau_end
14755 #else
14756       do i=3,nres
14757 !elwrite(iout,*) " vecpr",i,nres
14758 #endif
14759        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14760 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14761 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14762 !c dtauangle(j,intertyp,dervityp,residue number)
14763 !c INTERTYP=1 SC...Ca...Ca..Ca
14764 ! the conventional case
14765         sint=dsin(theta(i))
14766         sint1=dsin(omicron(2,i-1))
14767         sing=dsin(tauangle(1,i))
14768         cost=dcos(theta(i))
14769         cost1=dcos(omicron(2,i-1))
14770         cosg=dcos(tauangle(1,i))
14771 !elwrite(iout,*) " vecpr5",i,nres
14772         do j=1,3
14773 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14774 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14775         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14776 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14777         enddo
14778         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14779         fac0=1.0d0/(sint1*sint)
14780         fac1=cost*fac0
14781         fac2=cost1*fac0
14782         fac3=cosg*cost1/(sint1*sint1)
14783         fac4=cosg*cost/(sint*sint)
14784 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14785 !    Obtaining the gamma derivatives from sine derivative
14786        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14787            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14788            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14789          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14790          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14791          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14792         do j=1,3
14793             ctgt=cost/sint
14794             ctgt1=cost1/sint1
14795             cosg_inv=1.0d0/cosg
14796             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14797        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14798        *vbld_inv(i-2+nres)
14799             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14800             dsintau(j,1,2,i)= &
14801               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14802               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14803 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14804             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14805 ! Bug fixed 3/24/05 (AL)
14806             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14807               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14808 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14809             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14810          enddo
14811 !   Obtaining the gamma derivatives from cosine derivative
14812         else
14813            do j=1,3
14814            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14815            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14816            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14817            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14818            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14819            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14820            dcostheta(j,1,i)
14821            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14822            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14823            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14824            dc_norm(j,i-1))/vbld(i)
14825            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14826 !         write (iout,*) "else",i
14827          enddo
14828         endif
14829 !        do k=1,3
14830 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14831 !        enddo
14832       enddo
14833 !C Second case Ca...Ca...Ca...SC
14834 #ifdef PARINTDER
14835       do i=itau_start,itau_end
14836 #else
14837       do i=4,nres
14838 #endif
14839        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14840           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14841 ! the conventional case
14842         sint=dsin(omicron(1,i))
14843         sint1=dsin(theta(i-1))
14844         sing=dsin(tauangle(2,i))
14845         cost=dcos(omicron(1,i))
14846         cost1=dcos(theta(i-1))
14847         cosg=dcos(tauangle(2,i))
14848 !        do j=1,3
14849 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14850 !        enddo
14851         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14852         fac0=1.0d0/(sint1*sint)
14853         fac1=cost*fac0
14854         fac2=cost1*fac0
14855         fac3=cosg*cost1/(sint1*sint1)
14856         fac4=cosg*cost/(sint*sint)
14857 !    Obtaining the gamma derivatives from sine derivative
14858        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14859            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14860            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14861          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14862          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14863          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14864         do j=1,3
14865             ctgt=cost/sint
14866             ctgt1=cost1/sint1
14867             cosg_inv=1.0d0/cosg
14868             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14869               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14870 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14871 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14872             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14873             dsintau(j,2,2,i)= &
14874               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14875               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14876 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14877 !     & sing*ctgt*domicron(j,1,2,i),
14878 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14879             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14880 ! Bug fixed 3/24/05 (AL)
14881             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14882              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14883 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14884             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14885          enddo
14886 !   Obtaining the gamma derivatives from cosine derivative
14887         else
14888            do j=1,3
14889            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14890            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14891            dc_norm(j,i-3))/vbld(i-2)
14892            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14893            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14894            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14895            dcosomicron(j,1,1,i)
14896            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14897            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14898            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14899            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14900            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14901 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14902          enddo
14903         endif
14904       enddo
14905
14906 !CC third case SC...Ca...Ca...SC
14907 #ifdef PARINTDER
14908
14909       do i=itau_start,itau_end
14910 #else
14911       do i=3,nres
14912 #endif
14913 ! the conventional case
14914       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14915       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14916         sint=dsin(omicron(1,i))
14917         sint1=dsin(omicron(2,i-1))
14918         sing=dsin(tauangle(3,i))
14919         cost=dcos(omicron(1,i))
14920         cost1=dcos(omicron(2,i-1))
14921         cosg=dcos(tauangle(3,i))
14922         do j=1,3
14923         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14924 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14925         enddo
14926         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14927         fac0=1.0d0/(sint1*sint)
14928         fac1=cost*fac0
14929         fac2=cost1*fac0
14930         fac3=cosg*cost1/(sint1*sint1)
14931         fac4=cosg*cost/(sint*sint)
14932 !    Obtaining the gamma derivatives from sine derivative
14933        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14934            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14935            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14936          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14937          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14938          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14939         do j=1,3
14940             ctgt=cost/sint
14941             ctgt1=cost1/sint1
14942             cosg_inv=1.0d0/cosg
14943             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14944               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14945               *vbld_inv(i-2+nres)
14946             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14947             dsintau(j,3,2,i)= &
14948               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14949               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14950             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14951 ! Bug fixed 3/24/05 (AL)
14952             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14953               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14954               *vbld_inv(i-1+nres)
14955 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14956             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14957          enddo
14958 !   Obtaining the gamma derivatives from cosine derivative
14959         else
14960            do j=1,3
14961            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14962            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14963            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14964            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14965            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14966            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14967            dcosomicron(j,1,1,i)
14968            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14969            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14970            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14971            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14972            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14973 !          write(iout,*) "else",i
14974          enddo
14975         endif
14976       enddo
14977
14978 #ifdef CRYST_SC
14979 !   Derivatives of side-chain angles alpha and omega
14980 #if defined(MPI) && defined(PARINTDER)
14981         do i=ibond_start,ibond_end
14982 #else
14983         do i=2,nres-1
14984 #endif
14985           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14986              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14987              fac6=fac5/vbld(i)
14988              fac7=fac5*fac5
14989              fac8=fac5/vbld(i+1)
14990              fac9=fac5/vbld(i+nres)
14991              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14992              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14993              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14994              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14995              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14996              sina=sqrt(1-cosa*cosa)
14997              sino=dsin(omeg(i))
14998 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14999              do j=1,3
15000                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
15001                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
15002                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
15003                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
15004                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
15005                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
15006                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
15007                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
15008                 vbld(i+nres))
15009                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
15010             enddo
15011 ! obtaining the derivatives of omega from sines
15012             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
15013                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
15014                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
15015                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
15016                dsin(theta(i+1)))
15017                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
15018                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
15019                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
15020                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
15021                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
15022                coso_inv=1.0d0/dcos(omeg(i))
15023                do j=1,3
15024                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
15025                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
15026                  (sino*dc_norm(j,i-1))/vbld(i)
15027                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
15028                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
15029                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
15030                  -sino*dc_norm(j,i)/vbld(i+1)
15031                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
15032                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
15033                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
15034                  vbld(i+nres)
15035                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
15036               enddo
15037            else
15038 !   obtaining the derivatives of omega from cosines
15039              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
15040              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
15041              fac12=fac10*sina
15042              fac13=fac12*fac12
15043              fac14=sina*sina
15044              do j=1,3
15045                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
15046                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
15047                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
15048                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
15049                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
15050                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
15051                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
15052                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
15053                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
15054                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
15055                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
15056                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
15057                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
15058                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
15059                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
15060             enddo
15061           endif
15062          else
15063            do j=1,3
15064              do k=1,3
15065                dalpha(k,j,i)=0.0d0
15066                domega(k,j,i)=0.0d0
15067              enddo
15068            enddo
15069          endif
15070        enddo
15071 #endif
15072 #if defined(MPI) && defined(PARINTDER)
15073       if (nfgtasks.gt.1) then
15074 #ifdef DEBUG
15075 !d      write (iout,*) "Gather dtheta"
15076 !d      call flush(iout)
15077       write (iout,*) "dtheta before gather"
15078       do i=1,nres
15079         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15080       enddo
15081 #endif
15082       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15083         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15084         king,FG_COMM,IERROR)
15085 #ifdef DEBUG
15086 !d      write (iout,*) "Gather dphi"
15087 !d      call flush(iout)
15088       write (iout,*) "dphi before gather"
15089       do i=1,nres
15090         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15091       enddo
15092 #endif
15093       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15094         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15095         king,FG_COMM,IERROR)
15096 !d      write (iout,*) "Gather dalpha"
15097 !d      call flush(iout)
15098 #ifdef CRYST_SC
15099       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15100         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15101         king,FG_COMM,IERROR)
15102 !d      write (iout,*) "Gather domega"
15103 !d      call flush(iout)
15104       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15105         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15106         king,FG_COMM,IERROR)
15107 #endif
15108       endif
15109 #endif
15110 #ifdef DEBUG
15111       write (iout,*) "dtheta after gather"
15112       do i=1,nres
15113         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15114       enddo
15115       write (iout,*) "dphi after gather"
15116       do i=1,nres
15117         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15118       enddo
15119       write (iout,*) "dalpha after gather"
15120       do i=1,nres
15121         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15122       enddo
15123       write (iout,*) "domega after gather"
15124       do i=1,nres
15125         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15126       enddo
15127 #endif
15128       return
15129       end subroutine intcartderiv
15130 !-----------------------------------------------------------------------------
15131       subroutine checkintcartgrad
15132 !      implicit real*8 (a-h,o-z)
15133 !      include 'DIMENSIONS'
15134 #ifdef MPI
15135       include 'mpif.h'
15136 #endif
15137 !      include 'COMMON.CHAIN'
15138 !      include 'COMMON.VAR'
15139 !      include 'COMMON.GEO'
15140 !      include 'COMMON.INTERACT'
15141 !      include 'COMMON.DERIV'
15142 !      include 'COMMON.IOUNITS'
15143 !      include 'COMMON.SETUP'
15144       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15145       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15146       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15147       real(kind=8),dimension(3) :: dc_norm_s
15148       real(kind=8) :: aincr=1.0d-5
15149       integer :: i,j
15150       real(kind=8) :: dcji
15151       do i=1,nres
15152         phi_s(i)=phi(i)
15153         theta_s(i)=theta(i)
15154         alph_s(i)=alph(i)
15155         omeg_s(i)=omeg(i)
15156       enddo
15157 ! Check theta gradient
15158       write (iout,*) &
15159        "Analytical (upper) and numerical (lower) gradient of theta"
15160       write (iout,*)
15161       do i=3,nres
15162         do j=1,3
15163           dcji=dc(j,i-2)
15164           dc(j,i-2)=dcji+aincr
15165           call chainbuild_cart
15166           call int_from_cart1(.false.)
15167           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15168           dc(j,i-2)=dcji
15169           dcji=dc(j,i-1)
15170           dc(j,i-1)=dc(j,i-1)+aincr
15171           call chainbuild_cart
15172           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15173           dc(j,i-1)=dcji
15174         enddo
15175 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15176 !el          (dtheta(j,2,i),j=1,3)
15177 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15178 !el          (dthetanum(j,2,i),j=1,3)
15179 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15180 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15181 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15182 !el        write (iout,*)
15183       enddo
15184 ! Check gamma gradient
15185       write (iout,*) &
15186        "Analytical (upper) and numerical (lower) gradient of gamma"
15187       do i=4,nres
15188         do j=1,3
15189           dcji=dc(j,i-3)
15190           dc(j,i-3)=dcji+aincr
15191           call chainbuild_cart
15192           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15193           dc(j,i-3)=dcji
15194           dcji=dc(j,i-2)
15195           dc(j,i-2)=dcji+aincr
15196           call chainbuild_cart
15197           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15198           dc(j,i-2)=dcji
15199           dcji=dc(j,i-1)
15200           dc(j,i-1)=dc(j,i-1)+aincr
15201           call chainbuild_cart
15202           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15203           dc(j,i-1)=dcji
15204         enddo
15205 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15206 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15207 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15208 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15209 !el        write (iout,'(5x,3(3f10.5,5x))') &
15210 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15211 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15212 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15213 !el        write (iout,*)
15214       enddo
15215 ! Check alpha gradient
15216       write (iout,*) &
15217        "Analytical (upper) and numerical (lower) gradient of alpha"
15218       do i=2,nres-1
15219        if(itype(i).ne.10) then
15220             do j=1,3
15221               dcji=dc(j,i-1)
15222               dc(j,i-1)=dcji+aincr
15223               call chainbuild_cart
15224               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15225               /aincr
15226               dc(j,i-1)=dcji
15227               dcji=dc(j,i)
15228               dc(j,i)=dcji+aincr
15229               call chainbuild_cart
15230               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15231               /aincr
15232               dc(j,i)=dcji
15233               dcji=dc(j,i+nres)
15234               dc(j,i+nres)=dc(j,i+nres)+aincr
15235               call chainbuild_cart
15236               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15237               /aincr
15238              dc(j,i+nres)=dcji
15239             enddo
15240           endif
15241 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15242 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15243 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15244 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15245 !el        write (iout,'(5x,3(3f10.5,5x))') &
15246 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15247 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15248 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15249 !el        write (iout,*)
15250       enddo
15251 !     Check omega gradient
15252       write (iout,*) &
15253        "Analytical (upper) and numerical (lower) gradient of omega"
15254       do i=2,nres-1
15255        if(itype(i).ne.10) then
15256             do j=1,3
15257               dcji=dc(j,i-1)
15258               dc(j,i-1)=dcji+aincr
15259               call chainbuild_cart
15260               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15261               /aincr
15262               dc(j,i-1)=dcji
15263               dcji=dc(j,i)
15264               dc(j,i)=dcji+aincr
15265               call chainbuild_cart
15266               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15267               /aincr
15268               dc(j,i)=dcji
15269               dcji=dc(j,i+nres)
15270               dc(j,i+nres)=dc(j,i+nres)+aincr
15271               call chainbuild_cart
15272               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15273               /aincr
15274              dc(j,i+nres)=dcji
15275             enddo
15276           endif
15277 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15278 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15279 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15280 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15281 !el        write (iout,'(5x,3(3f10.5,5x))') &
15282 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15283 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15284 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15285 !el        write (iout,*)
15286       enddo
15287       return
15288       end subroutine checkintcartgrad
15289 !-----------------------------------------------------------------------------
15290 ! q_measure.F
15291 !-----------------------------------------------------------------------------
15292       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15293 !      implicit real*8 (a-h,o-z)
15294 !      include 'DIMENSIONS'
15295 !      include 'COMMON.IOUNITS'
15296 !      include 'COMMON.CHAIN'
15297 !      include 'COMMON.INTERACT'
15298 !      include 'COMMON.VAR'
15299       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15300       integer :: kkk,nsep=3
15301       real(kind=8) :: qm        !dist,
15302       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15303       logical :: lprn=.false.
15304       logical :: flag
15305 !      real(kind=8) :: sigm,x
15306
15307 !el      sigm(x)=0.25d0*x     ! local function
15308       qqmax=1.0d10
15309       do kkk=1,nperm
15310       qq = 0.0d0
15311       nl=0
15312        if(flag) then
15313         do il=seg1+nsep,seg2
15314           do jl=seg1,il-nsep
15315             nl=nl+1
15316             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15317                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15318                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15319             dij=dist(il,jl)
15320             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15321             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15322               nl=nl+1
15323               d0ijCM=dsqrt( &
15324                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15325                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15326                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15327               dijCM=dist(il+nres,jl+nres)
15328               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15329             endif
15330             qq = qq+qqij+qqijCM
15331           enddo
15332         enddo
15333         qq = qq/nl
15334       else
15335       do il=seg1,seg2
15336         if((seg3-il).lt.3) then
15337              secseg=il+3
15338         else
15339              secseg=seg3
15340         endif
15341           do jl=secseg,seg4
15342             nl=nl+1
15343             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15344                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15345                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15346             dij=dist(il,jl)
15347             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15348             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15349               nl=nl+1
15350               d0ijCM=dsqrt( &
15351                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15352                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15353                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15354               dijCM=dist(il+nres,jl+nres)
15355               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15356             endif
15357             qq = qq+qqij+qqijCM
15358           enddo
15359         enddo
15360       qq = qq/nl
15361       endif
15362       if (qqmax.le.qq) qqmax=qq
15363       enddo
15364       qwolynes=1.0d0-qqmax
15365       return
15366       end function qwolynes
15367 !-----------------------------------------------------------------------------
15368       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15369 !      implicit real*8 (a-h,o-z)
15370 !      include 'DIMENSIONS'
15371 !      include 'COMMON.IOUNITS'
15372 !      include 'COMMON.CHAIN'
15373 !      include 'COMMON.INTERACT'
15374 !      include 'COMMON.VAR'
15375 !      include 'COMMON.MD'
15376       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15377       integer :: nsep=3, kkk
15378 !el      real(kind=8) :: dist
15379       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15380       logical :: lprn=.false.
15381       logical :: flag
15382       real(kind=8) :: sim,dd0,fac,ddqij
15383 !el      sigm(x)=0.25d0*x            ! local function
15384       do kkk=1,nperm
15385       do i=0,nres
15386         do j=1,3
15387           dqwol(j,i)=0.0d0
15388           dxqwol(j,i)=0.0d0
15389         enddo
15390       enddo
15391       nl=0
15392        if(flag) then
15393         do il=seg1+nsep,seg2
15394           do jl=seg1,il-nsep
15395             nl=nl+1
15396             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15397                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15398                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15399             dij=dist(il,jl)
15400             sim = 1.0d0/sigm(d0ij)
15401             sim = sim*sim
15402             dd0 = dij-d0ij
15403             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15404             do k=1,3
15405               ddqij = (c(k,il)-c(k,jl))*fac
15406               dqwol(k,il)=dqwol(k,il)+ddqij
15407               dqwol(k,jl)=dqwol(k,jl)-ddqij
15408             enddo
15409
15410             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15411               nl=nl+1
15412               d0ijCM=dsqrt( &
15413                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15414                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15415                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15416               dijCM=dist(il+nres,jl+nres)
15417               sim = 1.0d0/sigm(d0ijCM)
15418               sim = sim*sim
15419               dd0=dijCM-d0ijCM
15420               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15421               do k=1,3
15422                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15423                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15424                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15425               enddo
15426             endif
15427           enddo
15428         enddo
15429        else
15430         do il=seg1,seg2
15431         if((seg3-il).lt.3) then
15432              secseg=il+3
15433         else
15434              secseg=seg3
15435         endif
15436           do jl=secseg,seg4
15437             nl=nl+1
15438             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15439                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15440                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15441             dij=dist(il,jl)
15442             sim = 1.0d0/sigm(d0ij)
15443             sim = sim*sim
15444             dd0 = dij-d0ij
15445             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15446             do k=1,3
15447               ddqij = (c(k,il)-c(k,jl))*fac
15448               dqwol(k,il)=dqwol(k,il)+ddqij
15449               dqwol(k,jl)=dqwol(k,jl)-ddqij
15450             enddo
15451             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15452               nl=nl+1
15453               d0ijCM=dsqrt( &
15454                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15455                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15456                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15457               dijCM=dist(il+nres,jl+nres)
15458               sim = 1.0d0/sigm(d0ijCM)
15459               sim=sim*sim
15460               dd0 = dijCM-d0ijCM
15461               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15462               do k=1,3
15463                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15464                dxqwol(k,il)=dxqwol(k,il)+ddqij
15465                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15466               enddo
15467             endif
15468           enddo
15469         enddo
15470       endif
15471       enddo
15472        do i=0,nres
15473          do j=1,3
15474            dqwol(j,i)=dqwol(j,i)/nl
15475            dxqwol(j,i)=dxqwol(j,i)/nl
15476          enddo
15477        enddo
15478       return
15479       end subroutine qwolynes_prim
15480 !-----------------------------------------------------------------------------
15481       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15482 !      implicit real*8 (a-h,o-z)
15483 !      include 'DIMENSIONS'
15484 !      include 'COMMON.IOUNITS'
15485 !      include 'COMMON.CHAIN'
15486 !      include 'COMMON.INTERACT'
15487 !      include 'COMMON.VAR'
15488       integer :: seg1,seg2,seg3,seg4
15489       logical :: flag
15490       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15491       real(kind=8),dimension(3,0:2*nres) :: cdummy
15492       real(kind=8) :: q1,q2
15493       real(kind=8) :: delta=1.0d-10
15494       integer :: i,j
15495
15496       do i=0,nres
15497         do j=1,3
15498           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15499           cdummy(j,i)=c(j,i)
15500           c(j,i)=c(j,i)+delta
15501           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15502           qwolan(j,i)=(q2-q1)/delta
15503           c(j,i)=cdummy(j,i)
15504         enddo
15505       enddo
15506       do i=0,nres
15507         do j=1,3
15508           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15509           cdummy(j,i+nres)=c(j,i+nres)
15510           c(j,i+nres)=c(j,i+nres)+delta
15511           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15512           qwolxan(j,i)=(q2-q1)/delta
15513           c(j,i+nres)=cdummy(j,i+nres)
15514         enddo
15515       enddo
15516 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15517 !      do i=0,nct
15518 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15519 !      enddo
15520 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15521 !      do i=0,nct
15522 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15523 !      enddo
15524       return
15525       end subroutine qwol_num
15526 !-----------------------------------------------------------------------------
15527       subroutine EconstrQ
15528 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15529 !      implicit real*8 (a-h,o-z)
15530 !      include 'DIMENSIONS'
15531 !      include 'COMMON.CONTROL'
15532 !      include 'COMMON.VAR'
15533 !      include 'COMMON.MD'
15534       use MD_data
15535 !#ifndef LANG0
15536 !      include 'COMMON.LANGEVIN'
15537 !#else
15538 !      include 'COMMON.LANGEVIN.lang0'
15539 !#endif
15540 !      include 'COMMON.CHAIN'
15541 !      include 'COMMON.DERIV'
15542 !      include 'COMMON.GEO'
15543 !      include 'COMMON.LOCAL'
15544 !      include 'COMMON.INTERACT'
15545 !      include 'COMMON.IOUNITS'
15546 !      include 'COMMON.NAMES'
15547 !      include 'COMMON.TIME1'
15548       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15549       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15550                    duconst,duxconst
15551       integer :: kstart,kend,lstart,lend,idummy
15552       real(kind=8) :: delta=1.0d-7
15553       integer :: i,j,k,ii
15554       do i=0,nres
15555          do j=1,3
15556             duconst(j,i)=0.0d0
15557             dudconst(j,i)=0.0d0
15558             duxconst(j,i)=0.0d0
15559             dudxconst(j,i)=0.0d0
15560          enddo
15561       enddo
15562       Uconst=0.0d0
15563       do i=1,nfrag
15564          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15565            idummy,idummy)
15566          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15567 ! Calculating the derivatives of Constraint energy with respect to Q
15568          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15569            qinfrag(i,iset))
15570 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15571 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15572 !         hmnum=(hm2-hm1)/delta
15573 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15574 !     &   qinfrag(i,iset))
15575 !         write(iout,*) "harmonicnum frag", hmnum
15576 ! Calculating the derivatives of Q with respect to cartesian coordinates
15577          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15578           idummy,idummy)
15579 !         write(iout,*) "dqwol "
15580 !         do ii=1,nres
15581 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15582 !         enddo
15583 !         write(iout,*) "dxqwol "
15584 !         do ii=1,nres
15585 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15586 !         enddo
15587 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15588 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15589 !     &  ,idummy,idummy)
15590 !  The gradients of Uconst in Cs
15591          do ii=0,nres
15592             do j=1,3
15593                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15594                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15595             enddo
15596          enddo
15597       enddo
15598       do i=1,npair
15599          kstart=ifrag(1,ipair(1,i,iset),iset)
15600          kend=ifrag(2,ipair(1,i,iset),iset)
15601          lstart=ifrag(1,ipair(2,i,iset),iset)
15602          lend=ifrag(2,ipair(2,i,iset),iset)
15603          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15604          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15605 !  Calculating dU/dQ
15606          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15607 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15608 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15609 !         hmnum=(hm2-hm1)/delta
15610 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15611 !     &   qinpair(i,iset))
15612 !         write(iout,*) "harmonicnum pair ", hmnum
15613 ! Calculating dQ/dXi
15614          call qwolynes_prim(kstart,kend,.false.,&
15615           lstart,lend)
15616 !         write(iout,*) "dqwol "
15617 !         do ii=1,nres
15618 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15619 !         enddo
15620 !         write(iout,*) "dxqwol "
15621 !         do ii=1,nres
15622 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15623 !        enddo
15624 ! Calculating numerical gradients
15625 !        call qwol_num(kstart,kend,.false.
15626 !     &  ,lstart,lend)
15627 ! The gradients of Uconst in Cs
15628          do ii=0,nres
15629             do j=1,3
15630                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15631                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15632             enddo
15633          enddo
15634       enddo
15635 !      write(iout,*) "Uconst inside subroutine ", Uconst
15636 ! Transforming the gradients from Cs to dCs for the backbone
15637       do i=0,nres
15638          do j=i+1,nres
15639            do k=1,3
15640              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15641            enddo
15642          enddo
15643       enddo
15644 !  Transforming the gradients from Cs to dCs for the side chains
15645       do i=1,nres
15646          do j=1,3
15647            dudxconst(j,i)=duxconst(j,i)
15648          enddo
15649       enddo
15650 !      write(iout,*) "dU/ddc backbone "
15651 !       do ii=0,nres
15652 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15653 !      enddo
15654 !      write(iout,*) "dU/ddX side chain "
15655 !      do ii=1,nres
15656 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15657 !      enddo
15658 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15659 !      call dEconstrQ_num
15660       return
15661       end subroutine EconstrQ
15662 !-----------------------------------------------------------------------------
15663       subroutine dEconstrQ_num
15664 ! Calculating numerical dUconst/ddc and dUconst/ddx
15665 !      implicit real*8 (a-h,o-z)
15666 !      include 'DIMENSIONS'
15667 !      include 'COMMON.CONTROL'
15668 !      include 'COMMON.VAR'
15669 !      include 'COMMON.MD'
15670       use MD_data
15671 !#ifndef LANG0
15672 !      include 'COMMON.LANGEVIN'
15673 !#else
15674 !      include 'COMMON.LANGEVIN.lang0'
15675 !#endif
15676 !      include 'COMMON.CHAIN'
15677 !      include 'COMMON.DERIV'
15678 !      include 'COMMON.GEO'
15679 !      include 'COMMON.LOCAL'
15680 !      include 'COMMON.INTERACT'
15681 !      include 'COMMON.IOUNITS'
15682 !      include 'COMMON.NAMES'
15683 !      include 'COMMON.TIME1'
15684       real(kind=8) :: uzap1,uzap2
15685       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15686       integer :: kstart,kend,lstart,lend,idummy
15687       real(kind=8) :: delta=1.0d-7
15688 !el local variables
15689       integer :: i,ii,j
15690 !     real(kind=8) ::
15691 !     For the backbone
15692       do i=0,nres-1
15693          do j=1,3
15694             dUcartan(j,i)=0.0d0
15695             cdummy(j,i)=dc(j,i)
15696             dc(j,i)=dc(j,i)+delta
15697             call chainbuild_cart
15698             uzap2=0.0d0
15699             do ii=1,nfrag
15700              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15701                 idummy,idummy)
15702                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15703                 qinfrag(ii,iset))
15704             enddo
15705             do ii=1,npair
15706                kstart=ifrag(1,ipair(1,ii,iset),iset)
15707                kend=ifrag(2,ipair(1,ii,iset),iset)
15708                lstart=ifrag(1,ipair(2,ii,iset),iset)
15709                lend=ifrag(2,ipair(2,ii,iset),iset)
15710                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15711                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15712                  qinpair(ii,iset))
15713             enddo
15714             dc(j,i)=cdummy(j,i)
15715             call chainbuild_cart
15716             uzap1=0.0d0
15717              do ii=1,nfrag
15718              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15719                 idummy,idummy)
15720                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15721                 qinfrag(ii,iset))
15722             enddo
15723             do ii=1,npair
15724                kstart=ifrag(1,ipair(1,ii,iset),iset)
15725                kend=ifrag(2,ipair(1,ii,iset),iset)
15726                lstart=ifrag(1,ipair(2,ii,iset),iset)
15727                lend=ifrag(2,ipair(2,ii,iset),iset)
15728                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15729                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15730                 qinpair(ii,iset))
15731             enddo
15732             ducartan(j,i)=(uzap2-uzap1)/(delta)
15733          enddo
15734       enddo
15735 ! Calculating numerical gradients for dU/ddx
15736       do i=0,nres-1
15737          duxcartan(j,i)=0.0d0
15738          do j=1,3
15739             cdummy(j,i)=dc(j,i+nres)
15740             dc(j,i+nres)=dc(j,i+nres)+delta
15741             call chainbuild_cart
15742             uzap2=0.0d0
15743             do ii=1,nfrag
15744              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15745                 idummy,idummy)
15746                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15747                 qinfrag(ii,iset))
15748             enddo
15749             do ii=1,npair
15750                kstart=ifrag(1,ipair(1,ii,iset),iset)
15751                kend=ifrag(2,ipair(1,ii,iset),iset)
15752                lstart=ifrag(1,ipair(2,ii,iset),iset)
15753                lend=ifrag(2,ipair(2,ii,iset),iset)
15754                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15755                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15756                 qinpair(ii,iset))
15757             enddo
15758             dc(j,i+nres)=cdummy(j,i)
15759             call chainbuild_cart
15760             uzap1=0.0d0
15761              do ii=1,nfrag
15762                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15763                 ifrag(2,ii,iset),.true.,idummy,idummy)
15764                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15765                 qinfrag(ii,iset))
15766             enddo
15767             do ii=1,npair
15768                kstart=ifrag(1,ipair(1,ii,iset),iset)
15769                kend=ifrag(2,ipair(1,ii,iset),iset)
15770                lstart=ifrag(1,ipair(2,ii,iset),iset)
15771                lend=ifrag(2,ipair(2,ii,iset),iset)
15772                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15773                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15774                 qinpair(ii,iset))
15775             enddo
15776             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15777          enddo
15778       enddo
15779       write(iout,*) "Numerical dUconst/ddc backbone "
15780       do ii=0,nres
15781         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15782       enddo
15783 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15784 !      do ii=1,nres
15785 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15786 !      enddo
15787       return
15788       end subroutine dEconstrQ_num
15789 !-----------------------------------------------------------------------------
15790 ! ssMD.F
15791 !-----------------------------------------------------------------------------
15792       subroutine check_energies
15793
15794 !      use random, only: ran_number
15795
15796 !      implicit none
15797 !     Includes
15798 !      include 'DIMENSIONS'
15799 !      include 'COMMON.CHAIN'
15800 !      include 'COMMON.VAR'
15801 !      include 'COMMON.IOUNITS'
15802 !      include 'COMMON.SBRIDGE'
15803 !      include 'COMMON.LOCAL'
15804 !      include 'COMMON.GEO'
15805
15806 !     External functions
15807 !EL      double precision ran_number
15808 !EL      external ran_number
15809
15810 !     Local variables
15811       integer :: i,j,k,l,lmax,p,pmax
15812       real(kind=8) :: rmin,rmax
15813       real(kind=8) :: eij
15814
15815       real(kind=8) :: d
15816       real(kind=8) :: wi,rij,tj,pj
15817 !      return
15818
15819       i=5
15820       j=14
15821
15822       d=dsc(1)
15823       rmin=2.0D0
15824       rmax=12.0D0
15825
15826       lmax=10000
15827       pmax=1
15828
15829       do k=1,3
15830         c(k,i)=0.0D0
15831         c(k,j)=0.0D0
15832         c(k,nres+i)=0.0D0
15833         c(k,nres+j)=0.0D0
15834       enddo
15835
15836       do l=1,lmax
15837
15838 !t        wi=ran_number(0.0D0,pi)
15839 !        wi=ran_number(0.0D0,pi/6.0D0)
15840 !        wi=0.0D0
15841 !t        tj=ran_number(0.0D0,pi)
15842 !t        pj=ran_number(0.0D0,pi)
15843 !        pj=ran_number(0.0D0,pi/6.0D0)
15844 !        pj=0.0D0
15845
15846         do p=1,pmax
15847 !t           rij=ran_number(rmin,rmax)
15848
15849            c(1,j)=d*sin(pj)*cos(tj)
15850            c(2,j)=d*sin(pj)*sin(tj)
15851            c(3,j)=d*cos(pj)
15852
15853            c(3,nres+i)=-rij
15854
15855            c(1,i)=d*sin(wi)
15856            c(3,i)=-rij-d*cos(wi)
15857
15858            do k=1,3
15859               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15860               dc_norm(k,nres+i)=dc(k,nres+i)/d
15861               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15862               dc_norm(k,nres+j)=dc(k,nres+j)/d
15863            enddo
15864
15865            call dyn_ssbond_ene(i,j,eij)
15866         enddo
15867       enddo
15868       call exit(1)
15869       return
15870       end subroutine check_energies
15871 !-----------------------------------------------------------------------------
15872       subroutine dyn_ssbond_ene(resi,resj,eij)
15873 !      implicit none
15874 !      Includes
15875       use calc_data
15876       use comm_sschecks
15877 !      include 'DIMENSIONS'
15878 !      include 'COMMON.SBRIDGE'
15879 !      include 'COMMON.CHAIN'
15880 !      include 'COMMON.DERIV'
15881 !      include 'COMMON.LOCAL'
15882 !      include 'COMMON.INTERACT'
15883 !      include 'COMMON.VAR'
15884 !      include 'COMMON.IOUNITS'
15885 !      include 'COMMON.CALC'
15886 #ifndef CLUST
15887 #ifndef WHAM
15888        use MD_data
15889 !      include 'COMMON.MD'
15890 !      use MD, only: totT,t_bath
15891 #endif
15892 #endif
15893 !     External functions
15894 !EL      double precision h_base
15895 !EL      external h_base
15896
15897 !     Input arguments
15898       integer :: resi,resj
15899
15900 !     Output arguments
15901       real(kind=8) :: eij
15902
15903 !     Local variables
15904       logical :: havebond
15905       integer itypi,itypj
15906       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15907       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15908       real(kind=8),dimension(3) :: dcosom1,dcosom2
15909       real(kind=8) :: ed
15910       real(kind=8) :: pom1,pom2
15911       real(kind=8) :: ljA,ljB,ljXs
15912       real(kind=8),dimension(1:3) :: d_ljB
15913       real(kind=8) :: ssA,ssB,ssC,ssXs
15914       real(kind=8) :: ssxm,ljxm,ssm,ljm
15915       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15916       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15917       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15918 !-------FIRST METHOD
15919       real(kind=8) :: xm
15920       real(kind=8),dimension(1:3) :: d_xm
15921 !-------END FIRST METHOD
15922 !-------SECOND METHOD
15923 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15924 !-------END SECOND METHOD
15925
15926 !-------TESTING CODE
15927 !el      logical :: checkstop,transgrad
15928 !el      common /sschecks/ checkstop,transgrad
15929
15930       integer :: icheck,nicheck,jcheck,njcheck
15931       real(kind=8),dimension(-1:1) :: echeck
15932       real(kind=8) :: deps,ssx0,ljx0
15933 !-------END TESTING CODE
15934
15935       eij=0.0d0
15936       i=resi
15937       j=resj
15938
15939 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15940 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15941
15942       itypi=itype(i)
15943       dxi=dc_norm(1,nres+i)
15944       dyi=dc_norm(2,nres+i)
15945       dzi=dc_norm(3,nres+i)
15946       dsci_inv=vbld_inv(i+nres)
15947
15948       itypj=itype(j)
15949       xj=c(1,nres+j)-c(1,nres+i)
15950       yj=c(2,nres+j)-c(2,nres+i)
15951       zj=c(3,nres+j)-c(3,nres+i)
15952       dxj=dc_norm(1,nres+j)
15953       dyj=dc_norm(2,nres+j)
15954       dzj=dc_norm(3,nres+j)
15955       dscj_inv=vbld_inv(j+nres)
15956
15957       chi1=chi(itypi,itypj)
15958       chi2=chi(itypj,itypi)
15959       chi12=chi1*chi2
15960       chip1=chip(itypi)
15961       chip2=chip(itypj)
15962       chip12=chip1*chip2
15963       alf1=alp(itypi)
15964       alf2=alp(itypj)
15965       alf12=0.5D0*(alf1+alf2)
15966
15967       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15968       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15969 !     The following are set in sc_angular
15970 !      erij(1)=xj*rij
15971 !      erij(2)=yj*rij
15972 !      erij(3)=zj*rij
15973 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15974 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15975 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15976       call sc_angular
15977       rij=1.0D0/rij  ! Reset this so it makes sense
15978
15979       sig0ij=sigma(itypi,itypj)
15980       sig=sig0ij*dsqrt(1.0D0/sigsq)
15981
15982       ljXs=sig-sig0ij
15983       ljA=eps1*eps2rt**2*eps3rt**2
15984       ljB=ljA*bb(itypi,itypj)
15985       ljA=ljA*aa(itypi,itypj)
15986       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15987
15988       ssXs=d0cm
15989       deltat1=1.0d0-om1
15990       deltat2=1.0d0+om2
15991       deltat12=om2-om1+2.0d0
15992       cosphi=om12-om1*om2
15993       ssA=akcm
15994       ssB=akct*deltat12
15995       ssC=ss_depth &
15996            +akth*(deltat1*deltat1+deltat2*deltat2) &
15997            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15998       ssxm=ssXs-0.5D0*ssB/ssA
15999
16000 !-------TESTING CODE
16001 !$$$c     Some extra output
16002 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
16003 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16004 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
16005 !$$$      if (ssx0.gt.0.0d0) then
16006 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
16007 !$$$      else
16008 !$$$        ssx0=ssxm
16009 !$$$      endif
16010 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16011 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
16012 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
16013 !$$$      return
16014 !-------END TESTING CODE
16015
16016 !-------TESTING CODE
16017 !     Stop and plot energy and derivative as a function of distance
16018       if (checkstop) then
16019         ssm=ssC-0.25D0*ssB*ssB/ssA
16020         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16021         if (ssm.lt.ljm .and. &
16022              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
16023           nicheck=1000
16024           njcheck=1
16025           deps=0.5d-7
16026         else
16027           checkstop=.false.
16028         endif
16029       endif
16030       if (.not.checkstop) then
16031         nicheck=0
16032         njcheck=-1
16033       endif
16034
16035       do icheck=0,nicheck
16036       do jcheck=-1,njcheck
16037       if (checkstop) rij=(ssxm-1.0d0)+ &
16038              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
16039 !-------END TESTING CODE
16040
16041       if (rij.gt.ljxm) then
16042         havebond=.false.
16043         ljd=rij-ljXs
16044         fac=(1.0D0/ljd)**expon
16045         e1=fac*fac*aa(itypi,itypj)
16046         e2=fac*bb(itypi,itypj)
16047         eij=eps1*eps2rt*eps3rt*(e1+e2)
16048         eps2der=eij*eps3rt
16049         eps3der=eij*eps2rt
16050         eij=eij*eps2rt*eps3rt
16051
16052         sigder=-sig/sigsq
16053         e1=e1*eps1*eps2rt**2*eps3rt**2
16054         ed=-expon*(e1+eij)/ljd
16055         sigder=ed*sigder
16056         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16057         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16058         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
16059              -2.0D0*alf12*eps3der+sigder*sigsq_om12
16060       else if (rij.lt.ssxm) then
16061         havebond=.true.
16062         ssd=rij-ssXs
16063         eij=ssA*ssd*ssd+ssB*ssd+ssC
16064
16065         ed=2*akcm*ssd+akct*deltat12
16066         pom1=akct*ssd
16067         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
16068         eom1=-2*akth*deltat1-pom1-om2*pom2
16069         eom2= 2*akth*deltat2+pom1-om1*pom2
16070         eom12=pom2
16071       else
16072         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16073
16074         d_ssxm(1)=0.5D0*akct/ssA
16075         d_ssxm(2)=-d_ssxm(1)
16076         d_ssxm(3)=0.0D0
16077
16078         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16079         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16080         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16081         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16082
16083 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16084         xm=0.5d0*(ssxm+ljxm)
16085         do k=1,3
16086           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16087         enddo
16088         if (rij.lt.xm) then
16089           havebond=.true.
16090           ssm=ssC-0.25D0*ssB*ssB/ssA
16091           d_ssm(1)=0.5D0*akct*ssB/ssA
16092           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16093           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16094           d_ssm(3)=omega
16095           f1=(rij-xm)/(ssxm-xm)
16096           f2=(rij-ssxm)/(xm-ssxm)
16097           h1=h_base(f1,hd1)
16098           h2=h_base(f2,hd2)
16099           eij=ssm*h1+Ht*h2
16100           delta_inv=1.0d0/(xm-ssxm)
16101           deltasq_inv=delta_inv*delta_inv
16102           fac=ssm*hd1-Ht*hd2
16103           fac1=deltasq_inv*fac*(xm-rij)
16104           fac2=deltasq_inv*fac*(rij-ssxm)
16105           ed=delta_inv*(Ht*hd2-ssm*hd1)
16106           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16107           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16108           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16109         else
16110           havebond=.false.
16111           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16112           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16113           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16114           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16115                alf12/eps3rt)
16116           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16117           f1=(rij-ljxm)/(xm-ljxm)
16118           f2=(rij-xm)/(ljxm-xm)
16119           h1=h_base(f1,hd1)
16120           h2=h_base(f2,hd2)
16121           eij=Ht*h1+ljm*h2
16122           delta_inv=1.0d0/(ljxm-xm)
16123           deltasq_inv=delta_inv*delta_inv
16124           fac=Ht*hd1-ljm*hd2
16125           fac1=deltasq_inv*fac*(ljxm-rij)
16126           fac2=deltasq_inv*fac*(rij-xm)
16127           ed=delta_inv*(ljm*hd2-Ht*hd1)
16128           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16129           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16130           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16131         endif
16132 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16133
16134 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16135 !$$$        ssd=rij-ssXs
16136 !$$$        ljd=rij-ljXs
16137 !$$$        fac1=rij-ljxm
16138 !$$$        fac2=rij-ssxm
16139 !$$$
16140 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16141 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16142 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16143 !$$$
16144 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16145 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16146 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16147 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16148 !$$$        d_ssm(3)=omega
16149 !$$$
16150 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16151 !$$$        do k=1,3
16152 !$$$          d_ljm(k)=ljm*d_ljB(k)
16153 !$$$        enddo
16154 !$$$        ljm=ljm*ljB
16155 !$$$
16156 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16157 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16158 !$$$        d_ss(2)=akct*ssd
16159 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16160 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16161 !$$$        d_ss(3)=omega
16162 !$$$
16163 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16164 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16165 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16166 !$$$        do k=1,3
16167 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16168 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16169 !$$$        enddo
16170 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16171 !$$$
16172 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16173 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16174 !$$$        h1=h_base(f1,hd1)
16175 !$$$        h2=h_base(f2,hd2)
16176 !$$$        eij=ss*h1+ljf*h2
16177 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16178 !$$$        deltasq_inv=delta_inv*delta_inv
16179 !$$$        fac=ljf*hd2-ss*hd1
16180 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16181 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16182 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16183 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16184 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16185 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16186 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16187 !$$$
16188 !$$$        havebond=.false.
16189 !$$$        if (ed.gt.0.0d0) havebond=.true.
16190 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16191
16192       endif
16193
16194       if (havebond) then
16195 !#ifndef CLUST
16196 !#ifndef WHAM
16197 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16198 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16199 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16200 !        endif
16201 !#endif
16202 !#endif
16203         dyn_ssbond_ij(i,j)=eij
16204       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16205         dyn_ssbond_ij(i,j)=1.0d300
16206 !#ifndef CLUST
16207 !#ifndef WHAM
16208 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16209 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16210 !#endif
16211 !#endif
16212       endif
16213
16214 !-------TESTING CODE
16215 !el      if (checkstop) then
16216         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16217              "CHECKSTOP",rij,eij,ed
16218         echeck(jcheck)=eij
16219 !el      endif
16220       enddo
16221       if (checkstop) then
16222         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16223       endif
16224       enddo
16225       if (checkstop) then
16226         transgrad=.true.
16227         checkstop=.false.
16228       endif
16229 !-------END TESTING CODE
16230
16231       do k=1,3
16232         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16233         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16234       enddo
16235       do k=1,3
16236         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16237       enddo
16238       do k=1,3
16239         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16240              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16241              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16242         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16243              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16244              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16245       enddo
16246 !grad      do k=i,j-1
16247 !grad        do l=1,3
16248 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16249 !grad        enddo
16250 !grad      enddo
16251
16252       do l=1,3
16253         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16254         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16255       enddo
16256
16257       return
16258       end subroutine dyn_ssbond_ene
16259 !-----------------------------------------------------------------------------
16260       real(kind=8) function h_base(x,deriv)
16261 !     A smooth function going 0->1 in range [0,1]
16262 !     It should NOT be called outside range [0,1], it will not work there.
16263       implicit none
16264
16265 !     Input arguments
16266       real(kind=8) :: x
16267
16268 !     Output arguments
16269       real(kind=8) :: deriv
16270
16271 !     Local variables
16272       real(kind=8) :: xsq
16273
16274
16275 !     Two parabolas put together.  First derivative zero at extrema
16276 !$$$      if (x.lt.0.5D0) then
16277 !$$$        h_base=2.0D0*x*x
16278 !$$$        deriv=4.0D0*x
16279 !$$$      else
16280 !$$$        deriv=1.0D0-x
16281 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16282 !$$$        deriv=4.0D0*deriv
16283 !$$$      endif
16284
16285 !     Third degree polynomial.  First derivative zero at extrema
16286       h_base=x*x*(3.0d0-2.0d0*x)
16287       deriv=6.0d0*x*(1.0d0-x)
16288
16289 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16290 !$$$      xsq=x*x
16291 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16292 !$$$      deriv=x-1.0d0
16293 !$$$      deriv=deriv*deriv
16294 !$$$      deriv=30.0d0*xsq*deriv
16295
16296       return
16297       end function h_base
16298 !-----------------------------------------------------------------------------
16299       subroutine dyn_set_nss
16300 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16301 !      implicit none
16302       use MD_data, only: totT,t_bath
16303 !     Includes
16304 !      include 'DIMENSIONS'
16305 #ifdef MPI
16306       include "mpif.h"
16307 #endif
16308 !      include 'COMMON.SBRIDGE'
16309 !      include 'COMMON.CHAIN'
16310 !      include 'COMMON.IOUNITS'
16311 !      include 'COMMON.SETUP'
16312 !      include 'COMMON.MD'
16313 !     Local variables
16314       real(kind=8) :: emin
16315       integer :: i,j,imin,ierr
16316       integer :: diff,allnss,newnss
16317       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16318                 newihpb,newjhpb
16319       logical :: found
16320       integer,dimension(0:nfgtasks) :: i_newnss
16321       integer,dimension(0:nfgtasks) :: displ
16322       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16323       integer :: g_newnss
16324
16325       allnss=0
16326       do i=1,nres-1
16327         do j=i+1,nres
16328           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16329             allnss=allnss+1
16330             allflag(allnss)=0
16331             allihpb(allnss)=i
16332             alljhpb(allnss)=j
16333           endif
16334         enddo
16335       enddo
16336
16337 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16338
16339  1    emin=1.0d300
16340       do i=1,allnss
16341         if (allflag(i).eq.0 .and. &
16342              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16343           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16344           imin=i
16345         endif
16346       enddo
16347       if (emin.lt.1.0d300) then
16348         allflag(imin)=1
16349         do i=1,allnss
16350           if (allflag(i).eq.0 .and. &
16351                (allihpb(i).eq.allihpb(imin) .or. &
16352                alljhpb(i).eq.allihpb(imin) .or. &
16353                allihpb(i).eq.alljhpb(imin) .or. &
16354                alljhpb(i).eq.alljhpb(imin))) then
16355             allflag(i)=-1
16356           endif
16357         enddo
16358         goto 1
16359       endif
16360
16361 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16362
16363       newnss=0
16364       do i=1,allnss
16365         if (allflag(i).eq.1) then
16366           newnss=newnss+1
16367           newihpb(newnss)=allihpb(i)
16368           newjhpb(newnss)=alljhpb(i)
16369         endif
16370       enddo
16371
16372 #ifdef MPI
16373       if (nfgtasks.gt.1)then
16374
16375         call MPI_Reduce(newnss,g_newnss,1,&
16376           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16377         call MPI_Gather(newnss,1,MPI_INTEGER,&
16378                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16379         displ(0)=0
16380         do i=1,nfgtasks-1,1
16381           displ(i)=i_newnss(i-1)+displ(i-1)
16382         enddo
16383         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16384                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16385                          king,FG_COMM,IERR)
16386         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16387                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16388                          king,FG_COMM,IERR)
16389         if(fg_rank.eq.0) then
16390 !         print *,'g_newnss',g_newnss
16391 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16392 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16393          newnss=g_newnss
16394          do i=1,newnss
16395           newihpb(i)=g_newihpb(i)
16396           newjhpb(i)=g_newjhpb(i)
16397          enddo
16398         endif
16399       endif
16400 #endif
16401
16402       diff=newnss-nss
16403
16404 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16405
16406       do i=1,nss
16407         found=.false.
16408         do j=1,newnss
16409           if (idssb(i).eq.newihpb(j) .and. &
16410                jdssb(i).eq.newjhpb(j)) found=.true.
16411         enddo
16412 #ifndef CLUST
16413 #ifndef WHAM
16414         if (.not.found.and.fg_rank.eq.0) &
16415             write(iout,'(a15,f12.2,f8.1,2i5)') &
16416              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16417 #endif
16418 #endif
16419       enddo
16420
16421       do i=1,newnss
16422         found=.false.
16423         do j=1,nss
16424           if (newihpb(i).eq.idssb(j) .and. &
16425                newjhpb(i).eq.jdssb(j)) found=.true.
16426         enddo
16427 #ifndef CLUST
16428 #ifndef WHAM
16429         if (.not.found.and.fg_rank.eq.0) &
16430             write(iout,'(a15,f12.2,f8.1,2i5)') &
16431              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16432 #endif
16433 #endif
16434       enddo
16435
16436       nss=newnss
16437       do i=1,nss
16438         idssb(i)=newihpb(i)
16439         jdssb(i)=newjhpb(i)
16440       enddo
16441
16442       return
16443       end subroutine dyn_set_nss
16444 !-----------------------------------------------------------------------------
16445 #ifdef WHAM
16446       subroutine read_ssHist
16447 !      implicit none
16448 !      Includes
16449 !      include 'DIMENSIONS'
16450 !      include "DIMENSIONS.FREE"
16451 !      include 'COMMON.FREE'
16452 !     Local variables
16453       integer :: i,j
16454       character(len=80) :: controlcard
16455
16456       do i=1,dyn_nssHist
16457         call card_concat(controlcard,.true.)
16458         read(controlcard,*) &
16459              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16460       enddo
16461
16462       return
16463       end subroutine read_ssHist
16464 #endif
16465 !-----------------------------------------------------------------------------
16466       integer function indmat(i,j)
16467 !el
16468 ! get the position of the jth ijth fragment of the chain coordinate system
16469 ! in the fromto array.
16470         integer :: i,j
16471
16472         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16473       return
16474       end function indmat
16475 !-----------------------------------------------------------------------------
16476       real(kind=8) function sigm(x)
16477 !el
16478        real(kind=8) :: x
16479         sigm=0.25d0*x
16480       return
16481       end function sigm
16482 !-----------------------------------------------------------------------------
16483 !-----------------------------------------------------------------------------
16484       subroutine alloc_ener_arrays
16485 !EL Allocation of arrays used by module energy
16486       use MD_data, only: mset
16487 !el local variables
16488       integer :: i,j
16489
16490       if(nres.lt.100) then
16491         maxconts=nres
16492       elseif(nres.lt.200) then
16493         maxconts=0.8*nres       ! Max. number of contacts per residue
16494       else
16495         maxconts=0.6*nres ! (maxconts=maxres/4)
16496       endif
16497       maxcont=12*nres   ! Max. number of SC contacts
16498       maxvar=6*nres     ! Max. number of variables
16499 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16500       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16501 !----------------------
16502 ! arrays in subroutine init_int_table
16503 !el#ifdef MPI
16504 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16505 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16506 !el#endif
16507       allocate(nint_gr(nres))
16508       allocate(nscp_gr(nres))
16509       allocate(ielstart(nres))
16510       allocate(ielend(nres))
16511 !(maxres)
16512       allocate(istart(nres,maxint_gr))
16513       allocate(iend(nres,maxint_gr))
16514 !(maxres,maxint_gr)
16515       allocate(iscpstart(nres,maxint_gr))
16516       allocate(iscpend(nres,maxint_gr))
16517 !(maxres,maxint_gr)
16518       allocate(ielstart_vdw(nres))
16519       allocate(ielend_vdw(nres))
16520 !(maxres)
16521
16522       allocate(lentyp(0:nfgtasks-1))
16523 !(0:maxprocs-1)
16524 !----------------------
16525 ! commom.contacts
16526 !      common /contacts/
16527       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16528       allocate(icont(2,maxcont))
16529 !(2,maxcont)
16530 !      common /contacts1/
16531       allocate(num_cont(0:nres+4))
16532 !(maxres)
16533       allocate(jcont(maxconts,nres))
16534 !(maxconts,maxres)
16535       allocate(facont(maxconts,nres))
16536 !(maxconts,maxres)
16537       allocate(gacont(3,maxconts,nres))
16538 !(3,maxconts,maxres)
16539 !      common /contacts_hb/
16540       allocate(gacontp_hb1(3,maxconts,nres))
16541       allocate(gacontp_hb2(3,maxconts,nres))
16542       allocate(gacontp_hb3(3,maxconts,nres))
16543       allocate(gacontm_hb1(3,maxconts,nres))
16544       allocate(gacontm_hb2(3,maxconts,nres))
16545       allocate(gacontm_hb3(3,maxconts,nres))
16546       allocate(gacont_hbr(3,maxconts,nres))
16547       allocate(grij_hb_cont(3,maxconts,nres))
16548 !(3,maxconts,maxres)
16549       allocate(facont_hb(maxconts,nres))
16550       allocate(ees0p(maxconts,nres))
16551       allocate(ees0m(maxconts,nres))
16552       allocate(d_cont(maxconts,nres))
16553 !(maxconts,maxres)
16554       allocate(num_cont_hb(nres))
16555 !(maxres)
16556       allocate(jcont_hb(maxconts,nres))
16557 !(maxconts,maxres)
16558 !      common /rotat/
16559       allocate(Ug(2,2,nres))
16560       allocate(Ugder(2,2,nres))
16561       allocate(Ug2(2,2,nres))
16562       allocate(Ug2der(2,2,nres))
16563 !(2,2,maxres)
16564       allocate(obrot(2,nres))
16565       allocate(obrot2(2,nres))
16566       allocate(obrot_der(2,nres))
16567       allocate(obrot2_der(2,nres))
16568 !(2,maxres)
16569 !      common /precomp1/
16570       allocate(mu(2,nres))
16571       allocate(muder(2,nres))
16572       allocate(Ub2(2,nres))
16573       Ub2(1,:)=0.0d0
16574       Ub2(2,:)=0.0d0
16575       allocate(Ub2der(2,nres))
16576       allocate(Ctobr(2,nres))
16577       allocate(Ctobrder(2,nres))
16578       allocate(Dtobr2(2,nres))
16579       allocate(Dtobr2der(2,nres))
16580 !(2,maxres)
16581       allocate(EUg(2,2,nres))
16582       allocate(EUgder(2,2,nres))
16583       allocate(CUg(2,2,nres))
16584       allocate(CUgder(2,2,nres))
16585       allocate(DUg(2,2,nres))
16586       allocate(Dugder(2,2,nres))
16587       allocate(DtUg2(2,2,nres))
16588       allocate(DtUg2der(2,2,nres))
16589 !(2,2,maxres)
16590 !      common /precomp2/
16591       allocate(Ug2Db1t(2,nres))
16592       allocate(Ug2Db1tder(2,nres))
16593       allocate(CUgb2(2,nres))
16594       allocate(CUgb2der(2,nres))
16595 !(2,maxres)
16596       allocate(EUgC(2,2,nres))
16597       allocate(EUgCder(2,2,nres))
16598       allocate(EUgD(2,2,nres))
16599       allocate(EUgDder(2,2,nres))
16600       allocate(DtUg2EUg(2,2,nres))
16601       allocate(Ug2DtEUg(2,2,nres))
16602 !(2,2,maxres)
16603       allocate(Ug2DtEUgder(2,2,2,nres))
16604       allocate(DtUg2EUgder(2,2,2,nres))
16605 !(2,2,2,maxres)
16606 !      common /rotat_old/
16607       allocate(costab(nres))
16608       allocate(sintab(nres))
16609       allocate(costab2(nres))
16610       allocate(sintab2(nres))
16611 !(maxres)
16612 !      common /dipmat/
16613       allocate(a_chuj(2,2,maxconts,nres))
16614 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16615       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16616 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16617 !      common /contdistrib/
16618       allocate(ncont_sent(nres))
16619       allocate(ncont_recv(nres))
16620
16621       allocate(iat_sent(nres))
16622 !(maxres)
16623       allocate(iint_sent(4,nres,nres))
16624       allocate(iint_sent_local(4,nres,nres))
16625 !(4,maxres,maxres)
16626       allocate(iturn3_sent(4,0:nres+4))
16627       allocate(iturn4_sent(4,0:nres+4))
16628       allocate(iturn3_sent_local(4,nres))
16629       allocate(iturn4_sent_local(4,nres))
16630 !(4,maxres)
16631       allocate(itask_cont_from(0:nfgtasks-1))
16632       allocate(itask_cont_to(0:nfgtasks-1))
16633 !(0:max_fg_procs-1)
16634
16635
16636
16637 !----------------------
16638 ! commom.deriv;
16639 !      common /derivat/
16640       allocate(dcdv(6,maxdim))
16641       allocate(dxdv(6,maxdim))
16642 !(6,maxdim)
16643       allocate(dxds(6,nres))
16644 !(6,maxres)
16645       allocate(gradx(3,nres,0:2))
16646       allocate(gradc(3,nres,0:2))
16647 !(3,maxres,2)
16648       allocate(gvdwx(3,nres))
16649       allocate(gvdwc(3,nres))
16650       allocate(gelc(3,nres))
16651       allocate(gelc_long(3,nres))
16652       allocate(gvdwpp(3,nres))
16653       allocate(gvdwc_scpp(3,nres))
16654       allocate(gradx_scp(3,nres))
16655       allocate(gvdwc_scp(3,nres))
16656       allocate(ghpbx(3,nres))
16657       allocate(ghpbc(3,nres))
16658       allocate(gradcorr(3,nres))
16659       allocate(gradcorr_long(3,nres))
16660       allocate(gradcorr5_long(3,nres))
16661       allocate(gradcorr6_long(3,nres))
16662       allocate(gcorr6_turn_long(3,nres))
16663       allocate(gradxorr(3,nres))
16664       allocate(gradcorr5(3,nres))
16665       allocate(gradcorr6(3,nres))
16666 !(3,maxres)
16667       allocate(gloc(0:maxvar,0:2))
16668       allocate(gloc_x(0:maxvar,2))
16669 !(maxvar,2)
16670       allocate(gel_loc(3,nres))
16671       allocate(gel_loc_long(3,nres))
16672       allocate(gcorr3_turn(3,nres))
16673       allocate(gcorr4_turn(3,nres))
16674       allocate(gcorr6_turn(3,nres))
16675       allocate(gradb(3,nres))
16676       allocate(gradbx(3,nres))
16677 !(3,maxres)
16678       allocate(gel_loc_loc(maxvar))
16679       allocate(gel_loc_turn3(maxvar))
16680       allocate(gel_loc_turn4(maxvar))
16681       allocate(gel_loc_turn6(maxvar))
16682       allocate(gcorr_loc(maxvar))
16683       allocate(g_corr5_loc(maxvar))
16684       allocate(g_corr6_loc(maxvar))
16685 !(maxvar)
16686       allocate(gsccorc(3,nres))
16687       allocate(gsccorx(3,nres))
16688 !(3,maxres)
16689       allocate(gsccor_loc(nres))
16690 !(maxres)
16691       allocate(dtheta(3,2,nres))
16692 !(3,2,maxres)
16693       allocate(gscloc(3,nres))
16694       allocate(gsclocx(3,nres))
16695 !(3,maxres)
16696       allocate(dphi(3,3,nres))
16697       allocate(dalpha(3,3,nres))
16698       allocate(domega(3,3,nres))
16699 !(3,3,maxres)
16700 !      common /deriv_scloc/
16701       allocate(dXX_C1tab(3,nres))
16702       allocate(dYY_C1tab(3,nres))
16703       allocate(dZZ_C1tab(3,nres))
16704       allocate(dXX_Ctab(3,nres))
16705       allocate(dYY_Ctab(3,nres))
16706       allocate(dZZ_Ctab(3,nres))
16707       allocate(dXX_XYZtab(3,nres))
16708       allocate(dYY_XYZtab(3,nres))
16709       allocate(dZZ_XYZtab(3,nres))
16710 !(3,maxres)
16711 !      common /mpgrad/
16712       allocate(jgrad_start(nres))
16713       allocate(jgrad_end(nres))
16714 !(maxres)
16715 !----------------------
16716
16717 !      common /indices/
16718       allocate(ibond_displ(0:nfgtasks-1))
16719       allocate(ibond_count(0:nfgtasks-1))
16720       allocate(ithet_displ(0:nfgtasks-1))
16721       allocate(ithet_count(0:nfgtasks-1))
16722       allocate(iphi_displ(0:nfgtasks-1))
16723       allocate(iphi_count(0:nfgtasks-1))
16724       allocate(iphi1_displ(0:nfgtasks-1))
16725       allocate(iphi1_count(0:nfgtasks-1))
16726       allocate(ivec_displ(0:nfgtasks-1))
16727       allocate(ivec_count(0:nfgtasks-1))
16728       allocate(iset_displ(0:nfgtasks-1))
16729       allocate(iset_count(0:nfgtasks-1))
16730       allocate(iint_count(0:nfgtasks-1))
16731       allocate(iint_displ(0:nfgtasks-1))
16732 !(0:max_fg_procs-1)
16733 !----------------------
16734 ! common.MD
16735 !      common /mdgrad/
16736       allocate(gcart(3,0:nres))
16737       allocate(gxcart(3,0:nres))
16738 !(3,0:MAXRES)
16739       allocate(gradcag(3,nres))
16740       allocate(gradxag(3,nres))
16741 !(3,MAXRES)
16742 !      common /back_constr/
16743 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16744       allocate(dutheta(nres))
16745       allocate(dugamma(nres))
16746 !(maxres)
16747       allocate(duscdiff(3,nres))
16748       allocate(duscdiffx(3,nres))
16749 !(3,maxres)
16750 !el i io:read_fragments
16751 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16752 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16753 !      common /qmeas/
16754 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16755 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16756       allocate(mset(0:nprocs))  !(maxprocs/20)
16757       mset(:)=0
16758 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16759 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16760       allocate(dUdconst(3,0:nres))
16761       allocate(dUdxconst(3,0:nres))
16762       allocate(dqwol(3,0:nres))
16763       allocate(dxqwol(3,0:nres))
16764 !(3,0:MAXRES)
16765 !----------------------
16766 ! common.sbridge
16767 !      common /sbridge/ in io_common: read_bridge
16768 !el    allocate((:),allocatable :: iss  !(maxss)
16769 !      common /links/  in io_common: read_bridge
16770 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16771 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16772 !      common /dyn_ssbond/
16773 ! and side-chain vectors in theta or phi.
16774       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16775 !(maxres,maxres)
16776 !      do i=1,nres
16777 !        do j=i+1,nres
16778       dyn_ssbond_ij(:,:)=1.0d300
16779 !        enddo
16780 !      enddo
16781
16782       if (nss.gt.0) then
16783         allocate(idssb(nss),jdssb(nss))
16784 !(maxdim)
16785       endif
16786       allocate(dyn_ss_mask(nres))
16787 !(maxres)
16788       dyn_ss_mask(:)=.false.
16789 !----------------------
16790 ! common.sccor
16791 ! Parameters of the SCCOR term
16792 !      common/sccor/
16793 !el in io_conf: parmread
16794 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16795 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16796 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16797 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16798 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16799 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16800 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16801 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16802 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16803 !----------------
16804       allocate(gloc_sc(3,0:2*nres,0:10))
16805 !(3,0:maxres2,10)maxres2=2*maxres
16806       allocate(dcostau(3,3,3,2*nres))
16807       allocate(dsintau(3,3,3,2*nres))
16808       allocate(dtauangle(3,3,3,2*nres))
16809       allocate(dcosomicron(3,3,3,2*nres))
16810       allocate(domicron(3,3,3,2*nres))
16811 !(3,3,3,maxres2)maxres2=2*maxres
16812 !----------------------
16813 ! common.var
16814 !      common /restr/
16815       allocate(varall(maxvar))
16816 !(maxvar)(maxvar=6*maxres)
16817       allocate(mask_theta(nres))
16818       allocate(mask_phi(nres))
16819       allocate(mask_side(nres))
16820 !(maxres)
16821 !----------------------
16822 ! common.vectors
16823 !      common /vectors/
16824       allocate(uy(3,nres))
16825       allocate(uz(3,nres))
16826 !(3,maxres)
16827       allocate(uygrad(3,3,2,nres))
16828       allocate(uzgrad(3,3,2,nres))
16829 !(3,3,2,maxres)
16830
16831       return
16832       end subroutine alloc_ener_arrays
16833 !-----------------------------------------------------------------------------
16834 !-----------------------------------------------------------------------------
16835       end module energy