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+sss_ele_grad*rmij*eesij*xj
2952           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
2953           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
2954
2955 !          do k=1,3
2956 !            ghalf=0.5D0*ggg(k)
2957 !            gelc(k,i)=gelc(k,i)+ghalf
2958 !            gelc(k,j)=gelc(k,j)+ghalf
2959 !          enddo
2960 ! 9/28/08 AL Gradient compotents will be summed only at the end
2961           do k=1,3
2962             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2963             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2964           enddo
2965 !
2966 ! Loop over residues i+1 thru j-1.
2967 !
2968 !grad          do k=i+1,j-1
2969 !grad            do l=1,3
2970 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2971 !grad            enddo
2972 !grad          enddo
2973           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj
2974           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj
2975           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj
2976 !          do k=1,3
2977 !            ghalf=0.5D0*ggg(k)
2978 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2979 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2980 !          enddo
2981 ! 9/28/08 AL Gradient compotents will be summed only at the end
2982           do k=1,3
2983             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2984             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2985           enddo
2986 !
2987 ! Loop over residues i+1 thru j-1.
2988 !
2989 !grad          do k=i+1,j-1
2990 !grad            do l=1,3
2991 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2992 !grad            enddo
2993 !grad          enddo
2994 #else
2995           facvdw=(ev1+evdwij)*sss_ele_cut
2996           facel=(el1+eesij)*sss_ele_cut
2997           fac1=fac
2998           fac=-3*rrmij*(facvdw+facvdw+facel)
2999           erij(1)=xj*rmij
3000           erij(2)=yj*rmij
3001           erij(3)=zj*rmij
3002 !
3003 ! Radial derivatives. First process both termini of the fragment (i,j)
3004 !
3005           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3006           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3007           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3008 !          do k=1,3
3009 !            ghalf=0.5D0*ggg(k)
3010 !            gelc(k,i)=gelc(k,i)+ghalf
3011 !            gelc(k,j)=gelc(k,j)+ghalf
3012 !          enddo
3013 ! 9/28/08 AL Gradient compotents will be summed only at the end
3014           do k=1,3
3015             gelc_long(k,j)=gelc(k,j)+ggg(k)
3016             gelc_long(k,i)=gelc(k,i)-ggg(k)
3017           enddo
3018 !
3019 ! Loop over residues i+1 thru j-1.
3020 !
3021 !grad          do k=i+1,j-1
3022 !grad            do l=1,3
3023 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3024 !grad            enddo
3025 !grad          enddo
3026 ! 9/28/08 AL Gradient compotents will be summed only at the end
3027           ggg(1)=facvdw*xj
3028           ggg(2)=facvdw*yj
3029           ggg(3)=facvdw*zj
3030           do k=1,3
3031             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3032             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3033           enddo
3034 #endif
3035 !
3036 ! Angular part
3037 !
3038           ecosa=2.0D0*fac3*fac1+fac4
3039           fac4=-3.0D0*fac4
3040           fac3=-6.0D0*fac3
3041           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3042           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3043           do k=1,3
3044             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3045             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3046           enddo
3047 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3048 !d   &          (dcosg(k),k=1,3)
3049           do k=1,3
3050             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut
3051           enddo
3052 !          do k=1,3
3053 !            ghalf=0.5D0*ggg(k)
3054 !            gelc(k,i)=gelc(k,i)+ghalf
3055 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3056 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3057 !            gelc(k,j)=gelc(k,j)+ghalf
3058 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3059 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3060 !          enddo
3061 !grad          do k=i+1,j-1
3062 !grad            do l=1,3
3063 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3064 !grad            enddo
3065 !grad          enddo
3066           do k=1,3
3067             gelc(k,i)=gelc(k,i) &
3068                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3069                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3070                      *sss_ele_cut
3071             gelc(k,j)=gelc(k,j) &
3072                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3073                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3074                      *sss_ele_cut
3075             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3077           enddo
3078
3079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3080               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3081               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3082 !
3083 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3084 !   energy of a peptide unit is assumed in the form of a second-order
3085 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3086 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3087 !   are computed for EVERY pair of non-contiguous peptide groups.
3088 !
3089           if (j.lt.nres-1) then
3090             j1=j+1
3091             j2=j-1
3092           else
3093             j1=j-1
3094             j2=j-2
3095           endif
3096           kkk=0
3097           do k=1,2
3098             do l=1,2
3099               kkk=kkk+1
3100               muij(kkk)=mu(k,i)*mu(l,j)
3101             enddo
3102           enddo
3103 !d         write (iout,*) 'EELEC: i',i,' j',j
3104 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3105 !d          write(iout,*) 'muij',muij
3106           ury=scalar(uy(1,i),erij)
3107           urz=scalar(uz(1,i),erij)
3108           vry=scalar(uy(1,j),erij)
3109           vrz=scalar(uz(1,j),erij)
3110           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3111           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3112           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3113           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3114           fac=dsqrt(-ael6i)*r3ij
3115           a22=a22*fac
3116           a23=a23*fac
3117           a32=a32*fac
3118           a33=a33*fac
3119 !d          write (iout,'(4i5,4f10.5)')
3120 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3121 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3122 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3123 !d     &      uy(:,j),uz(:,j)
3124 !d          write (iout,'(4f10.5)')
3125 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3126 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3127 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3128 !d           write (iout,'(9f10.5/)')
3129 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3130 ! Derivatives of the elements of A in virtual-bond vectors
3131           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3132           do k=1,3
3133             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3134             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3135             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3136             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3137             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3138             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3139             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3140             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3141             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3142             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3143             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3144             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3145           enddo
3146 ! Compute radial contributions to the gradient
3147           facr=-3.0d0*rrmij
3148           a22der=a22*facr
3149           a23der=a23*facr
3150           a32der=a32*facr
3151           a33der=a33*facr
3152           agg(1,1)=a22der*xj
3153           agg(2,1)=a22der*yj
3154           agg(3,1)=a22der*zj
3155           agg(1,2)=a23der*xj
3156           agg(2,2)=a23der*yj
3157           agg(3,2)=a23der*zj
3158           agg(1,3)=a32der*xj
3159           agg(2,3)=a32der*yj
3160           agg(3,3)=a32der*zj
3161           agg(1,4)=a33der*xj
3162           agg(2,4)=a33der*yj
3163           agg(3,4)=a33der*zj
3164 ! Add the contributions coming from er
3165           fac3=-3.0d0*fac
3166           do k=1,3
3167             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3168             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3169             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3170             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3171           enddo
3172           do k=1,3
3173 ! Derivatives in DC(i)
3174 !grad            ghalf1=0.5d0*agg(k,1)
3175 !grad            ghalf2=0.5d0*agg(k,2)
3176 !grad            ghalf3=0.5d0*agg(k,3)
3177 !grad            ghalf4=0.5d0*agg(k,4)
3178             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3179             -3.0d0*uryg(k,2)*vry)!+ghalf1
3180             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3181             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3182             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3183             -3.0d0*urzg(k,2)*vry)!+ghalf3
3184             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3185             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3186 ! Derivatives in DC(i+1)
3187             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3188             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3189             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3190             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3191             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3192             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3193             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3194             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3195 ! Derivatives in DC(j)
3196             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3197             -3.0d0*vryg(k,2)*ury)!+ghalf1
3198             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3199             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3200             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3201             -3.0d0*vryg(k,2)*urz)!+ghalf3
3202             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3203             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3204 ! Derivatives in DC(j+1) or DC(nres-1)
3205             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3206             -3.0d0*vryg(k,3)*ury)
3207             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3208             -3.0d0*vrzg(k,3)*ury)
3209             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3210             -3.0d0*vryg(k,3)*urz)
3211             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3212             -3.0d0*vrzg(k,3)*urz)
3213 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3214 !grad              do l=1,4
3215 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3216 !grad              enddo
3217 !grad            endif
3218           enddo
3219           acipa(1,1)=a22
3220           acipa(1,2)=a23
3221           acipa(2,1)=a32
3222           acipa(2,2)=a33
3223           a22=-a22
3224           a23=-a23
3225           do l=1,2
3226             do k=1,3
3227               agg(k,l)=-agg(k,l)
3228               aggi(k,l)=-aggi(k,l)
3229               aggi1(k,l)=-aggi1(k,l)
3230               aggj(k,l)=-aggj(k,l)
3231               aggj1(k,l)=-aggj1(k,l)
3232             enddo
3233           enddo
3234           if (j.lt.nres-1) then
3235             a22=-a22
3236             a32=-a32
3237             do l=1,3,2
3238               do k=1,3
3239                 agg(k,l)=-agg(k,l)
3240                 aggi(k,l)=-aggi(k,l)
3241                 aggi1(k,l)=-aggi1(k,l)
3242                 aggj(k,l)=-aggj(k,l)
3243                 aggj1(k,l)=-aggj1(k,l)
3244               enddo
3245             enddo
3246           else
3247             a22=-a22
3248             a23=-a23
3249             a32=-a32
3250             a33=-a33
3251             do l=1,4
3252               do k=1,3
3253                 agg(k,l)=-agg(k,l)
3254                 aggi(k,l)=-aggi(k,l)
3255                 aggi1(k,l)=-aggi1(k,l)
3256                 aggj(k,l)=-aggj(k,l)
3257                 aggj1(k,l)=-aggj1(k,l)
3258               enddo
3259             enddo
3260           endif
3261           ENDIF ! WCORR
3262           IF (wel_loc.gt.0.0d0) THEN
3263 ! Contribution to the local-electrostatic energy coming from the i-j pair
3264           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3265            +a33*muij(4)
3266 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3267
3268           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3269                   'eelloc',i,j,eel_loc_ij
3270 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3271 !          if (energy_dec) write (iout,*) "muij",muij
3272 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3273
3274           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3275 ! Partial derivatives in virtual-bond dihedral angles gamma
3276           if (i.gt.1) &
3277           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3278                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3279                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3280                  *sss_ele_cut
3281           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3282                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3283                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3284                  *sss_ele_cut
3285 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3286 !          do l=1,3
3287             ggg(1)=(agg(1,1)*muij(1)+ &
3288                 agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3289             *sss_ele_cut+eel_loc_ij*sss_ele_grad*rmij*xj
3290             ggg(2)=(agg(2,1)*muij(1)+ &
3291                 agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3292             *sss_ele_cut+eel_loc_ij*sss_ele_grad*rmij*yj
3293             ggg(3)=(agg(3,1)*muij(1)+ &
3294                 agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3295             *sss_ele_cut+eel_loc_ij*sss_ele_grad*rmij*zj
3296
3297            do l=1,3
3298             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3299             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3300 !grad            ghalf=0.5d0*ggg(l)
3301 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3302 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3303           enddo
3304 !grad          do k=i+1,j2
3305 !grad            do l=1,3
3306 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3307 !grad            enddo
3308 !grad          enddo
3309 ! Remaining derivatives of eello
3310           do l=1,3
3311             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3312                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3313             *sss_ele_cut
3314             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3315                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
3316             *sss_ele_cut
3317             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3318                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3319             *sss_ele_cut
3320             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3321                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
3322             *sss_ele_cut
3323           enddo
3324           ENDIF
3325 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3326 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3327           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3328              .and. num_conti.le.maxconts) then
3329 !            write (iout,*) i,j," entered corr"
3330 !
3331 ! Calculate the contact function. The ith column of the array JCONT will
3332 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3333 ! greater than I). The arrays FACONT and GACONT will contain the values of
3334 ! the contact function and its derivative.
3335 !           r0ij=1.02D0*rpp(iteli,itelj)
3336 !           r0ij=1.11D0*rpp(iteli,itelj)
3337             r0ij=2.20D0*rpp(iteli,itelj)
3338 !           r0ij=1.55D0*rpp(iteli,itelj)
3339             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3340 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3341             if (fcont.gt.0.0D0) then
3342               num_conti=num_conti+1
3343               if (num_conti.gt.maxconts) then
3344 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3345 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3346                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3347                                ' will skip next contacts for this conf.', num_conti
3348               else
3349                 jcont_hb(num_conti,i)=j
3350 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3351 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3352                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3353                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3354 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3355 !  terms.
3356                 d_cont(num_conti,i)=rij
3357 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3358 !     --- Electrostatic-interaction matrix ---
3359                 a_chuj(1,1,num_conti,i)=a22
3360                 a_chuj(1,2,num_conti,i)=a23
3361                 a_chuj(2,1,num_conti,i)=a32
3362                 a_chuj(2,2,num_conti,i)=a33
3363 !     --- Gradient of rij
3364                 do kkk=1,3
3365                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3366                 enddo
3367                 kkll=0
3368                 do k=1,2
3369                   do l=1,2
3370                     kkll=kkll+1
3371                     do m=1,3
3372                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3373                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3374                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3375                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3376                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3377                     enddo
3378                   enddo
3379                 enddo
3380                 ENDIF
3381                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3382 ! Calculate contact energies
3383                 cosa4=4.0D0*cosa
3384                 wij=cosa-3.0D0*cosb*cosg
3385                 cosbg1=cosb+cosg
3386                 cosbg2=cosb-cosg
3387 !               fac3=dsqrt(-ael6i)/r0ij**3
3388                 fac3=dsqrt(-ael6i)*r3ij
3389 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3390                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3391                 if (ees0tmp.gt.0) then
3392                   ees0pij=dsqrt(ees0tmp)
3393                 else
3394                   ees0pij=0
3395                 endif
3396 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3397                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3398                 if (ees0tmp.gt.0) then
3399                   ees0mij=dsqrt(ees0tmp)
3400                 else
3401                   ees0mij=0
3402                 endif
3403 !               ees0mij=0.0D0
3404                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3405                      *sss_ele_cut
3406
3407                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3408                      *sss_ele_cut
3409
3410 ! Diagnostics. Comment out or remove after debugging!
3411 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3412 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3413 !               ees0m(num_conti,i)=0.0D0
3414 ! End diagnostics.
3415 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3416 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3417 ! Angular derivatives of the contact function
3418                 ees0pij1=fac3/ees0pij
3419                 ees0mij1=fac3/ees0mij
3420                 fac3p=-3.0D0*fac3*rrmij
3421                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3422                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3423 !               ees0mij1=0.0D0
3424                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3425                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3426                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3427                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3428                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3429                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3430                 ecosap=ecosa1+ecosa2
3431                 ecosbp=ecosb1+ecosb2
3432                 ecosgp=ecosg1+ecosg2
3433                 ecosam=ecosa1-ecosa2
3434                 ecosbm=ecosb1-ecosb2
3435                 ecosgm=ecosg1-ecosg2
3436 ! Diagnostics
3437 !               ecosap=ecosa1
3438 !               ecosbp=ecosb1
3439 !               ecosgp=ecosg1
3440 !               ecosam=0.0D0
3441 !               ecosbm=0.0D0
3442 !               ecosgm=0.0D0
3443 ! End diagnostics
3444                 facont_hb(num_conti,i)=fcont
3445                 fprimcont=fprimcont/rij
3446 !d              facont_hb(num_conti,i)=1.0D0
3447 ! Following line is for diagnostics.
3448 !d              fprimcont=0.0D0
3449                 do k=1,3
3450                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3451                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3452                 enddo
3453                 do k=1,3
3454                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3455                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3456                 enddo
3457                 gggp(1)=gggp(1)+ees0pijp*xj &
3458                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3459                 gggp(2)=gggp(2)+ees0pijp*yj &
3460                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3461                 gggp(3)=gggp(3)+ees0pijp*zj &
3462                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3463
3464                 gggm(1)=gggm(1)+ees0mijp*xj &
3465                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3466
3467                 gggm(2)=gggm(2)+ees0mijp*yj &
3468                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3469
3470                 gggm(3)=gggm(3)+ees0mijp*zj &
3471                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3472
3473 ! Derivatives due to the contact function
3474                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3475                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3476                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3477                 do k=1,3
3478 !
3479 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3480 !          following the change of gradient-summation algorithm.
3481 !
3482 !grad                  ghalfp=0.5D0*gggp(k)
3483 !grad                  ghalfm=0.5D0*gggm(k)
3484                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3485                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3486                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3487                      *sss_ele_cut
3488
3489                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3490                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3491                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3492                      *sss_ele_cut
3493
3494                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3495                      *sss_ele_cut
3496
3497                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3498                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3499                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3500                      *sss_ele_cut
3501
3502                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3503                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3504                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3505                      *sss_ele_cut
3506
3507                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3508                      *sss_ele_cut
3509
3510                 enddo
3511 ! Diagnostics. Comment out or remove after debugging!
3512 !diag           do k=1,3
3513 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3514 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3515 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3516 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3517 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3518 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3519 !diag           enddo
3520               ENDIF ! wcorr
3521               endif  ! num_conti.le.maxconts
3522             endif  ! fcont.gt.0
3523           endif    ! j.gt.i+1
3524           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3525             do k=1,4
3526               do l=1,3
3527                 ghalf=0.5d0*agg(l,k)
3528                 aggi(l,k)=aggi(l,k)+ghalf
3529                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3530                 aggj(l,k)=aggj(l,k)+ghalf
3531               enddo
3532             enddo
3533             if (j.eq.nres-1 .and. i.lt.j-2) then
3534               do k=1,4
3535                 do l=1,3
3536                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3537                 enddo
3538               enddo
3539             endif
3540           endif
3541  128  continue
3542 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3543       return
3544       end subroutine eelecij
3545 !-----------------------------------------------------------------------------
3546       subroutine eturn3(i,eello_turn3)
3547 ! Third- and fourth-order contributions from turns
3548
3549       use comm_locel
3550 !      implicit real*8 (a-h,o-z)
3551 !      include 'DIMENSIONS'
3552 !      include 'COMMON.IOUNITS'
3553 !      include 'COMMON.GEO'
3554 !      include 'COMMON.VAR'
3555 !      include 'COMMON.LOCAL'
3556 !      include 'COMMON.CHAIN'
3557 !      include 'COMMON.DERIV'
3558 !      include 'COMMON.INTERACT'
3559 !      include 'COMMON.CONTACTS'
3560 !      include 'COMMON.TORSION'
3561 !      include 'COMMON.VECTORS'
3562 !      include 'COMMON.FFIELD'
3563 !      include 'COMMON.CONTROL'
3564       real(kind=8),dimension(3) :: ggg
3565       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3566         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3567       real(kind=8),dimension(2) :: auxvec,auxvec1
3568 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3569       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3570 !el      integer :: num_conti,j1,j2
3571 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3572 !el        dz_normi,xmedi,ymedi,zmedi
3573
3574 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3575 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3576 !el         num_conti,j1,j2
3577 !el local variables
3578       integer :: i,j,l
3579       real(kind=8) :: eello_turn3
3580
3581       j=i+2
3582 !      write (iout,*) "eturn3",i,j,j1,j2
3583       a_temp(1,1)=a22
3584       a_temp(1,2)=a23
3585       a_temp(2,1)=a32
3586       a_temp(2,2)=a33
3587 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3588 !
3589 !               Third-order contributions
3590 !
3591 !                 (i+2)o----(i+3)
3592 !                      | |
3593 !                      | |
3594 !                 (i+1)o----i
3595 !
3596 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3597 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3598         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3599         call transpose2(auxmat(1,1),auxmat1(1,1))
3600         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3601         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3602         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3603                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3604 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3605 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3606 !d     &    ' eello_turn3_num',4*eello_turn3_num
3607 ! Derivatives in gamma(i)
3608         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3609         call transpose2(auxmat2(1,1),auxmat3(1,1))
3610         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3611         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3612 ! Derivatives in gamma(i+1)
3613         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3614         call transpose2(auxmat2(1,1),auxmat3(1,1))
3615         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3616         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3617           +0.5d0*(pizda(1,1)+pizda(2,2))
3618 ! Cartesian derivatives
3619         do l=1,3
3620 !            ghalf1=0.5d0*agg(l,1)
3621 !            ghalf2=0.5d0*agg(l,2)
3622 !            ghalf3=0.5d0*agg(l,3)
3623 !            ghalf4=0.5d0*agg(l,4)
3624           a_temp(1,1)=aggi(l,1)!+ghalf1
3625           a_temp(1,2)=aggi(l,2)!+ghalf2
3626           a_temp(2,1)=aggi(l,3)!+ghalf3
3627           a_temp(2,2)=aggi(l,4)!+ghalf4
3628           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3629           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3630             +0.5d0*(pizda(1,1)+pizda(2,2))
3631           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3632           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3633           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3634           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3635           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3636           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3637             +0.5d0*(pizda(1,1)+pizda(2,2))
3638           a_temp(1,1)=aggj(l,1)!+ghalf1
3639           a_temp(1,2)=aggj(l,2)!+ghalf2
3640           a_temp(2,1)=aggj(l,3)!+ghalf3
3641           a_temp(2,2)=aggj(l,4)!+ghalf4
3642           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3643           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3644             +0.5d0*(pizda(1,1)+pizda(2,2))
3645           a_temp(1,1)=aggj1(l,1)
3646           a_temp(1,2)=aggj1(l,2)
3647           a_temp(2,1)=aggj1(l,3)
3648           a_temp(2,2)=aggj1(l,4)
3649           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3650           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3651             +0.5d0*(pizda(1,1)+pizda(2,2))
3652         enddo
3653       return
3654       end subroutine eturn3
3655 !-----------------------------------------------------------------------------
3656       subroutine eturn4(i,eello_turn4)
3657 ! Third- and fourth-order contributions from turns
3658
3659       use comm_locel
3660 !      implicit real*8 (a-h,o-z)
3661 !      include 'DIMENSIONS'
3662 !      include 'COMMON.IOUNITS'
3663 !      include 'COMMON.GEO'
3664 !      include 'COMMON.VAR'
3665 !      include 'COMMON.LOCAL'
3666 !      include 'COMMON.CHAIN'
3667 !      include 'COMMON.DERIV'
3668 !      include 'COMMON.INTERACT'
3669 !      include 'COMMON.CONTACTS'
3670 !      include 'COMMON.TORSION'
3671 !      include 'COMMON.VECTORS'
3672 !      include 'COMMON.FFIELD'
3673 !      include 'COMMON.CONTROL'
3674       real(kind=8),dimension(3) :: ggg
3675       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3676         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3677       real(kind=8),dimension(2) :: auxvec,auxvec1
3678 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3679       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3680 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3681 !el        dz_normi,xmedi,ymedi,zmedi
3682 !el      integer :: num_conti,j1,j2
3683 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3684 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3685 !el          num_conti,j1,j2
3686 !el local variables
3687       integer :: i,j,iti1,iti2,iti3,l
3688       real(kind=8) :: eello_turn4,s1,s2,s3
3689
3690       j=i+3
3691 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3692 !
3693 !               Fourth-order contributions
3694 !
3695 !                 (i+3)o----(i+4)
3696 !                     /  |
3697 !               (i+2)o   |
3698 !                     \  |
3699 !                 (i+1)o----i
3700 !
3701 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3702 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3703 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3704         a_temp(1,1)=a22
3705         a_temp(1,2)=a23
3706         a_temp(2,1)=a32
3707         a_temp(2,2)=a33
3708         iti1=itortyp(itype(i+1))
3709         iti2=itortyp(itype(i+2))
3710         iti3=itortyp(itype(i+3))
3711 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3712         call transpose2(EUg(1,1,i+1),e1t(1,1))
3713         call transpose2(Eug(1,1,i+2),e2t(1,1))
3714         call transpose2(Eug(1,1,i+3),e3t(1,1))
3715         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3716         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3717         s1=scalar2(b1(1,iti2),auxvec(1))
3718         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3719         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3720         s2=scalar2(b1(1,iti1),auxvec(1))
3721         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3722         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3723         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724         eello_turn4=eello_turn4-(s1+s2+s3)
3725         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3726            'eturn4',i,j,-(s1+s2+s3)
3727 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3728 !d     &    ' eello_turn4_num',8*eello_turn4_num
3729 ! Derivatives in gamma(i)
3730         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3731         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3732         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3733         s1=scalar2(b1(1,iti2),auxvec(1))
3734         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3735         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3736         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3737 ! Derivatives in gamma(i+1)
3738         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3739         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3740         s2=scalar2(b1(1,iti1),auxvec(1))
3741         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3742         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3743         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3744         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3745 ! Derivatives in gamma(i+2)
3746         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3747         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3748         s1=scalar2(b1(1,iti2),auxvec(1))
3749         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3750         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3751         s2=scalar2(b1(1,iti1),auxvec(1))
3752         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3753         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3754         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3755         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3756 ! Cartesian derivatives
3757 ! Derivatives of this turn contributions in DC(i+2)
3758         if (j.lt.nres-1) then
3759           do l=1,3
3760             a_temp(1,1)=agg(l,1)
3761             a_temp(1,2)=agg(l,2)
3762             a_temp(2,1)=agg(l,3)
3763             a_temp(2,2)=agg(l,4)
3764             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3765             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3766             s1=scalar2(b1(1,iti2),auxvec(1))
3767             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3768             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3769             s2=scalar2(b1(1,iti1),auxvec(1))
3770             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3771             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3772             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3773             ggg(l)=-(s1+s2+s3)
3774             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3775           enddo
3776         endif
3777 ! Remaining derivatives of this turn contribution
3778         do l=1,3
3779           a_temp(1,1)=aggi(l,1)
3780           a_temp(1,2)=aggi(l,2)
3781           a_temp(2,1)=aggi(l,3)
3782           a_temp(2,2)=aggi(l,4)
3783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3785           s1=scalar2(b1(1,iti2),auxvec(1))
3786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3788           s2=scalar2(b1(1,iti1),auxvec(1))
3789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3792           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3793           a_temp(1,1)=aggi1(l,1)
3794           a_temp(1,2)=aggi1(l,2)
3795           a_temp(2,1)=aggi1(l,3)
3796           a_temp(2,2)=aggi1(l,4)
3797           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3798           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3799           s1=scalar2(b1(1,iti2),auxvec(1))
3800           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3801           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3802           s2=scalar2(b1(1,iti1),auxvec(1))
3803           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3804           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3805           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3806           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3807           a_temp(1,1)=aggj(l,1)
3808           a_temp(1,2)=aggj(l,2)
3809           a_temp(2,1)=aggj(l,3)
3810           a_temp(2,2)=aggj(l,4)
3811           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3812           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3813           s1=scalar2(b1(1,iti2),auxvec(1))
3814           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3815           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3816           s2=scalar2(b1(1,iti1),auxvec(1))
3817           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3818           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3819           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3820           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3821           a_temp(1,1)=aggj1(l,1)
3822           a_temp(1,2)=aggj1(l,2)
3823           a_temp(2,1)=aggj1(l,3)
3824           a_temp(2,2)=aggj1(l,4)
3825           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3826           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3827           s1=scalar2(b1(1,iti2),auxvec(1))
3828           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3829           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3830           s2=scalar2(b1(1,iti1),auxvec(1))
3831           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3832           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3833           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3834 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3835           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3836         enddo
3837       return
3838       end subroutine eturn4
3839 !-----------------------------------------------------------------------------
3840       subroutine unormderiv(u,ugrad,unorm,ungrad)
3841 ! This subroutine computes the derivatives of a normalized vector u, given
3842 ! the derivatives computed without normalization conditions, ugrad. Returns
3843 ! ungrad.
3844 !      implicit none
3845       real(kind=8),dimension(3) :: u,vec
3846       real(kind=8),dimension(3,3) ::ugrad,ungrad
3847       real(kind=8) :: unorm     !,scalar
3848       integer :: i,j
3849 !      write (2,*) 'ugrad',ugrad
3850 !      write (2,*) 'u',u
3851       do i=1,3
3852         vec(i)=scalar(ugrad(1,i),u(1))
3853       enddo
3854 !      write (2,*) 'vec',vec
3855       do i=1,3
3856         do j=1,3
3857           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3858         enddo
3859       enddo
3860 !      write (2,*) 'ungrad',ungrad
3861       return
3862       end subroutine unormderiv
3863 !-----------------------------------------------------------------------------
3864       subroutine escp_soft_sphere(evdw2,evdw2_14)
3865 !
3866 ! This subroutine calculates the excluded-volume interaction energy between
3867 ! peptide-group centers and side chains and its gradient in virtual-bond and
3868 ! side-chain vectors.
3869 !
3870 !      implicit real*8 (a-h,o-z)
3871 !      include 'DIMENSIONS'
3872 !      include 'COMMON.GEO'
3873 !      include 'COMMON.VAR'
3874 !      include 'COMMON.LOCAL'
3875 !      include 'COMMON.CHAIN'
3876 !      include 'COMMON.DERIV'
3877 !      include 'COMMON.INTERACT'
3878 !      include 'COMMON.FFIELD'
3879 !      include 'COMMON.IOUNITS'
3880 !      include 'COMMON.CONTROL'
3881       real(kind=8),dimension(3) :: ggg
3882 !el local variables
3883       integer :: i,iint,j,k,iteli,itypj
3884       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3885                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3886
3887       evdw2=0.0D0
3888       evdw2_14=0.0d0
3889       r0_scp=4.5d0
3890 !d    print '(a)','Enter ESCP'
3891 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3892       do i=iatscp_s,iatscp_e
3893         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3894         iteli=itel(i)
3895         xi=0.5D0*(c(1,i)+c(1,i+1))
3896         yi=0.5D0*(c(2,i)+c(2,i+1))
3897         zi=0.5D0*(c(3,i)+c(3,i+1))
3898
3899         do iint=1,nscp_gr(i)
3900
3901         do j=iscpstart(i,iint),iscpend(i,iint)
3902           if (itype(j).eq.ntyp1) cycle
3903           itypj=iabs(itype(j))
3904 ! Uncomment following three lines for SC-p interactions
3905 !         xj=c(1,nres+j)-xi
3906 !         yj=c(2,nres+j)-yi
3907 !         zj=c(3,nres+j)-zi
3908 ! Uncomment following three lines for Ca-p interactions
3909           xj=c(1,j)-xi
3910           yj=c(2,j)-yi
3911           zj=c(3,j)-zi
3912           rij=xj*xj+yj*yj+zj*zj
3913           r0ij=r0_scp
3914           r0ijsq=r0ij*r0ij
3915           if (rij.lt.r0ijsq) then
3916             evdwij=0.25d0*(rij-r0ijsq)**2
3917             fac=rij-r0ijsq
3918           else
3919             evdwij=0.0d0
3920             fac=0.0d0
3921           endif
3922           evdw2=evdw2+evdwij
3923 !
3924 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3925 !
3926           ggg(1)=xj*fac
3927           ggg(2)=yj*fac
3928           ggg(3)=zj*fac
3929 !grad          if (j.lt.i) then
3930 !d          write (iout,*) 'j<i'
3931 ! Uncomment following three lines for SC-p interactions
3932 !           do k=1,3
3933 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3934 !           enddo
3935 !grad          else
3936 !d          write (iout,*) 'j>i'
3937 !grad            do k=1,3
3938 !grad              ggg(k)=-ggg(k)
3939 ! Uncomment following line for SC-p interactions
3940 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3941 !grad            enddo
3942 !grad          endif
3943 !grad          do k=1,3
3944 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3945 !grad          enddo
3946 !grad          kstart=min0(i+1,j)
3947 !grad          kend=max0(i-1,j-1)
3948 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3949 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3950 !grad          do k=kstart,kend
3951 !grad            do l=1,3
3952 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3953 !grad            enddo
3954 !grad          enddo
3955           do k=1,3
3956             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3957             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3958           enddo
3959         enddo
3960
3961         enddo ! iint
3962       enddo ! i
3963       return
3964       end subroutine escp_soft_sphere
3965 !-----------------------------------------------------------------------------
3966       subroutine escp(evdw2,evdw2_14)
3967 !
3968 ! This subroutine calculates the excluded-volume interaction energy between
3969 ! peptide-group centers and side chains and its gradient in virtual-bond and
3970 ! side-chain vectors.
3971 !
3972 !      implicit real*8 (a-h,o-z)
3973 !      include 'DIMENSIONS'
3974 !      include 'COMMON.GEO'
3975 !      include 'COMMON.VAR'
3976 !      include 'COMMON.LOCAL'
3977 !      include 'COMMON.CHAIN'
3978 !      include 'COMMON.DERIV'
3979 !      include 'COMMON.INTERACT'
3980 !      include 'COMMON.FFIELD'
3981 !      include 'COMMON.IOUNITS'
3982 !      include 'COMMON.CONTROL'
3983       real(kind=8),dimension(3) :: ggg
3984 !el local variables
3985       integer :: i,iint,j,k,iteli,itypj
3986       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3987                    e1,e2,evdwij
3988
3989       evdw2=0.0D0
3990       evdw2_14=0.0d0
3991 !d    print '(a)','Enter ESCP'
3992 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3993       do i=iatscp_s,iatscp_e
3994         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3995         iteli=itel(i)
3996         xi=0.5D0*(c(1,i)+c(1,i+1))
3997         yi=0.5D0*(c(2,i)+c(2,i+1))
3998         zi=0.5D0*(c(3,i)+c(3,i+1))
3999
4000         do iint=1,nscp_gr(i)
4001
4002         do j=iscpstart(i,iint),iscpend(i,iint)
4003           itypj=iabs(itype(j))
4004           if (itypj.eq.ntyp1) cycle
4005 ! Uncomment following three lines for SC-p interactions
4006 !         xj=c(1,nres+j)-xi
4007 !         yj=c(2,nres+j)-yi
4008 !         zj=c(3,nres+j)-zi
4009 ! Uncomment following three lines for Ca-p interactions
4010           xj=c(1,j)-xi
4011           yj=c(2,j)-yi
4012           zj=c(3,j)-zi
4013           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4014           fac=rrij**expon2
4015           e1=fac*fac*aad(itypj,iteli)
4016           e2=fac*bad(itypj,iteli)
4017           if (iabs(j-i) .le. 2) then
4018             e1=scal14*e1
4019             e2=scal14*e2
4020             evdw2_14=evdw2_14+e1+e2
4021           endif
4022           evdwij=e1+e2
4023           evdw2=evdw2+evdwij
4024 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4025 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4026           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4027              'evdw2',i,j,evdwij
4028 !
4029 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4030 !
4031           fac=-(evdwij+e1)*rrij
4032           ggg(1)=xj*fac
4033           ggg(2)=yj*fac
4034           ggg(3)=zj*fac
4035 !grad          if (j.lt.i) then
4036 !d          write (iout,*) 'j<i'
4037 ! Uncomment following three lines for SC-p interactions
4038 !           do k=1,3
4039 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4040 !           enddo
4041 !grad          else
4042 !d          write (iout,*) 'j>i'
4043 !grad            do k=1,3
4044 !grad              ggg(k)=-ggg(k)
4045 ! Uncomment following line for SC-p interactions
4046 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4047 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4048 !grad            enddo
4049 !grad          endif
4050 !grad          do k=1,3
4051 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4052 !grad          enddo
4053 !grad          kstart=min0(i+1,j)
4054 !grad          kend=max0(i-1,j-1)
4055 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4056 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4057 !grad          do k=kstart,kend
4058 !grad            do l=1,3
4059 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4060 !grad            enddo
4061 !grad          enddo
4062           do k=1,3
4063             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4064             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4065           enddo
4066         enddo
4067
4068         enddo ! iint
4069       enddo ! i
4070       do i=1,nct
4071         do j=1,3
4072           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4073           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4074           gradx_scp(j,i)=expon*gradx_scp(j,i)
4075         enddo
4076       enddo
4077 !******************************************************************************
4078 !
4079 !                              N O T E !!!
4080 !
4081 ! To save time the factor EXPON has been extracted from ALL components
4082 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4083 ! use!
4084 !
4085 !******************************************************************************
4086       return
4087       end subroutine escp
4088 !-----------------------------------------------------------------------------
4089       subroutine edis(ehpb)
4090 !
4091 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4092 !
4093 !      implicit real*8 (a-h,o-z)
4094 !      include 'DIMENSIONS'
4095 !      include 'COMMON.SBRIDGE'
4096 !      include 'COMMON.CHAIN'
4097 !      include 'COMMON.DERIV'
4098 !      include 'COMMON.VAR'
4099 !      include 'COMMON.INTERACT'
4100 !      include 'COMMON.IOUNITS'
4101       real(kind=8),dimension(3) :: ggg
4102 !el local variables
4103       integer :: i,j,ii,jj,iii,jjj,k
4104       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4105
4106       ehpb=0.0D0
4107 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4108 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4109       if (link_end.eq.0) return
4110       do i=link_start,link_end
4111 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4112 ! CA-CA distance used in regularization of structure.
4113         ii=ihpb(i)
4114         jj=jhpb(i)
4115 ! iii and jjj point to the residues for which the distance is assigned.
4116         if (ii.gt.nres) then
4117           iii=ii-nres
4118           jjj=jj-nres
4119         else
4120           iii=ii
4121           jjj=jj
4122         endif
4123 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4124 !     &    dhpb(i),dhpb1(i),forcon(i)
4125 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4126 !    distance and angle dependent SS bond potential.
4127 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4128 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4129         if (.not.dyn_ss .and. i.le.nss) then
4130 ! 15/02/13 CC dynamic SSbond - additional check
4131          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4132         iabs(itype(jjj)).eq.1) then
4133           call ssbond_ene(iii,jjj,eij)
4134           ehpb=ehpb+2*eij
4135 !d          write (iout,*) "eij",eij
4136          endif
4137         else
4138 ! Calculate the distance between the two points and its difference from the
4139 ! target distance.
4140         dd=dist(ii,jj)
4141         rdis=dd-dhpb(i)
4142 ! Get the force constant corresponding to this distance.
4143         waga=forcon(i)
4144 ! Calculate the contribution to energy.
4145         ehpb=ehpb+waga*rdis*rdis
4146 !
4147 ! Evaluate gradient.
4148 !
4149         fac=waga*rdis/dd
4150 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4151 !d   &   ' waga=',waga,' fac=',fac
4152         do j=1,3
4153           ggg(j)=fac*(c(j,jj)-c(j,ii))
4154         enddo
4155 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4156 ! If this is a SC-SC distance, we need to calculate the contributions to the
4157 ! Cartesian gradient in the SC vectors (ghpbx).
4158         if (iii.lt.ii) then
4159           do j=1,3
4160             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4161             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4162           enddo
4163         endif
4164 !grad        do j=iii,jjj-1
4165 !grad          do k=1,3
4166 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4167 !grad          enddo
4168 !grad        enddo
4169         do k=1,3
4170           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4171           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4172         enddo
4173         endif
4174       enddo
4175       ehpb=0.5D0*ehpb
4176       return
4177       end subroutine edis
4178 !-----------------------------------------------------------------------------
4179       subroutine ssbond_ene(i,j,eij)
4180 !
4181 ! Calculate the distance and angle dependent SS-bond potential energy
4182 ! using a free-energy function derived based on RHF/6-31G** ab initio
4183 ! calculations of diethyl disulfide.
4184 !
4185 ! A. Liwo and U. Kozlowska, 11/24/03
4186 !
4187 !      implicit real*8 (a-h,o-z)
4188 !      include 'DIMENSIONS'
4189 !      include 'COMMON.SBRIDGE'
4190 !      include 'COMMON.CHAIN'
4191 !      include 'COMMON.DERIV'
4192 !      include 'COMMON.LOCAL'
4193 !      include 'COMMON.INTERACT'
4194 !      include 'COMMON.VAR'
4195 !      include 'COMMON.IOUNITS'
4196       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4197 !el local variables
4198       integer :: i,j,itypi,itypj,k
4199       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4200                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4201                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4202                    cosphi,ggk
4203
4204       itypi=iabs(itype(i))
4205       xi=c(1,nres+i)
4206       yi=c(2,nres+i)
4207       zi=c(3,nres+i)
4208       dxi=dc_norm(1,nres+i)
4209       dyi=dc_norm(2,nres+i)
4210       dzi=dc_norm(3,nres+i)
4211 !      dsci_inv=dsc_inv(itypi)
4212       dsci_inv=vbld_inv(nres+i)
4213       itypj=iabs(itype(j))
4214 !      dscj_inv=dsc_inv(itypj)
4215       dscj_inv=vbld_inv(nres+j)
4216       xj=c(1,nres+j)-xi
4217       yj=c(2,nres+j)-yi
4218       zj=c(3,nres+j)-zi
4219       dxj=dc_norm(1,nres+j)
4220       dyj=dc_norm(2,nres+j)
4221       dzj=dc_norm(3,nres+j)
4222       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4223       rij=dsqrt(rrij)
4224       erij(1)=xj*rij
4225       erij(2)=yj*rij
4226       erij(3)=zj*rij
4227       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4228       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4229       om12=dxi*dxj+dyi*dyj+dzi*dzj
4230       do k=1,3
4231         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4232         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4233       enddo
4234       rij=1.0d0/rij
4235       deltad=rij-d0cm
4236       deltat1=1.0d0-om1
4237       deltat2=1.0d0+om2
4238       deltat12=om2-om1+2.0d0
4239       cosphi=om12-om1*om2
4240       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4241         +akct*deltad*deltat12 &
4242         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4243 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4244 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4245 !     &  " deltat12",deltat12," eij",eij
4246       ed=2*akcm*deltad+akct*deltat12
4247       pom1=akct*deltad
4248       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4249       eom1=-2*akth*deltat1-pom1-om2*pom2
4250       eom2= 2*akth*deltat2+pom1-om1*pom2
4251       eom12=pom2
4252       do k=1,3
4253         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4254         ghpbx(k,i)=ghpbx(k,i)-ggk &
4255                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4256                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4257         ghpbx(k,j)=ghpbx(k,j)+ggk &
4258                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4259                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4260         ghpbc(k,i)=ghpbc(k,i)-ggk
4261         ghpbc(k,j)=ghpbc(k,j)+ggk
4262       enddo
4263 !
4264 ! Calculate the components of the gradient in DC and X
4265 !
4266 !grad      do k=i,j-1
4267 !grad        do l=1,3
4268 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4269 !grad        enddo
4270 !grad      enddo
4271       return
4272       end subroutine ssbond_ene
4273 !-----------------------------------------------------------------------------
4274       subroutine ebond(estr)
4275 !
4276 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4277 !
4278 !      implicit real*8 (a-h,o-z)
4279 !      include 'DIMENSIONS'
4280 !      include 'COMMON.LOCAL'
4281 !      include 'COMMON.GEO'
4282 !      include 'COMMON.INTERACT'
4283 !      include 'COMMON.DERIV'
4284 !      include 'COMMON.VAR'
4285 !      include 'COMMON.CHAIN'
4286 !      include 'COMMON.IOUNITS'
4287 !      include 'COMMON.NAMES'
4288 !      include 'COMMON.FFIELD'
4289 !      include 'COMMON.CONTROL'
4290 !      include 'COMMON.SETUP'
4291       real(kind=8),dimension(3) :: u,ud
4292 !el local variables
4293       integer :: i,j,iti,nbi,k
4294       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4295                    uprod1,uprod2
4296
4297       estr=0.0d0
4298       estr1=0.0d0
4299 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4300 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4301
4302       do i=ibondp_start,ibondp_end
4303         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4304         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4305 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4306 !C          do j=1,3
4307 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4308 !C            *dc(j,i-1)/vbld(i)
4309 !C          enddo
4310 !C          if (energy_dec) write(iout,*) &
4311 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4312         diff = vbld(i)-vbldpDUM
4313         else
4314         diff = vbld(i)-vbldp0
4315         endif
4316         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4317            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4318         estr=estr+diff*diff
4319         do j=1,3
4320           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4321         enddo
4322 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4323 !        endif
4324       enddo
4325       estr=0.5d0*AKP*estr+estr1
4326 !
4327 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4328 !
4329       do i=ibond_start,ibond_end
4330         iti=iabs(itype(i))
4331         if (iti.ne.10 .and. iti.ne.ntyp1) then
4332           nbi=nbondterm(iti)
4333           if (nbi.eq.1) then
4334             diff=vbld(i+nres)-vbldsc0(1,iti)
4335             if (energy_dec) write (iout,*) &
4336             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4337             AKSC(1,iti),AKSC(1,iti)*diff*diff
4338             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4339             do j=1,3
4340               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4341             enddo
4342           else
4343             do j=1,nbi
4344               diff=vbld(i+nres)-vbldsc0(j,iti)
4345               ud(j)=aksc(j,iti)*diff
4346               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4347             enddo
4348             uprod=u(1)
4349             do j=2,nbi
4350               uprod=uprod*u(j)
4351             enddo
4352             usum=0.0d0
4353             usumsqder=0.0d0
4354             do j=1,nbi
4355               uprod1=1.0d0
4356               uprod2=1.0d0
4357               do k=1,nbi
4358                 if (k.ne.j) then
4359                   uprod1=uprod1*u(k)
4360                   uprod2=uprod2*u(k)*u(k)
4361                 endif
4362               enddo
4363               usum=usum+uprod1
4364               usumsqder=usumsqder+ud(j)*uprod2
4365             enddo
4366             estr=estr+uprod/usum
4367             do j=1,3
4368              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4369             enddo
4370           endif
4371         endif
4372       enddo
4373       return
4374       end subroutine ebond
4375 #ifdef CRYST_THETA
4376 !-----------------------------------------------------------------------------
4377       subroutine ebend(etheta)
4378 !
4379 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4380 ! angles gamma and its derivatives in consecutive thetas and gammas.
4381 !
4382       use comm_calcthet
4383 !      implicit real*8 (a-h,o-z)
4384 !      include 'DIMENSIONS'
4385 !      include 'COMMON.LOCAL'
4386 !      include 'COMMON.GEO'
4387 !      include 'COMMON.INTERACT'
4388 !      include 'COMMON.DERIV'
4389 !      include 'COMMON.VAR'
4390 !      include 'COMMON.CHAIN'
4391 !      include 'COMMON.IOUNITS'
4392 !      include 'COMMON.NAMES'
4393 !      include 'COMMON.FFIELD'
4394 !      include 'COMMON.CONTROL'
4395 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4396 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4397 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4398 !el      integer :: it
4399 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4400 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4401 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4402 !el local variables
4403       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4404        ichir21,ichir22
4405       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4406        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4407        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4408       real(kind=8),dimension(2) :: y,z
4409
4410       delta=0.02d0*pi
4411 !      time11=dexp(-2*time)
4412 !      time12=1.0d0
4413       etheta=0.0D0
4414 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4415       do i=ithet_start,ithet_end
4416         if (itype(i-1).eq.ntyp1) cycle
4417 ! Zero the energy function and its derivative at 0 or pi.
4418         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4419         it=itype(i-1)
4420         ichir1=isign(1,itype(i-2))
4421         ichir2=isign(1,itype(i))
4422          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4423          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4424          if (itype(i-1).eq.10) then
4425           itype1=isign(10,itype(i-2))
4426           ichir11=isign(1,itype(i-2))
4427           ichir12=isign(1,itype(i-2))
4428           itype2=isign(10,itype(i))
4429           ichir21=isign(1,itype(i))
4430           ichir22=isign(1,itype(i))
4431          endif
4432
4433         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4434 #ifdef OSF
4435           phii=phi(i)
4436           if (phii.ne.phii) phii=150.0
4437 #else
4438           phii=phi(i)
4439 #endif
4440           y(1)=dcos(phii)
4441           y(2)=dsin(phii)
4442         else
4443           y(1)=0.0D0
4444           y(2)=0.0D0
4445         endif
4446         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4447 #ifdef OSF
4448           phii1=phi(i+1)
4449           if (phii1.ne.phii1) phii1=150.0
4450           phii1=pinorm(phii1)
4451           z(1)=cos(phii1)
4452 #else
4453           phii1=phi(i+1)
4454           z(1)=dcos(phii1)
4455 #endif
4456           z(2)=dsin(phii1)
4457         else
4458           z(1)=0.0D0
4459           z(2)=0.0D0
4460         endif
4461 ! Calculate the "mean" value of theta from the part of the distribution
4462 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4463 ! In following comments this theta will be referred to as t_c.
4464         thet_pred_mean=0.0d0
4465         do k=1,2
4466             athetk=athet(k,it,ichir1,ichir2)
4467             bthetk=bthet(k,it,ichir1,ichir2)
4468           if (it.eq.10) then
4469              athetk=athet(k,itype1,ichir11,ichir12)
4470              bthetk=bthet(k,itype2,ichir21,ichir22)
4471           endif
4472          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4473         enddo
4474         dthett=thet_pred_mean*ssd
4475         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4476 ! Derivatives of the "mean" values in gamma1 and gamma2.
4477         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4478                +athet(2,it,ichir1,ichir2)*y(1))*ss
4479         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4480                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4481          if (it.eq.10) then
4482         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4483              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4484         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4485                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4486          endif
4487         if (theta(i).gt.pi-delta) then
4488           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4489                E_tc0)
4490           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4491           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4492           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4493               E_theta)
4494           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4495               E_tc)
4496         else if (theta(i).lt.delta) then
4497           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4498           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4499           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4500               E_theta)
4501           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4502           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4503               E_tc)
4504         else
4505           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4506               E_theta,E_tc)
4507         endif
4508         etheta=etheta+ethetai
4509         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4510             'ebend',i,ethetai
4511         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4512         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4513         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4514       enddo
4515 ! Ufff.... We've done all this!!!
4516       return
4517       end subroutine ebend
4518 !-----------------------------------------------------------------------------
4519       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4520
4521       use comm_calcthet
4522 !      implicit real*8 (a-h,o-z)
4523 !      include 'DIMENSIONS'
4524 !      include 'COMMON.LOCAL'
4525 !      include 'COMMON.IOUNITS'
4526 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4527 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4528 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4529       integer :: i,j,k
4530       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4531 !el      integer :: it
4532 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4533 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4534 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4535 !el local variables
4536       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4537        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4538
4539 ! Calculate the contributions to both Gaussian lobes.
4540 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4541 ! The "polynomial part" of the "standard deviation" of this part of
4542 ! the distribution.
4543         sig=polthet(3,it)
4544         do j=2,0,-1
4545           sig=sig*thet_pred_mean+polthet(j,it)
4546         enddo
4547 ! Derivative of the "interior part" of the "standard deviation of the"
4548 ! gamma-dependent Gaussian lobe in t_c.
4549         sigtc=3*polthet(3,it)
4550         do j=2,1,-1
4551           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4552         enddo
4553         sigtc=sig*sigtc
4554 ! Set the parameters of both Gaussian lobes of the distribution.
4555 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4556         fac=sig*sig+sigc0(it)
4557         sigcsq=fac+fac
4558         sigc=1.0D0/sigcsq
4559 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4560         sigsqtc=-4.0D0*sigcsq*sigtc
4561 !       print *,i,sig,sigtc,sigsqtc
4562 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4563         sigtc=-sigtc/(fac*fac)
4564 ! Following variable is sigma(t_c)**(-2)
4565         sigcsq=sigcsq*sigcsq
4566         sig0i=sig0(it)
4567         sig0inv=1.0D0/sig0i**2
4568         delthec=thetai-thet_pred_mean
4569         delthe0=thetai-theta0i
4570         term1=-0.5D0*sigcsq*delthec*delthec
4571         term2=-0.5D0*sig0inv*delthe0*delthe0
4572 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4573 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4574 ! to the energy (this being the log of the distribution) at the end of energy
4575 ! term evaluation for this virtual-bond angle.
4576         if (term1.gt.term2) then
4577           termm=term1
4578           term2=dexp(term2-termm)
4579           term1=1.0d0
4580         else
4581           termm=term2
4582           term1=dexp(term1-termm)
4583           term2=1.0d0
4584         endif
4585 ! The ratio between the gamma-independent and gamma-dependent lobes of
4586 ! the distribution is a Gaussian function of thet_pred_mean too.
4587         diffak=gthet(2,it)-thet_pred_mean
4588         ratak=diffak/gthet(3,it)**2
4589         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4590 ! Let's differentiate it in thet_pred_mean NOW.
4591         aktc=ak*ratak
4592 ! Now put together the distribution terms to make complete distribution.
4593         termexp=term1+ak*term2
4594         termpre=sigc+ak*sig0i
4595 ! Contribution of the bending energy from this theta is just the -log of
4596 ! the sum of the contributions from the two lobes and the pre-exponential
4597 ! factor. Simple enough, isn't it?
4598         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4599 ! NOW the derivatives!!!
4600 ! 6/6/97 Take into account the deformation.
4601         E_theta=(delthec*sigcsq*term1 &
4602              +ak*delthe0*sig0inv*term2)/termexp
4603         E_tc=((sigtc+aktc*sig0i)/termpre &
4604             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4605              aktc*term2)/termexp)
4606       return
4607       end subroutine theteng
4608 #else
4609 !-----------------------------------------------------------------------------
4610       subroutine ebend(etheta)
4611 !
4612 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4613 ! angles gamma and its derivatives in consecutive thetas and gammas.
4614 ! ab initio-derived potentials from
4615 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4616 !
4617 !      implicit real*8 (a-h,o-z)
4618 !      include 'DIMENSIONS'
4619 !      include 'COMMON.LOCAL'
4620 !      include 'COMMON.GEO'
4621 !      include 'COMMON.INTERACT'
4622 !      include 'COMMON.DERIV'
4623 !      include 'COMMON.VAR'
4624 !      include 'COMMON.CHAIN'
4625 !      include 'COMMON.IOUNITS'
4626 !      include 'COMMON.NAMES'
4627 !      include 'COMMON.FFIELD'
4628 !      include 'COMMON.CONTROL'
4629       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4630       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4631       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4632       logical :: lprn=.false., lprn1=.false.
4633 !el local variables
4634       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4635       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4636       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4637
4638       etheta=0.0D0
4639       do i=ithet_start,ithet_end
4640         if (itype(i-1).eq.ntyp1) cycle
4641         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4642         if (iabs(itype(i+1)).eq.20) iblock=2
4643         if (iabs(itype(i+1)).ne.20) iblock=1
4644         dethetai=0.0d0
4645         dephii=0.0d0
4646         dephii1=0.0d0
4647         theti2=0.5d0*theta(i)
4648         ityp2=ithetyp((itype(i-1)))
4649         do k=1,nntheterm
4650           coskt(k)=dcos(k*theti2)
4651           sinkt(k)=dsin(k*theti2)
4652         enddo
4653         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4654 #ifdef OSF
4655           phii=phi(i)
4656           if (phii.ne.phii) phii=150.0
4657 #else
4658           phii=phi(i)
4659 #endif
4660           ityp1=ithetyp((itype(i-2)))
4661 ! propagation of chirality for glycine type
4662           do k=1,nsingle
4663             cosph1(k)=dcos(k*phii)
4664             sinph1(k)=dsin(k*phii)
4665           enddo
4666         else
4667           phii=0.0d0
4668           ityp1=ithetyp(itype(i-2))
4669           do k=1,nsingle
4670             cosph1(k)=0.0d0
4671             sinph1(k)=0.0d0
4672           enddo
4673         endif
4674         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4675 #ifdef OSF
4676           phii1=phi(i+1)
4677           if (phii1.ne.phii1) phii1=150.0
4678           phii1=pinorm(phii1)
4679 #else
4680           phii1=phi(i+1)
4681 #endif
4682           ityp3=ithetyp((itype(i)))
4683           do k=1,nsingle
4684             cosph2(k)=dcos(k*phii1)
4685             sinph2(k)=dsin(k*phii1)
4686           enddo
4687         else
4688           phii1=0.0d0
4689           ityp3=ithetyp(itype(i))
4690           do k=1,nsingle
4691             cosph2(k)=0.0d0
4692             sinph2(k)=0.0d0
4693           enddo
4694         endif
4695         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4696         do k=1,ndouble
4697           do l=1,k-1
4698             ccl=cosph1(l)*cosph2(k-l)
4699             ssl=sinph1(l)*sinph2(k-l)
4700             scl=sinph1(l)*cosph2(k-l)
4701             csl=cosph1(l)*sinph2(k-l)
4702             cosph1ph2(l,k)=ccl-ssl
4703             cosph1ph2(k,l)=ccl+ssl
4704             sinph1ph2(l,k)=scl+csl
4705             sinph1ph2(k,l)=scl-csl
4706           enddo
4707         enddo
4708         if (lprn) then
4709         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4710           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4711         write (iout,*) "coskt and sinkt"
4712         do k=1,nntheterm
4713           write (iout,*) k,coskt(k),sinkt(k)
4714         enddo
4715         endif
4716         do k=1,ntheterm
4717           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4718           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4719             *coskt(k)
4720           if (lprn) &
4721           write (iout,*) "k",k,&
4722            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4723            " ethetai",ethetai
4724         enddo
4725         if (lprn) then
4726         write (iout,*) "cosph and sinph"
4727         do k=1,nsingle
4728           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4729         enddo
4730         write (iout,*) "cosph1ph2 and sinph2ph2"
4731         do k=2,ndouble
4732           do l=1,k-1
4733             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4734                sinph1ph2(l,k),sinph1ph2(k,l)
4735           enddo
4736         enddo
4737         write(iout,*) "ethetai",ethetai
4738         endif
4739         do m=1,ntheterm2
4740           do k=1,nsingle
4741             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4742                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4743                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4744                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4745             ethetai=ethetai+sinkt(m)*aux
4746             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4747             dephii=dephii+k*sinkt(m)* &
4748                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4749                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4750             dephii1=dephii1+k*sinkt(m)* &
4751                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4752                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4753             if (lprn) &
4754             write (iout,*) "m",m," k",k," bbthet", &
4755                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4756                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4757                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4758                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4759           enddo
4760         enddo
4761         if (lprn) &
4762         write(iout,*) "ethetai",ethetai
4763         do m=1,ntheterm3
4764           do k=2,ndouble
4765             do l=1,k-1
4766               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4767                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4768                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4769                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4770               ethetai=ethetai+sinkt(m)*aux
4771               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4772               dephii=dephii+l*sinkt(m)* &
4773                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4774                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4775                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4776                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4777               dephii1=dephii1+(k-l)*sinkt(m)* &
4778                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4779                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4780                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4781                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4782               if (lprn) then
4783               write (iout,*) "m",m," k",k," l",l," ffthet",&
4784                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4785                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4786                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4787                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4788                   " ethetai",ethetai
4789               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4790                   cosph1ph2(k,l)*sinkt(m),&
4791                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4792               endif
4793             enddo
4794           enddo
4795         enddo
4796 10      continue
4797 !        lprn1=.true.
4798         if (lprn1) &
4799           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4800          i,theta(i)*rad2deg,phii*rad2deg,&
4801          phii1*rad2deg,ethetai
4802 !        lprn1=.false.
4803         etheta=etheta+ethetai
4804         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4805                                     'ebend',i,ethetai
4806         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4807         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4808         gloc(nphi+i-2,icg)=wang*dethetai
4809       enddo
4810       return
4811       end subroutine ebend
4812 #endif
4813 #ifdef CRYST_SC
4814 !-----------------------------------------------------------------------------
4815       subroutine esc(escloc)
4816 ! Calculate the local energy of a side chain and its derivatives in the
4817 ! corresponding virtual-bond valence angles THETA and the spherical angles
4818 ! ALPHA and OMEGA.
4819 !
4820       use comm_sccalc
4821 !      implicit real*8 (a-h,o-z)
4822 !      include 'DIMENSIONS'
4823 !      include 'COMMON.GEO'
4824 !      include 'COMMON.LOCAL'
4825 !      include 'COMMON.VAR'
4826 !      include 'COMMON.INTERACT'
4827 !      include 'COMMON.DERIV'
4828 !      include 'COMMON.CHAIN'
4829 !      include 'COMMON.IOUNITS'
4830 !      include 'COMMON.NAMES'
4831 !      include 'COMMON.FFIELD'
4832 !      include 'COMMON.CONTROL'
4833       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4834          ddersc0,ddummy,xtemp,temp
4835 !el      real(kind=8) :: time11,time12,time112,theti
4836       real(kind=8) :: escloc,delta
4837 !el      integer :: it,nlobit
4838 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4839 !el local variables
4840       integer :: i,k
4841       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4842        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4843       delta=0.02d0*pi
4844       escloc=0.0D0
4845 !     write (iout,'(a)') 'ESC'
4846       do i=loc_start,loc_end
4847         it=itype(i)
4848         if (it.eq.ntyp1) cycle
4849         if (it.eq.10) goto 1
4850         nlobit=nlob(iabs(it))
4851 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4852 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4853         theti=theta(i+1)-pipol
4854         x(1)=dtan(theti)
4855         x(2)=alph(i)
4856         x(3)=omeg(i)
4857
4858         if (x(2).gt.pi-delta) then
4859           xtemp(1)=x(1)
4860           xtemp(2)=pi-delta
4861           xtemp(3)=x(3)
4862           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4863           xtemp(2)=pi
4864           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4865           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4866               escloci,dersc(2))
4867           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4868               ddersc0(1),dersc(1))
4869           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4870               ddersc0(3),dersc(3))
4871           xtemp(2)=pi-delta
4872           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4873           xtemp(2)=pi
4874           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4875           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4876                   dersc0(2),esclocbi,dersc02)
4877           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4878                   dersc12,dersc01)
4879           call splinthet(x(2),0.5d0*delta,ss,ssd)
4880           dersc0(1)=dersc01
4881           dersc0(2)=dersc02
4882           dersc0(3)=0.0d0
4883           do k=1,3
4884             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4885           enddo
4886           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4887 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4888 !    &             esclocbi,ss,ssd
4889           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4890 !         escloci=esclocbi
4891 !         write (iout,*) escloci
4892         else if (x(2).lt.delta) then
4893           xtemp(1)=x(1)
4894           xtemp(2)=delta
4895           xtemp(3)=x(3)
4896           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4897           xtemp(2)=0.0d0
4898           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4899           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4900               escloci,dersc(2))
4901           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4902               ddersc0(1),dersc(1))
4903           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4904               ddersc0(3),dersc(3))
4905           xtemp(2)=delta
4906           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4907           xtemp(2)=0.0d0
4908           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4909           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4910                   dersc0(2),esclocbi,dersc02)
4911           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4912                   dersc12,dersc01)
4913           dersc0(1)=dersc01
4914           dersc0(2)=dersc02
4915           dersc0(3)=0.0d0
4916           call splinthet(x(2),0.5d0*delta,ss,ssd)
4917           do k=1,3
4918             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4919           enddo
4920           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4921 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4922 !    &             esclocbi,ss,ssd
4923           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4924 !         write (iout,*) escloci
4925         else
4926           call enesc(x,escloci,dersc,ddummy,.false.)
4927         endif
4928
4929         escloc=escloc+escloci
4930         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4931            'escloc',i,escloci
4932 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4933
4934         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4935          wscloc*dersc(1)
4936         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4937         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4938     1   continue
4939       enddo
4940       return
4941       end subroutine esc
4942 !-----------------------------------------------------------------------------
4943       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4944
4945       use comm_sccalc
4946 !      implicit real*8 (a-h,o-z)
4947 !      include 'DIMENSIONS'
4948 !      include 'COMMON.GEO'
4949 !      include 'COMMON.LOCAL'
4950 !      include 'COMMON.IOUNITS'
4951 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4952       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4953       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4954       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4955       real(kind=8) :: escloci
4956       logical :: mixed
4957 !el local variables
4958       integer :: j,iii,l,k !el,it,nlobit
4959       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4960 !el       time11,time12,time112
4961 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4962         escloc_i=0.0D0
4963         do j=1,3
4964           dersc(j)=0.0D0
4965           if (mixed) ddersc(j)=0.0d0
4966         enddo
4967         x3=x(3)
4968
4969 ! Because of periodicity of the dependence of the SC energy in omega we have
4970 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4971 ! To avoid underflows, first compute & store the exponents.
4972
4973         do iii=-1,1
4974
4975           x(3)=x3+iii*dwapi
4976
4977           do j=1,nlobit
4978             do k=1,3
4979               z(k)=x(k)-censc(k,j,it)
4980             enddo
4981             do k=1,3
4982               Axk=0.0D0
4983               do l=1,3
4984                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4985               enddo
4986               Ax(k,j,iii)=Axk
4987             enddo
4988             expfac=0.0D0
4989             do k=1,3
4990               expfac=expfac+Ax(k,j,iii)*z(k)
4991             enddo
4992             contr(j,iii)=expfac
4993           enddo ! j
4994
4995         enddo ! iii
4996
4997         x(3)=x3
4998 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4999 ! subsequent NaNs and INFs in energy calculation.
5000 ! Find the largest exponent
5001         emin=contr(1,-1)
5002         do iii=-1,1
5003           do j=1,nlobit
5004             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5005           enddo
5006         enddo
5007         emin=0.5D0*emin
5008 !d      print *,'it=',it,' emin=',emin
5009
5010 ! Compute the contribution to SC energy and derivatives
5011         do iii=-1,1
5012
5013           do j=1,nlobit
5014 #ifdef OSF
5015             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5016             if(adexp.ne.adexp) adexp=1.0
5017             expfac=dexp(adexp)
5018 #else
5019             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5020 #endif
5021 !d          print *,'j=',j,' expfac=',expfac
5022             escloc_i=escloc_i+expfac
5023             do k=1,3
5024               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5025             enddo
5026             if (mixed) then
5027               do k=1,3,2
5028                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5029                   +gaussc(k,2,j,it))*expfac
5030               enddo
5031             endif
5032           enddo
5033
5034         enddo ! iii
5035
5036         dersc(1)=dersc(1)/cos(theti)**2
5037         ddersc(1)=ddersc(1)/cos(theti)**2
5038         ddersc(3)=ddersc(3)
5039
5040         escloci=-(dlog(escloc_i)-emin)
5041         do j=1,3
5042           dersc(j)=dersc(j)/escloc_i
5043         enddo
5044         if (mixed) then
5045           do j=1,3,2
5046             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5047           enddo
5048         endif
5049       return
5050       end subroutine enesc
5051 !-----------------------------------------------------------------------------
5052       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5053
5054       use comm_sccalc
5055 !      implicit real*8 (a-h,o-z)
5056 !      include 'DIMENSIONS'
5057 !      include 'COMMON.GEO'
5058 !      include 'COMMON.LOCAL'
5059 !      include 'COMMON.IOUNITS'
5060 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5061       real(kind=8),dimension(3) :: x,z,dersc
5062       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5063       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5064       real(kind=8) :: escloci,dersc12,emin
5065       logical :: mixed
5066 !el local varables
5067       integer :: j,k,l !el,it,nlobit
5068       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5069
5070       escloc_i=0.0D0
5071
5072       do j=1,3
5073         dersc(j)=0.0D0
5074       enddo
5075
5076       do j=1,nlobit
5077         do k=1,2
5078           z(k)=x(k)-censc(k,j,it)
5079         enddo
5080         z(3)=dwapi
5081         do k=1,3
5082           Axk=0.0D0
5083           do l=1,3
5084             Axk=Axk+gaussc(l,k,j,it)*z(l)
5085           enddo
5086           Ax(k,j)=Axk
5087         enddo
5088         expfac=0.0D0
5089         do k=1,3
5090           expfac=expfac+Ax(k,j)*z(k)
5091         enddo
5092         contr(j)=expfac
5093       enddo ! j
5094
5095 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5096 ! subsequent NaNs and INFs in energy calculation.
5097 ! Find the largest exponent
5098       emin=contr(1)
5099       do j=1,nlobit
5100         if (emin.gt.contr(j)) emin=contr(j)
5101       enddo
5102       emin=0.5D0*emin
5103
5104 ! Compute the contribution to SC energy and derivatives
5105
5106       dersc12=0.0d0
5107       do j=1,nlobit
5108         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5109         escloc_i=escloc_i+expfac
5110         do k=1,2
5111           dersc(k)=dersc(k)+Ax(k,j)*expfac
5112         enddo
5113         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5114                   +gaussc(1,2,j,it))*expfac
5115         dersc(3)=0.0d0
5116       enddo
5117
5118       dersc(1)=dersc(1)/cos(theti)**2
5119       dersc12=dersc12/cos(theti)**2
5120       escloci=-(dlog(escloc_i)-emin)
5121       do j=1,2
5122         dersc(j)=dersc(j)/escloc_i
5123       enddo
5124       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5125       return
5126       end subroutine enesc_bound
5127 #else
5128 !-----------------------------------------------------------------------------
5129       subroutine esc(escloc)
5130 ! Calculate the local energy of a side chain and its derivatives in the
5131 ! corresponding virtual-bond valence angles THETA and the spherical angles
5132 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5133 ! added by Urszula Kozlowska. 07/11/2007
5134 !
5135       use comm_sccalc
5136 !      implicit real*8 (a-h,o-z)
5137 !      include 'DIMENSIONS'
5138 !      include 'COMMON.GEO'
5139 !      include 'COMMON.LOCAL'
5140 !      include 'COMMON.VAR'
5141 !      include 'COMMON.SCROT'
5142 !      include 'COMMON.INTERACT'
5143 !      include 'COMMON.DERIV'
5144 !      include 'COMMON.CHAIN'
5145 !      include 'COMMON.IOUNITS'
5146 !      include 'COMMON.NAMES'
5147 !      include 'COMMON.FFIELD'
5148 !      include 'COMMON.CONTROL'
5149 !      include 'COMMON.VECTORS'
5150       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5151       real(kind=8),dimension(65) :: x
5152       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5153          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5154       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5155       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5156          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5157 !el local variables
5158       integer :: i,j,k !el,it,nlobit
5159       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5160 !el      real(kind=8) :: time11,time12,time112,theti
5161 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5162       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5163                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5164                    sumene1x,sumene2x,sumene3x,sumene4x,&
5165                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5166                    cosfac2xx,sinfac2yy
5167 #ifdef DEBUG
5168       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5169                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5170                    de_dt_num
5171 #endif
5172 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5173
5174       delta=0.02d0*pi
5175       escloc=0.0D0
5176       do i=loc_start,loc_end
5177         if (itype(i).eq.ntyp1) cycle
5178         costtab(i+1) =dcos(theta(i+1))
5179         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5180         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5181         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5182         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5183         cosfac=dsqrt(cosfac2)
5184         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5185         sinfac=dsqrt(sinfac2)
5186         it=iabs(itype(i))
5187         if (it.eq.10) goto 1
5188 !
5189 !  Compute the axes of tghe local cartesian coordinates system; store in
5190 !   x_prime, y_prime and z_prime
5191 !
5192         do j=1,3
5193           x_prime(j) = 0.00
5194           y_prime(j) = 0.00
5195           z_prime(j) = 0.00
5196         enddo
5197 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5198 !     &   dc_norm(3,i+nres)
5199         do j = 1,3
5200           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5201           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5202         enddo
5203         do j = 1,3
5204           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5205         enddo
5206 !       write (2,*) "i",i
5207 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5208 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5209 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5210 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5211 !      & " xy",scalar(x_prime(1),y_prime(1)),
5212 !      & " xz",scalar(x_prime(1),z_prime(1)),
5213 !      & " yy",scalar(y_prime(1),y_prime(1)),
5214 !      & " yz",scalar(y_prime(1),z_prime(1)),
5215 !      & " zz",scalar(z_prime(1),z_prime(1))
5216 !
5217 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5218 ! to local coordinate system. Store in xx, yy, zz.
5219 !
5220         xx=0.0d0
5221         yy=0.0d0
5222         zz=0.0d0
5223         do j = 1,3
5224           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5225           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5226           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5227         enddo
5228
5229         xxtab(i)=xx
5230         yytab(i)=yy
5231         zztab(i)=zz
5232 !
5233 ! Compute the energy of the ith side cbain
5234 !
5235 !        write (2,*) "xx",xx," yy",yy," zz",zz
5236         it=iabs(itype(i))
5237         do j = 1,65
5238           x(j) = sc_parmin(j,it)
5239         enddo
5240 #ifdef CHECK_COORD
5241 !c diagnostics - remove later
5242         xx1 = dcos(alph(2))
5243         yy1 = dsin(alph(2))*dcos(omeg(2))
5244         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5245         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5246           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5247           xx1,yy1,zz1
5248 !,"  --- ", xx_w,yy_w,zz_w
5249 ! end diagnostics
5250 #endif
5251         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5252          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5253          + x(10)*yy*zz
5254         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5255          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5256          + x(20)*yy*zz
5257         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5258          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5259          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5260          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5261          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5262          +x(40)*xx*yy*zz
5263         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5264          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5265          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5266          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5267          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5268          +x(60)*xx*yy*zz
5269         dsc_i   = 0.743d0+x(61)
5270         dp2_i   = 1.9d0+x(62)
5271         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5272                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5273         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5274                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5275         s1=(1+x(63))/(0.1d0 + dscp1)
5276         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5277         s2=(1+x(65))/(0.1d0 + dscp2)
5278         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5279         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5280       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5281 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5282 !     &   sumene4,
5283 !     &   dscp1,dscp2,sumene
5284 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5285         escloc = escloc + sumene
5286 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5287 !     & ,zz,xx,yy
5288 !#define DEBUG
5289 #ifdef DEBUG
5290 !
5291 ! This section to check the numerical derivatives of the energy of ith side
5292 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5293 ! #define DEBUG in the code to turn it on.
5294 !
5295         write (2,*) "sumene               =",sumene
5296         aincr=1.0d-7
5297         xxsave=xx
5298         xx=xx+aincr
5299         write (2,*) xx,yy,zz
5300         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5301         de_dxx_num=(sumenep-sumene)/aincr
5302         xx=xxsave
5303         write (2,*) "xx+ sumene from enesc=",sumenep
5304         yysave=yy
5305         yy=yy+aincr
5306         write (2,*) xx,yy,zz
5307         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5308         de_dyy_num=(sumenep-sumene)/aincr
5309         yy=yysave
5310         write (2,*) "yy+ sumene from enesc=",sumenep
5311         zzsave=zz
5312         zz=zz+aincr
5313         write (2,*) xx,yy,zz
5314         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5315         de_dzz_num=(sumenep-sumene)/aincr
5316         zz=zzsave
5317         write (2,*) "zz+ sumene from enesc=",sumenep
5318         costsave=cost2tab(i+1)
5319         sintsave=sint2tab(i+1)
5320         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5321         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5322         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5323         de_dt_num=(sumenep-sumene)/aincr
5324         write (2,*) " t+ sumene from enesc=",sumenep
5325         cost2tab(i+1)=costsave
5326         sint2tab(i+1)=sintsave
5327 ! End of diagnostics section.
5328 #endif
5329 !
5330 ! Compute the gradient of esc
5331 !
5332 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5333         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5334         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5335         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5336         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5337         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5338         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5339         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5340         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5341         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5342            *(pom_s1/dscp1+pom_s16*dscp1**4)
5343         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5344            *(pom_s2/dscp2+pom_s26*dscp2**4)
5345         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5346         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5347         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5348         +x(40)*yy*zz
5349         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5350         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5351         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5352         +x(60)*yy*zz
5353         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5354               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5355               +(pom1+pom2)*pom_dx
5356 #ifdef DEBUG
5357         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5358 #endif
5359 !
5360         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5361         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5362         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5363         +x(40)*xx*zz
5364         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5365         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5366         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5367         +x(59)*zz**2 +x(60)*xx*zz
5368         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5369               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5370               +(pom1-pom2)*pom_dy
5371 #ifdef DEBUG
5372         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5373 #endif
5374 !
5375         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5376         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5377         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5378         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5379         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5380         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5381         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5382         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5383 #ifdef DEBUG
5384         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5385 #endif
5386 !
5387         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5388         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5389         +pom1*pom_dt1+pom2*pom_dt2
5390 #ifdef DEBUG
5391         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5392 #endif
5393 !
5394 !
5395        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5396        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5397        cosfac2xx=cosfac2*xx
5398        sinfac2yy=sinfac2*yy
5399        do k = 1,3
5400          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5401             vbld_inv(i+1)
5402          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5403             vbld_inv(i)
5404          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5405          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5406 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5407 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5408 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5409 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5410          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5411          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5412          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5413          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5414          dZZ_Ci1(k)=0.0d0
5415          dZZ_Ci(k)=0.0d0
5416          do j=1,3
5417            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5418            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5419            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5420            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5421          enddo
5422
5423          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5424          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5425          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5426          (z_prime(k)-zz*dC_norm(k,i+nres))
5427 !
5428          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5429          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5430        enddo
5431
5432        do k=1,3
5433          dXX_Ctab(k,i)=dXX_Ci(k)
5434          dXX_C1tab(k,i)=dXX_Ci1(k)
5435          dYY_Ctab(k,i)=dYY_Ci(k)
5436          dYY_C1tab(k,i)=dYY_Ci1(k)
5437          dZZ_Ctab(k,i)=dZZ_Ci(k)
5438          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5439          dXX_XYZtab(k,i)=dXX_XYZ(k)
5440          dYY_XYZtab(k,i)=dYY_XYZ(k)
5441          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5442        enddo
5443
5444        do k = 1,3
5445 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5446 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5447 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5448 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5449 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5450 !     &    dt_dci(k)
5451 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5452 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5453          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5454           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5455          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5456           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5457          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5458           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5459        enddo
5460 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5461 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5462
5463 ! to check gradient call subroutine check_grad
5464
5465     1 continue
5466       enddo
5467       return
5468       end subroutine esc
5469 !-----------------------------------------------------------------------------
5470       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5471 !      implicit none
5472       real(kind=8),dimension(65) :: x
5473       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5474         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5475
5476       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5477         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5478         + x(10)*yy*zz
5479       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5480         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5481         + x(20)*yy*zz
5482       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5483         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5484         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5485         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5486         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5487         +x(40)*xx*yy*zz
5488       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5489         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5490         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5491         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5492         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5493         +x(60)*xx*yy*zz
5494       dsc_i   = 0.743d0+x(61)
5495       dp2_i   = 1.9d0+x(62)
5496       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5497                 *(xx*cost2+yy*sint2))
5498       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5499                 *(xx*cost2-yy*sint2))
5500       s1=(1+x(63))/(0.1d0 + dscp1)
5501       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5502       s2=(1+x(65))/(0.1d0 + dscp2)
5503       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5504       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5505        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5506       enesc=sumene
5507       return
5508       end function enesc
5509 #endif
5510 !-----------------------------------------------------------------------------
5511       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5512 !
5513 ! This procedure calculates two-body contact function g(rij) and its derivative:
5514 !
5515 !           eps0ij                                     !       x < -1
5516 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5517 !            0                                         !       x > 1
5518 !
5519 ! where x=(rij-r0ij)/delta
5520 !
5521 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5522 !
5523 !      implicit none
5524       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5525       real(kind=8) :: x,x2,x4,delta
5526 !     delta=0.02D0*r0ij
5527 !      delta=0.2D0*r0ij
5528       x=(rij-r0ij)/delta
5529       if (x.lt.-1.0D0) then
5530         fcont=eps0ij
5531         fprimcont=0.0D0
5532       else if (x.le.1.0D0) then
5533         x2=x*x
5534         x4=x2*x2
5535         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5536         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5537       else
5538         fcont=0.0D0
5539         fprimcont=0.0D0
5540       endif
5541       return
5542       end subroutine gcont
5543 !-----------------------------------------------------------------------------
5544       subroutine splinthet(theti,delta,ss,ssder)
5545 !      implicit real*8 (a-h,o-z)
5546 !      include 'DIMENSIONS'
5547 !      include 'COMMON.VAR'
5548 !      include 'COMMON.GEO'
5549       real(kind=8) :: theti,delta,ss,ssder
5550       real(kind=8) :: thetup,thetlow
5551       thetup=pi-delta
5552       thetlow=delta
5553       if (theti.gt.pipol) then
5554         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5555       else
5556         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5557         ssder=-ssder
5558       endif
5559       return
5560       end subroutine splinthet
5561 !-----------------------------------------------------------------------------
5562       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5563 !      implicit none
5564       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5565       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5566       a1=fprim0*delta/(f1-f0)
5567       a2=3.0d0-2.0d0*a1
5568       a3=a1-2.0d0
5569       ksi=(x-x0)/delta
5570       ksi2=ksi*ksi
5571       ksi3=ksi2*ksi
5572       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5573       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5574       return
5575       end subroutine spline1
5576 !-----------------------------------------------------------------------------
5577       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5578 !      implicit none
5579       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5580       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5581       ksi=(x-x0)/delta
5582       ksi2=ksi*ksi
5583       ksi3=ksi2*ksi
5584       a1=fprim0x*delta
5585       a2=3*(f1x-f0x)-2*fprim0x*delta
5586       a3=fprim0x*delta-2*(f1x-f0x)
5587       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5588       return
5589       end subroutine spline2
5590 !-----------------------------------------------------------------------------
5591 #ifdef CRYST_TOR
5592 !-----------------------------------------------------------------------------
5593       subroutine etor(etors,edihcnstr)
5594 !      implicit real*8 (a-h,o-z)
5595 !      include 'DIMENSIONS'
5596 !      include 'COMMON.VAR'
5597 !      include 'COMMON.GEO'
5598 !      include 'COMMON.LOCAL'
5599 !      include 'COMMON.TORSION'
5600 !      include 'COMMON.INTERACT'
5601 !      include 'COMMON.DERIV'
5602 !      include 'COMMON.CHAIN'
5603 !      include 'COMMON.NAMES'
5604 !      include 'COMMON.IOUNITS'
5605 !      include 'COMMON.FFIELD'
5606 !      include 'COMMON.TORCNSTR'
5607 !      include 'COMMON.CONTROL'
5608       real(kind=8) :: etors,edihcnstr
5609       logical :: lprn
5610 !el local variables
5611       integer :: i,j,
5612       real(kind=8) :: phii,fac,etors_ii
5613
5614 ! Set lprn=.true. for debugging
5615       lprn=.false.
5616 !      lprn=.true.
5617       etors=0.0D0
5618       do i=iphi_start,iphi_end
5619       etors_ii=0.0D0
5620         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5621             .or. itype(i).eq.ntyp1) cycle
5622         itori=itortyp(itype(i-2))
5623         itori1=itortyp(itype(i-1))
5624         phii=phi(i)
5625         gloci=0.0D0
5626 ! Proline-Proline pair is a special case...
5627         if (itori.eq.3 .and. itori1.eq.3) then
5628           if (phii.gt.-dwapi3) then
5629             cosphi=dcos(3*phii)
5630             fac=1.0D0/(1.0D0-cosphi)
5631             etorsi=v1(1,3,3)*fac
5632             etorsi=etorsi+etorsi
5633             etors=etors+etorsi-v1(1,3,3)
5634             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5635             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5636           endif
5637           do j=1,3
5638             v1ij=v1(j+1,itori,itori1)
5639             v2ij=v2(j+1,itori,itori1)
5640             cosphi=dcos(j*phii)
5641             sinphi=dsin(j*phii)
5642             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5643             if (energy_dec) etors_ii=etors_ii+ &
5644                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5645             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5646           enddo
5647         else
5648           do j=1,nterm_old
5649             v1ij=v1(j,itori,itori1)
5650             v2ij=v2(j,itori,itori1)
5651             cosphi=dcos(j*phii)
5652             sinphi=dsin(j*phii)
5653             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5654             if (energy_dec) etors_ii=etors_ii+ &
5655                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5656             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5657           enddo
5658         endif
5659         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5660              'etor',i,etors_ii
5661         if (lprn) &
5662         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5663         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5664         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5665         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5666 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5667       enddo
5668 ! 6/20/98 - dihedral angle constraints
5669       edihcnstr=0.0d0
5670       do i=1,ndih_constr
5671         itori=idih_constr(i)
5672         phii=phi(itori)
5673         difi=phii-phi0(i)
5674         if (difi.gt.drange(i)) then
5675           difi=difi-drange(i)
5676           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5677           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5678         else if (difi.lt.-drange(i)) then
5679           difi=difi+drange(i)
5680           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5681           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5682         endif
5683 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5684 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5685       enddo
5686 !      write (iout,*) 'edihcnstr',edihcnstr
5687       return
5688       end subroutine etor
5689 !-----------------------------------------------------------------------------
5690       subroutine etor_d(etors_d)
5691       real(kind=8) :: etors_d
5692       etors_d=0.0d0
5693       return
5694       end subroutine etor_d
5695 #else
5696 !-----------------------------------------------------------------------------
5697       subroutine etor(etors,edihcnstr)
5698 !      implicit real*8 (a-h,o-z)
5699 !      include 'DIMENSIONS'
5700 !      include 'COMMON.VAR'
5701 !      include 'COMMON.GEO'
5702 !      include 'COMMON.LOCAL'
5703 !      include 'COMMON.TORSION'
5704 !      include 'COMMON.INTERACT'
5705 !      include 'COMMON.DERIV'
5706 !      include 'COMMON.CHAIN'
5707 !      include 'COMMON.NAMES'
5708 !      include 'COMMON.IOUNITS'
5709 !      include 'COMMON.FFIELD'
5710 !      include 'COMMON.TORCNSTR'
5711 !      include 'COMMON.CONTROL'
5712       real(kind=8) :: etors,edihcnstr
5713       logical :: lprn
5714 !el local variables
5715       integer :: i,j,iblock,itori,itori1
5716       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5717                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5718 ! Set lprn=.true. for debugging
5719       lprn=.false.
5720 !     lprn=.true.
5721       etors=0.0D0
5722       do i=iphi_start,iphi_end
5723         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5724              .or. itype(i-3).eq.ntyp1 &
5725              .or. itype(i).eq.ntyp1) cycle
5726         etors_ii=0.0D0
5727          if (iabs(itype(i)).eq.20) then
5728          iblock=2
5729          else
5730          iblock=1
5731          endif
5732         itori=itortyp(itype(i-2))
5733         itori1=itortyp(itype(i-1))
5734         phii=phi(i)
5735         gloci=0.0D0
5736 ! Regular cosine and sine terms
5737         do j=1,nterm(itori,itori1,iblock)
5738           v1ij=v1(j,itori,itori1,iblock)
5739           v2ij=v2(j,itori,itori1,iblock)
5740           cosphi=dcos(j*phii)
5741           sinphi=dsin(j*phii)
5742           etors=etors+v1ij*cosphi+v2ij*sinphi
5743           if (energy_dec) etors_ii=etors_ii+ &
5744                      v1ij*cosphi+v2ij*sinphi
5745           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5746         enddo
5747 ! Lorentz terms
5748 !                         v1
5749 !  E = SUM ----------------------------------- - v1
5750 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5751 !
5752         cosphi=dcos(0.5d0*phii)
5753         sinphi=dsin(0.5d0*phii)
5754         do j=1,nlor(itori,itori1,iblock)
5755           vl1ij=vlor1(j,itori,itori1)
5756           vl2ij=vlor2(j,itori,itori1)
5757           vl3ij=vlor3(j,itori,itori1)
5758           pom=vl2ij*cosphi+vl3ij*sinphi
5759           pom1=1.0d0/(pom*pom+1.0d0)
5760           etors=etors+vl1ij*pom1
5761           if (energy_dec) etors_ii=etors_ii+ &
5762                      vl1ij*pom1
5763           pom=-pom*pom1*pom1
5764           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5765         enddo
5766 ! Subtract the constant term
5767         etors=etors-v0(itori,itori1,iblock)
5768           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5769                'etor',i,etors_ii-v0(itori,itori1,iblock)
5770         if (lprn) &
5771         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5772         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5773         (v1(j,itori,itori1,iblock),j=1,6),&
5774         (v2(j,itori,itori1,iblock),j=1,6)
5775         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5776 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5777       enddo
5778 ! 6/20/98 - dihedral angle constraints
5779       edihcnstr=0.0d0
5780 !      do i=1,ndih_constr
5781       do i=idihconstr_start,idihconstr_end
5782         itori=idih_constr(i)
5783         phii=phi(itori)
5784         difi=pinorm(phii-phi0(i))
5785         if (difi.gt.drange(i)) then
5786           difi=difi-drange(i)
5787           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5788           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5789         else if (difi.lt.-drange(i)) then
5790           difi=difi+drange(i)
5791           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5792           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5793         else
5794           difi=0.0
5795         endif
5796 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5797 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5798 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5799       enddo
5800 !d       write (iout,*) 'edihcnstr',edihcnstr
5801       return
5802       end subroutine etor
5803 !-----------------------------------------------------------------------------
5804       subroutine etor_d(etors_d)
5805 ! 6/23/01 Compute double torsional energy
5806 !      implicit real*8 (a-h,o-z)
5807 !      include 'DIMENSIONS'
5808 !      include 'COMMON.VAR'
5809 !      include 'COMMON.GEO'
5810 !      include 'COMMON.LOCAL'
5811 !      include 'COMMON.TORSION'
5812 !      include 'COMMON.INTERACT'
5813 !      include 'COMMON.DERIV'
5814 !      include 'COMMON.CHAIN'
5815 !      include 'COMMON.NAMES'
5816 !      include 'COMMON.IOUNITS'
5817 !      include 'COMMON.FFIELD'
5818 !      include 'COMMON.TORCNSTR'
5819       real(kind=8) :: etors_d,etors_d_ii
5820       logical :: lprn
5821 !el local variables
5822       integer :: i,j,k,l,itori,itori1,itori2,iblock
5823       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5824                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5825                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5826                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5827 ! Set lprn=.true. for debugging
5828       lprn=.false.
5829 !     lprn=.true.
5830       etors_d=0.0D0
5831 !      write(iout,*) "a tu??"
5832       do i=iphid_start,iphid_end
5833         etors_d_ii=0.0D0
5834         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5835             .or. itype(i-3).eq.ntyp1 &
5836             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5837         itori=itortyp(itype(i-2))
5838         itori1=itortyp(itype(i-1))
5839         itori2=itortyp(itype(i))
5840         phii=phi(i)
5841         phii1=phi(i+1)
5842         gloci1=0.0D0
5843         gloci2=0.0D0
5844         iblock=1
5845         if (iabs(itype(i+1)).eq.20) iblock=2
5846
5847 ! Regular cosine and sine terms
5848         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5849           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5850           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5851           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5852           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5853           cosphi1=dcos(j*phii)
5854           sinphi1=dsin(j*phii)
5855           cosphi2=dcos(j*phii1)
5856           sinphi2=dsin(j*phii1)
5857           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5858            v2cij*cosphi2+v2sij*sinphi2
5859           if (energy_dec) etors_d_ii=etors_d_ii+ &
5860            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5861           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5862           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5863         enddo
5864         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5865           do l=1,k-1
5866             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5867             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5868             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5869             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5870             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5871             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5872             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5873             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5874             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5875               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5876             if (energy_dec) etors_d_ii=etors_d_ii+ &
5877               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5878               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5879             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5880               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5881             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5882               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5883           enddo
5884         enddo
5885         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5886                             'etor_d',i,etors_d_ii
5887         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5888         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5889       enddo
5890       return
5891       end subroutine etor_d
5892 #endif
5893 !-----------------------------------------------------------------------------
5894       subroutine eback_sc_corr(esccor)
5895 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5896 !        conformational states; temporarily implemented as differences
5897 !        between UNRES torsional potentials (dependent on three types of
5898 !        residues) and the torsional potentials dependent on all 20 types
5899 !        of residues computed from AM1  energy surfaces of terminally-blocked
5900 !        amino-acid residues.
5901 !      implicit real*8 (a-h,o-z)
5902 !      include 'DIMENSIONS'
5903 !      include 'COMMON.VAR'
5904 !      include 'COMMON.GEO'
5905 !      include 'COMMON.LOCAL'
5906 !      include 'COMMON.TORSION'
5907 !      include 'COMMON.SCCOR'
5908 !      include 'COMMON.INTERACT'
5909 !      include 'COMMON.DERIV'
5910 !      include 'COMMON.CHAIN'
5911 !      include 'COMMON.NAMES'
5912 !      include 'COMMON.IOUNITS'
5913 !      include 'COMMON.FFIELD'
5914 !      include 'COMMON.CONTROL'
5915       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5916                    cosphi,sinphi
5917       logical :: lprn
5918       integer :: i,interty,j,isccori,isccori1,intertyp
5919 ! Set lprn=.true. for debugging
5920       lprn=.false.
5921 !      lprn=.true.
5922 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5923       esccor=0.0D0
5924       do i=itau_start,itau_end
5925         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5926         esccor_ii=0.0D0
5927         isccori=isccortyp(itype(i-2))
5928         isccori1=isccortyp(itype(i-1))
5929
5930 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5931         phii=phi(i)
5932         do intertyp=1,3 !intertyp
5933          esccor_ii=0.0D0
5934 !c Added 09 May 2012 (Adasko)
5935 !c  Intertyp means interaction type of backbone mainchain correlation:
5936 !   1 = SC...Ca...Ca...Ca
5937 !   2 = Ca...Ca...Ca...SC
5938 !   3 = SC...Ca...Ca...SCi
5939         gloci=0.0D0
5940         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5941             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5942             (itype(i-1).eq.ntyp1))) &
5943           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5944            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5945            .or.(itype(i).eq.ntyp1))) &
5946           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5947             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5948             (itype(i-3).eq.ntyp1)))) cycle
5949         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5950         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5951        cycle
5952        do j=1,nterm_sccor(isccori,isccori1)
5953           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5954           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5955           cosphi=dcos(j*tauangle(intertyp,i))
5956           sinphi=dsin(j*tauangle(intertyp,i))
5957           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5958           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5959           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5960         enddo
5961         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5962                                 'esccor',i,intertyp,esccor_ii
5963 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5964         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5965         if (lprn) &
5966         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5967         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5968         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5969         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5970         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5971        enddo !intertyp
5972       enddo
5973
5974       return
5975       end subroutine eback_sc_corr
5976 !-----------------------------------------------------------------------------
5977       subroutine multibody(ecorr)
5978 ! This subroutine calculates multi-body contributions to energy following
5979 ! the idea of Skolnick et al. If side chains I and J make a contact and
5980 ! at the same time side chains I+1 and J+1 make a contact, an extra
5981 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5982 !      implicit real*8 (a-h,o-z)
5983 !      include 'DIMENSIONS'
5984 !      include 'COMMON.IOUNITS'
5985 !      include 'COMMON.DERIV'
5986 !      include 'COMMON.INTERACT'
5987 !      include 'COMMON.CONTACTS'
5988       real(kind=8),dimension(3) :: gx,gx1
5989       logical :: lprn
5990       real(kind=8) :: ecorr
5991       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5992 ! Set lprn=.true. for debugging
5993       lprn=.false.
5994
5995       if (lprn) then
5996         write (iout,'(a)') 'Contact function values:'
5997         do i=nnt,nct-2
5998           write (iout,'(i2,20(1x,i2,f10.5))') &
5999               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6000         enddo
6001       endif
6002       ecorr=0.0D0
6003
6004 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6005 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6006       do i=nnt,nct
6007         do j=1,3
6008           gradcorr(j,i)=0.0D0
6009           gradxorr(j,i)=0.0D0
6010         enddo
6011       enddo
6012       do i=nnt,nct-2
6013
6014         DO ISHIFT = 3,4
6015
6016         i1=i+ishift
6017         num_conti=num_cont(i)
6018         num_conti1=num_cont(i1)
6019         do jj=1,num_conti
6020           j=jcont(jj,i)
6021           do kk=1,num_conti1
6022             j1=jcont(kk,i1)
6023             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6024 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6025 !d   &                   ' ishift=',ishift
6026 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6027 ! The system gains extra energy.
6028               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6029             endif   ! j1==j+-ishift
6030           enddo     ! kk
6031         enddo       ! jj
6032
6033         ENDDO ! ISHIFT
6034
6035       enddo         ! i
6036       return
6037       end subroutine multibody
6038 !-----------------------------------------------------------------------------
6039       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6040 !      implicit real*8 (a-h,o-z)
6041 !      include 'DIMENSIONS'
6042 !      include 'COMMON.IOUNITS'
6043 !      include 'COMMON.DERIV'
6044 !      include 'COMMON.INTERACT'
6045 !      include 'COMMON.CONTACTS'
6046       real(kind=8),dimension(3) :: gx,gx1
6047       logical :: lprn
6048       integer :: i,j,k,l,jj,kk,m,ll
6049       real(kind=8) :: eij,ekl
6050       lprn=.false.
6051       eij=facont(jj,i)
6052       ekl=facont(kk,k)
6053 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6054 ! Calculate the multi-body contribution to energy.
6055 ! Calculate multi-body contributions to the gradient.
6056 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6057 !d   & k,l,(gacont(m,kk,k),m=1,3)
6058       do m=1,3
6059         gx(m) =ekl*gacont(m,jj,i)
6060         gx1(m)=eij*gacont(m,kk,k)
6061         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6062         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6063         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6064         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6065       enddo
6066       do m=i,j-1
6067         do ll=1,3
6068           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6069         enddo
6070       enddo
6071       do m=k,l-1
6072         do ll=1,3
6073           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6074         enddo
6075       enddo
6076       esccorr=-eij*ekl
6077       return
6078       end function esccorr
6079 !-----------------------------------------------------------------------------
6080       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6081 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6082 !      implicit real*8 (a-h,o-z)
6083 !      include 'DIMENSIONS'
6084 !      include 'COMMON.IOUNITS'
6085 #ifdef MPI
6086       include "mpif.h"
6087 !      integer :: maxconts !max_cont=maxconts  =nres/4
6088       integer,parameter :: max_dim=26
6089       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6090       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6091 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6092 !el      common /przechowalnia/ zapas
6093       integer :: status(MPI_STATUS_SIZE)
6094       integer,dimension((nres/4)*2) :: req !maxconts*2
6095       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6096 #endif
6097 !      include 'COMMON.SETUP'
6098 !      include 'COMMON.FFIELD'
6099 !      include 'COMMON.DERIV'
6100 !      include 'COMMON.INTERACT'
6101 !      include 'COMMON.CONTACTS'
6102 !      include 'COMMON.CONTROL'
6103 !      include 'COMMON.LOCAL'
6104       real(kind=8),dimension(3) :: gx,gx1
6105       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6106       logical :: lprn,ldone
6107 !el local variables
6108       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6109               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6110
6111 ! Set lprn=.true. for debugging
6112       lprn=.false.
6113 #ifdef MPI
6114 !      maxconts=nres/4
6115       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6116       n_corr=0
6117       n_corr1=0
6118       if (nfgtasks.le.1) goto 30
6119       if (lprn) then
6120         write (iout,'(a)') 'Contact function values before RECEIVE:'
6121         do i=nnt,nct-2
6122           write (iout,'(2i3,50(1x,i2,f5.2))') &
6123           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6124           j=1,num_cont_hb(i))
6125         enddo
6126       endif
6127       call flush(iout)
6128       do i=1,ntask_cont_from
6129         ncont_recv(i)=0
6130       enddo
6131       do i=1,ntask_cont_to
6132         ncont_sent(i)=0
6133       enddo
6134 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6135 !     & ntask_cont_to
6136 ! Make the list of contacts to send to send to other procesors
6137 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6138 !      call flush(iout)
6139       do i=iturn3_start,iturn3_end
6140 !        write (iout,*) "make contact list turn3",i," num_cont",
6141 !     &    num_cont_hb(i)
6142         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6143       enddo
6144       do i=iturn4_start,iturn4_end
6145 !        write (iout,*) "make contact list turn4",i," num_cont",
6146 !     &   num_cont_hb(i)
6147         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6148       enddo
6149       do ii=1,nat_sent
6150         i=iat_sent(ii)
6151 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6152 !     &    num_cont_hb(i)
6153         do j=1,num_cont_hb(i)
6154         do k=1,4
6155           jjc=jcont_hb(j,i)
6156           iproc=iint_sent_local(k,jjc,ii)
6157 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6158           if (iproc.gt.0) then
6159             ncont_sent(iproc)=ncont_sent(iproc)+1
6160             nn=ncont_sent(iproc)
6161             zapas(1,nn,iproc)=i
6162             zapas(2,nn,iproc)=jjc
6163             zapas(3,nn,iproc)=facont_hb(j,i)
6164             zapas(4,nn,iproc)=ees0p(j,i)
6165             zapas(5,nn,iproc)=ees0m(j,i)
6166             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6167             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6168             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6169             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6170             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6171             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6172             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6173             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6174             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6175             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6176             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6177             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6178             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6179             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6180             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6181             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6182             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6183             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6184             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6185             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6186             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6187           endif
6188         enddo
6189         enddo
6190       enddo
6191       if (lprn) then
6192       write (iout,*) &
6193         "Numbers of contacts to be sent to other processors",&
6194         (ncont_sent(i),i=1,ntask_cont_to)
6195       write (iout,*) "Contacts sent"
6196       do ii=1,ntask_cont_to
6197         nn=ncont_sent(ii)
6198         iproc=itask_cont_to(ii)
6199         write (iout,*) nn," contacts to processor",iproc,&
6200          " of CONT_TO_COMM group"
6201         do i=1,nn
6202           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6203         enddo
6204       enddo
6205       call flush(iout)
6206       endif
6207       CorrelType=477
6208       CorrelID=fg_rank+1
6209       CorrelType1=478
6210       CorrelID1=nfgtasks+fg_rank+1
6211       ireq=0
6212 ! Receive the numbers of needed contacts from other processors
6213       do ii=1,ntask_cont_from
6214         iproc=itask_cont_from(ii)
6215         ireq=ireq+1
6216         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6217           FG_COMM,req(ireq),IERR)
6218       enddo
6219 !      write (iout,*) "IRECV ended"
6220 !      call flush(iout)
6221 ! Send the number of contacts needed by other processors
6222       do ii=1,ntask_cont_to
6223         iproc=itask_cont_to(ii)
6224         ireq=ireq+1
6225         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6226           FG_COMM,req(ireq),IERR)
6227       enddo
6228 !      write (iout,*) "ISEND ended"
6229 !      write (iout,*) "number of requests (nn)",ireq
6230       call flush(iout)
6231       if (ireq.gt.0) &
6232         call MPI_Waitall(ireq,req,status_array,ierr)
6233 !      write (iout,*)
6234 !     &  "Numbers of contacts to be received from other processors",
6235 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6236 !      call flush(iout)
6237 ! Receive contacts
6238       ireq=0
6239       do ii=1,ntask_cont_from
6240         iproc=itask_cont_from(ii)
6241         nn=ncont_recv(ii)
6242 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6243 !     &   " of CONT_TO_COMM group"
6244         call flush(iout)
6245         if (nn.gt.0) then
6246           ireq=ireq+1
6247           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6248           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6249 !          write (iout,*) "ireq,req",ireq,req(ireq)
6250         endif
6251       enddo
6252 ! Send the contacts to processors that need them
6253       do ii=1,ntask_cont_to
6254         iproc=itask_cont_to(ii)
6255         nn=ncont_sent(ii)
6256 !        write (iout,*) nn," contacts to processor",iproc,
6257 !     &   " of CONT_TO_COMM group"
6258         if (nn.gt.0) then
6259           ireq=ireq+1
6260           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6261             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6262 !          write (iout,*) "ireq,req",ireq,req(ireq)
6263 !          do i=1,nn
6264 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6265 !          enddo
6266         endif
6267       enddo
6268 !      write (iout,*) "number of requests (contacts)",ireq
6269 !      write (iout,*) "req",(req(i),i=1,4)
6270 !      call flush(iout)
6271       if (ireq.gt.0) &
6272        call MPI_Waitall(ireq,req,status_array,ierr)
6273       do iii=1,ntask_cont_from
6274         iproc=itask_cont_from(iii)
6275         nn=ncont_recv(iii)
6276         if (lprn) then
6277         write (iout,*) "Received",nn," contacts from processor",iproc,&
6278          " of CONT_FROM_COMM group"
6279         call flush(iout)
6280         do i=1,nn
6281           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6282         enddo
6283         call flush(iout)
6284         endif
6285         do i=1,nn
6286           ii=zapas_recv(1,i,iii)
6287 ! Flag the received contacts to prevent double-counting
6288           jj=-zapas_recv(2,i,iii)
6289 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6290 !          call flush(iout)
6291           nnn=num_cont_hb(ii)+1
6292           num_cont_hb(ii)=nnn
6293           jcont_hb(nnn,ii)=jj
6294           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6295           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6296           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6297           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6298           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6299           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6300           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6301           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6302           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6303           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6304           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6305           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6306           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6307           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6308           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6309           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6310           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6311           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6312           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6313           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6314           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6315           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6316           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6317           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6318         enddo
6319       enddo
6320       call flush(iout)
6321       if (lprn) then
6322         write (iout,'(a)') 'Contact function values after receive:'
6323         do i=nnt,nct-2
6324           write (iout,'(2i3,50(1x,i3,f5.2))') &
6325           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6326           j=1,num_cont_hb(i))
6327         enddo
6328         call flush(iout)
6329       endif
6330    30 continue
6331 #endif
6332       if (lprn) then
6333         write (iout,'(a)') 'Contact function values:'
6334         do i=nnt,nct-2
6335           write (iout,'(2i3,50(1x,i3,f5.2))') &
6336           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6337           j=1,num_cont_hb(i))
6338         enddo
6339       endif
6340       ecorr=0.0D0
6341
6342 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6343 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6344 ! Remove the loop below after debugging !!!
6345       do i=nnt,nct
6346         do j=1,3
6347           gradcorr(j,i)=0.0D0
6348           gradxorr(j,i)=0.0D0
6349         enddo
6350       enddo
6351 ! Calculate the local-electrostatic correlation terms
6352       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6353         i1=i+1
6354         num_conti=num_cont_hb(i)
6355         num_conti1=num_cont_hb(i+1)
6356         do jj=1,num_conti
6357           j=jcont_hb(jj,i)
6358           jp=iabs(j)
6359           do kk=1,num_conti1
6360             j1=jcont_hb(kk,i1)
6361             jp1=iabs(j1)
6362 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6363 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6364             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6365                 .or. j.lt.0 .and. j1.gt.0) .and. &
6366                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6367 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6368 ! The system gains extra energy.
6369               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6370               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6371                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6372               n_corr=n_corr+1
6373             else if (j1.eq.j) then
6374 ! Contacts I-J and I-(J+1) occur simultaneously.
6375 ! The system loses extra energy.
6376 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6377             endif
6378           enddo ! kk
6379           do kk=1,num_conti
6380             j1=jcont_hb(kk,i)
6381 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6382 !    &         ' jj=',jj,' kk=',kk
6383             if (j1.eq.j+1) then
6384 ! Contacts I-J and (I+1)-J occur simultaneously.
6385 ! The system loses extra energy.
6386 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6387             endif ! j1==j+1
6388           enddo ! kk
6389         enddo ! jj
6390       enddo ! i
6391       return
6392       end subroutine multibody_hb
6393 !-----------------------------------------------------------------------------
6394       subroutine add_hb_contact(ii,jj,itask)
6395 !      implicit real*8 (a-h,o-z)
6396 !      include "DIMENSIONS"
6397 !      include "COMMON.IOUNITS"
6398 !      include "COMMON.CONTACTS"
6399 !      integer,parameter :: maxconts=nres/4
6400       integer,parameter :: max_dim=26
6401       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6402 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6403 !      common /przechowalnia/ zapas
6404       integer :: i,j,ii,jj,iproc,nn,jjc
6405       integer,dimension(4) :: itask
6406 !      write (iout,*) "itask",itask
6407       do i=1,2
6408         iproc=itask(i)
6409         if (iproc.gt.0) then
6410           do j=1,num_cont_hb(ii)
6411             jjc=jcont_hb(j,ii)
6412 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6413             if (jjc.eq.jj) then
6414               ncont_sent(iproc)=ncont_sent(iproc)+1
6415               nn=ncont_sent(iproc)
6416               zapas(1,nn,iproc)=ii
6417               zapas(2,nn,iproc)=jjc
6418               zapas(3,nn,iproc)=facont_hb(j,ii)
6419               zapas(4,nn,iproc)=ees0p(j,ii)
6420               zapas(5,nn,iproc)=ees0m(j,ii)
6421               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6422               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6423               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6424               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6425               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6426               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6427               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6428               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6429               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6430               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6431               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6432               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6433               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6434               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6435               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6436               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6437               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6438               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6439               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6440               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6441               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6442               exit
6443             endif
6444           enddo
6445         endif
6446       enddo
6447       return
6448       end subroutine add_hb_contact
6449 !-----------------------------------------------------------------------------
6450       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6451 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6452 !      implicit real*8 (a-h,o-z)
6453 !      include 'DIMENSIONS'
6454 !      include 'COMMON.IOUNITS'
6455       integer,parameter :: max_dim=70
6456 #ifdef MPI
6457       include "mpif.h"
6458 !      integer :: maxconts !max_cont=maxconts=nres/4
6459       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6460       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6461 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6462 !      common /przechowalnia/ zapas
6463       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6464         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6465         ierr,iii,nnn
6466 #endif
6467 !      include 'COMMON.SETUP'
6468 !      include 'COMMON.FFIELD'
6469 !      include 'COMMON.DERIV'
6470 !      include 'COMMON.LOCAL'
6471 !      include 'COMMON.INTERACT'
6472 !      include 'COMMON.CONTACTS'
6473 !      include 'COMMON.CHAIN'
6474 !      include 'COMMON.CONTROL'
6475       real(kind=8),dimension(3) :: gx,gx1
6476       integer,dimension(nres) :: num_cont_hb_old
6477       logical :: lprn,ldone
6478 !EL      double precision eello4,eello5,eelo6,eello_turn6
6479 !EL      external eello4,eello5,eello6,eello_turn6
6480 !el local variables
6481       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6482               j1,jp1,i1,num_conti1
6483       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6484       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6485
6486 ! Set lprn=.true. for debugging
6487       lprn=.false.
6488       eturn6=0.0d0
6489 #ifdef MPI
6490 !      maxconts=nres/4
6491       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6492       do i=1,nres
6493         num_cont_hb_old(i)=num_cont_hb(i)
6494       enddo
6495       n_corr=0
6496       n_corr1=0
6497       if (nfgtasks.le.1) goto 30
6498       if (lprn) then
6499         write (iout,'(a)') 'Contact function values before RECEIVE:'
6500         do i=nnt,nct-2
6501           write (iout,'(2i3,50(1x,i2,f5.2))') &
6502           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6503           j=1,num_cont_hb(i))
6504         enddo
6505       endif
6506       call flush(iout)
6507       do i=1,ntask_cont_from
6508         ncont_recv(i)=0
6509       enddo
6510       do i=1,ntask_cont_to
6511         ncont_sent(i)=0
6512       enddo
6513 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6514 !     & ntask_cont_to
6515 ! Make the list of contacts to send to send to other procesors
6516       do i=iturn3_start,iturn3_end
6517 !        write (iout,*) "make contact list turn3",i," num_cont",
6518 !     &    num_cont_hb(i)
6519         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6520       enddo
6521       do i=iturn4_start,iturn4_end
6522 !        write (iout,*) "make contact list turn4",i," num_cont",
6523 !     &   num_cont_hb(i)
6524         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6525       enddo
6526       do ii=1,nat_sent
6527         i=iat_sent(ii)
6528 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6529 !     &    num_cont_hb(i)
6530         do j=1,num_cont_hb(i)
6531         do k=1,4
6532           jjc=jcont_hb(j,i)
6533           iproc=iint_sent_local(k,jjc,ii)
6534 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6535           if (iproc.ne.0) then
6536             ncont_sent(iproc)=ncont_sent(iproc)+1
6537             nn=ncont_sent(iproc)
6538             zapas(1,nn,iproc)=i
6539             zapas(2,nn,iproc)=jjc
6540             zapas(3,nn,iproc)=d_cont(j,i)
6541             ind=3
6542             do kk=1,3
6543               ind=ind+1
6544               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6545             enddo
6546             do kk=1,2
6547               do ll=1,2
6548                 ind=ind+1
6549                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6550               enddo
6551             enddo
6552             do jj=1,5
6553               do kk=1,3
6554                 do ll=1,2
6555                   do mm=1,2
6556                     ind=ind+1
6557                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6558                   enddo
6559                 enddo
6560               enddo
6561             enddo
6562           endif
6563         enddo
6564         enddo
6565       enddo
6566       if (lprn) then
6567       write (iout,*) &
6568         "Numbers of contacts to be sent to other processors",&
6569         (ncont_sent(i),i=1,ntask_cont_to)
6570       write (iout,*) "Contacts sent"
6571       do ii=1,ntask_cont_to
6572         nn=ncont_sent(ii)
6573         iproc=itask_cont_to(ii)
6574         write (iout,*) nn," contacts to processor",iproc,&
6575          " of CONT_TO_COMM group"
6576         do i=1,nn
6577           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6578         enddo
6579       enddo
6580       call flush(iout)
6581       endif
6582       CorrelType=477
6583       CorrelID=fg_rank+1
6584       CorrelType1=478
6585       CorrelID1=nfgtasks+fg_rank+1
6586       ireq=0
6587 ! Receive the numbers of needed contacts from other processors
6588       do ii=1,ntask_cont_from
6589         iproc=itask_cont_from(ii)
6590         ireq=ireq+1
6591         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6592           FG_COMM,req(ireq),IERR)
6593       enddo
6594 !      write (iout,*) "IRECV ended"
6595 !      call flush(iout)
6596 ! Send the number of contacts needed by other processors
6597       do ii=1,ntask_cont_to
6598         iproc=itask_cont_to(ii)
6599         ireq=ireq+1
6600         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6601           FG_COMM,req(ireq),IERR)
6602       enddo
6603 !      write (iout,*) "ISEND ended"
6604 !      write (iout,*) "number of requests (nn)",ireq
6605       call flush(iout)
6606       if (ireq.gt.0) &
6607         call MPI_Waitall(ireq,req,status_array,ierr)
6608 !      write (iout,*)
6609 !     &  "Numbers of contacts to be received from other processors",
6610 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6611 !      call flush(iout)
6612 ! Receive contacts
6613       ireq=0
6614       do ii=1,ntask_cont_from
6615         iproc=itask_cont_from(ii)
6616         nn=ncont_recv(ii)
6617 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6618 !     &   " of CONT_TO_COMM group"
6619         call flush(iout)
6620         if (nn.gt.0) then
6621           ireq=ireq+1
6622           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6623           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6624 !          write (iout,*) "ireq,req",ireq,req(ireq)
6625         endif
6626       enddo
6627 ! Send the contacts to processors that need them
6628       do ii=1,ntask_cont_to
6629         iproc=itask_cont_to(ii)
6630         nn=ncont_sent(ii)
6631 !        write (iout,*) nn," contacts to processor",iproc,
6632 !     &   " of CONT_TO_COMM group"
6633         if (nn.gt.0) then
6634           ireq=ireq+1
6635           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6636             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6637 !          write (iout,*) "ireq,req",ireq,req(ireq)
6638 !          do i=1,nn
6639 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6640 !          enddo
6641         endif
6642       enddo
6643 !      write (iout,*) "number of requests (contacts)",ireq
6644 !      write (iout,*) "req",(req(i),i=1,4)
6645 !      call flush(iout)
6646       if (ireq.gt.0) &
6647        call MPI_Waitall(ireq,req,status_array,ierr)
6648       do iii=1,ntask_cont_from
6649         iproc=itask_cont_from(iii)
6650         nn=ncont_recv(iii)
6651         if (lprn) then
6652         write (iout,*) "Received",nn," contacts from processor",iproc,&
6653          " of CONT_FROM_COMM group"
6654         call flush(iout)
6655         do i=1,nn
6656           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6657         enddo
6658         call flush(iout)
6659         endif
6660         do i=1,nn
6661           ii=zapas_recv(1,i,iii)
6662 ! Flag the received contacts to prevent double-counting
6663           jj=-zapas_recv(2,i,iii)
6664 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6665 !          call flush(iout)
6666           nnn=num_cont_hb(ii)+1
6667           num_cont_hb(ii)=nnn
6668           jcont_hb(nnn,ii)=jj
6669           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6670           ind=3
6671           do kk=1,3
6672             ind=ind+1
6673             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6674           enddo
6675           do kk=1,2
6676             do ll=1,2
6677               ind=ind+1
6678               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6679             enddo
6680           enddo
6681           do jj=1,5
6682             do kk=1,3
6683               do ll=1,2
6684                 do mm=1,2
6685                   ind=ind+1
6686                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6687                 enddo
6688               enddo
6689             enddo
6690           enddo
6691         enddo
6692       enddo
6693       call flush(iout)
6694       if (lprn) then
6695         write (iout,'(a)') 'Contact function values after receive:'
6696         do i=nnt,nct-2
6697           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6698           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6699           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6700         enddo
6701         call flush(iout)
6702       endif
6703    30 continue
6704 #endif
6705       if (lprn) then
6706         write (iout,'(a)') 'Contact function values:'
6707         do i=nnt,nct-2
6708           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6709           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6710           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6711         enddo
6712       endif
6713       ecorr=0.0D0
6714       ecorr5=0.0d0
6715       ecorr6=0.0d0
6716
6717 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6718 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6719 ! Remove the loop below after debugging !!!
6720       do i=nnt,nct
6721         do j=1,3
6722           gradcorr(j,i)=0.0D0
6723           gradxorr(j,i)=0.0D0
6724         enddo
6725       enddo
6726 ! Calculate the dipole-dipole interaction energies
6727       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6728       do i=iatel_s,iatel_e+1
6729         num_conti=num_cont_hb(i)
6730         do jj=1,num_conti
6731           j=jcont_hb(jj,i)
6732 #ifdef MOMENT
6733           call dipole(i,j,jj)
6734 #endif
6735         enddo
6736       enddo
6737       endif
6738 ! Calculate the local-electrostatic correlation terms
6739 !                write (iout,*) "gradcorr5 in eello5 before loop"
6740 !                do iii=1,nres
6741 !                  write (iout,'(i5,3f10.5)')
6742 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6743 !                enddo
6744       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6745 !        write (iout,*) "corr loop i",i
6746         i1=i+1
6747         num_conti=num_cont_hb(i)
6748         num_conti1=num_cont_hb(i+1)
6749         do jj=1,num_conti
6750           j=jcont_hb(jj,i)
6751           jp=iabs(j)
6752           do kk=1,num_conti1
6753             j1=jcont_hb(kk,i1)
6754             jp1=iabs(j1)
6755 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6756 !     &         ' jj=',jj,' kk=',kk
6757 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6758             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6759                 .or. j.lt.0 .and. j1.gt.0) .and. &
6760                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6761 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6762 ! The system gains extra energy.
6763               n_corr=n_corr+1
6764               sqd1=dsqrt(d_cont(jj,i))
6765               sqd2=dsqrt(d_cont(kk,i1))
6766               sred_geom = sqd1*sqd2
6767               IF (sred_geom.lt.cutoff_corr) THEN
6768                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6769                   ekont,fprimcont)
6770 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6771 !d     &         ' jj=',jj,' kk=',kk
6772                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6773                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6774                 do l=1,3
6775                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6776                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6777                 enddo
6778                 n_corr1=n_corr1+1
6779 !d               write (iout,*) 'sred_geom=',sred_geom,
6780 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6781 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6782 !d               write (iout,*) "g_contij",g_contij
6783 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6784 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6785                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6786                 if (wcorr4.gt.0.0d0) &
6787                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6788                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6789                        write (iout,'(a6,4i5,0pf7.3)') &
6790                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6791 !                write (iout,*) "gradcorr5 before eello5"
6792 !                do iii=1,nres
6793 !                  write (iout,'(i5,3f10.5)')
6794 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6795 !                enddo
6796                 if (wcorr5.gt.0.0d0) &
6797                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6798 !                write (iout,*) "gradcorr5 after eello5"
6799 !                do iii=1,nres
6800 !                  write (iout,'(i5,3f10.5)')
6801 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6802 !                enddo
6803                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6804                        write (iout,'(a6,4i5,0pf7.3)') &
6805                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6806 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6807 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6808                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6809                      .or. wturn6.eq.0.0d0))then
6810 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6811                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6812                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6813                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6814 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6815 !d     &            'ecorr6=',ecorr6
6816 !d                write (iout,'(4e15.5)') sred_geom,
6817 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6818 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6819 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6820                 else if (wturn6.gt.0.0d0 &
6821                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6822 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6823                   eturn6=eturn6+eello_turn6(i,jj,kk)
6824                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6825                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6826 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6827                 endif
6828               ENDIF
6829 1111          continue
6830             endif
6831           enddo ! kk
6832         enddo ! jj
6833       enddo ! i
6834       do i=1,nres
6835         num_cont_hb(i)=num_cont_hb_old(i)
6836       enddo
6837 !                write (iout,*) "gradcorr5 in eello5"
6838 !                do iii=1,nres
6839 !                  write (iout,'(i5,3f10.5)')
6840 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6841 !                enddo
6842       return
6843       end subroutine multibody_eello
6844 !-----------------------------------------------------------------------------
6845       subroutine add_hb_contact_eello(ii,jj,itask)
6846 !      implicit real*8 (a-h,o-z)
6847 !      include "DIMENSIONS"
6848 !      include "COMMON.IOUNITS"
6849 !      include "COMMON.CONTACTS"
6850 !      integer,parameter :: maxconts=nres/4
6851       integer,parameter :: max_dim=70
6852       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6853 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6854 !      common /przechowalnia/ zapas
6855
6856       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6857       integer,dimension(4) ::itask
6858 !      write (iout,*) "itask",itask
6859       do i=1,2
6860         iproc=itask(i)
6861         if (iproc.gt.0) then
6862           do j=1,num_cont_hb(ii)
6863             jjc=jcont_hb(j,ii)
6864 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6865             if (jjc.eq.jj) then
6866               ncont_sent(iproc)=ncont_sent(iproc)+1
6867               nn=ncont_sent(iproc)
6868               zapas(1,nn,iproc)=ii
6869               zapas(2,nn,iproc)=jjc
6870               zapas(3,nn,iproc)=d_cont(j,ii)
6871               ind=3
6872               do kk=1,3
6873                 ind=ind+1
6874                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6875               enddo
6876               do kk=1,2
6877                 do ll=1,2
6878                   ind=ind+1
6879                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6880                 enddo
6881               enddo
6882               do jj=1,5
6883                 do kk=1,3
6884                   do ll=1,2
6885                     do mm=1,2
6886                       ind=ind+1
6887                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6888                     enddo
6889                   enddo
6890                 enddo
6891               enddo
6892               exit
6893             endif
6894           enddo
6895         endif
6896       enddo
6897       return
6898       end subroutine add_hb_contact_eello
6899 !-----------------------------------------------------------------------------
6900       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6901 !      implicit real*8 (a-h,o-z)
6902 !      include 'DIMENSIONS'
6903 !      include 'COMMON.IOUNITS'
6904 !      include 'COMMON.DERIV'
6905 !      include 'COMMON.INTERACT'
6906 !      include 'COMMON.CONTACTS'
6907       real(kind=8),dimension(3) :: gx,gx1
6908       logical :: lprn
6909 !el local variables
6910       integer :: i,j,k,l,jj,kk,ll
6911       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6912                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6913                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6914
6915       lprn=.false.
6916       eij=facont_hb(jj,i)
6917       ekl=facont_hb(kk,k)
6918       ees0pij=ees0p(jj,i)
6919       ees0pkl=ees0p(kk,k)
6920       ees0mij=ees0m(jj,i)
6921       ees0mkl=ees0m(kk,k)
6922       ekont=eij*ekl
6923       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6924 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6925 ! Following 4 lines for diagnostics.
6926 !d    ees0pkl=0.0D0
6927 !d    ees0pij=1.0D0
6928 !d    ees0mkl=0.0D0
6929 !d    ees0mij=1.0D0
6930 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6931 !     & 'Contacts ',i,j,
6932 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6933 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6934 !     & 'gradcorr_long'
6935 ! Calculate the multi-body contribution to energy.
6936 !      ecorr=ecorr+ekont*ees
6937 ! Calculate multi-body contributions to the gradient.
6938       coeffpees0pij=coeffp*ees0pij
6939       coeffmees0mij=coeffm*ees0mij
6940       coeffpees0pkl=coeffp*ees0pkl
6941       coeffmees0mkl=coeffm*ees0mkl
6942       do ll=1,3
6943 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6944         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6945         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6946         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6947         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6948         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6949         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6950 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6951         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6952         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6953         coeffmees0mij*gacontm_hb1(ll,kk,k))
6954         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6955         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6956         coeffmees0mij*gacontm_hb2(ll,kk,k))
6957         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6958            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6959            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6960         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6961         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6962         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6963            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6964            coeffmees0mij*gacontm_hb3(ll,kk,k))
6965         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6966         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6967 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6968       enddo
6969 !      write (iout,*)
6970 !grad      do m=i+1,j-1
6971 !grad        do ll=1,3
6972 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6973 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6974 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6975 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6976 !grad        enddo
6977 !grad      enddo
6978 !grad      do m=k+1,l-1
6979 !grad        do ll=1,3
6980 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6981 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6982 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6983 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6984 !grad        enddo
6985 !grad      enddo
6986 !      write (iout,*) "ehbcorr",ekont*ees
6987       ehbcorr=ekont*ees
6988       return
6989       end function ehbcorr
6990 #ifdef MOMENT
6991 !-----------------------------------------------------------------------------
6992       subroutine dipole(i,j,jj)
6993 !      implicit real*8 (a-h,o-z)
6994 !      include 'DIMENSIONS'
6995 !      include 'COMMON.IOUNITS'
6996 !      include 'COMMON.CHAIN'
6997 !      include 'COMMON.FFIELD'
6998 !      include 'COMMON.DERIV'
6999 !      include 'COMMON.INTERACT'
7000 !      include 'COMMON.CONTACTS'
7001 !      include 'COMMON.TORSION'
7002 !      include 'COMMON.VAR'
7003 !      include 'COMMON.GEO'
7004       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7005       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7006       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7007
7008       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7009       allocate(dipderx(3,5,4,maxconts,nres))
7010 !
7011
7012       iti1 = itortyp(itype(i+1))
7013       if (j.lt.nres-1) then
7014         itj1 = itortyp(itype(j+1))
7015       else
7016         itj1=ntortyp+1
7017       endif
7018       do iii=1,2
7019         dipi(iii,1)=Ub2(iii,i)
7020         dipderi(iii)=Ub2der(iii,i)
7021         dipi(iii,2)=b1(iii,iti1)
7022         dipj(iii,1)=Ub2(iii,j)
7023         dipderj(iii)=Ub2der(iii,j)
7024         dipj(iii,2)=b1(iii,itj1)
7025       enddo
7026       kkk=0
7027       do iii=1,2
7028         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7029         do jjj=1,2
7030           kkk=kkk+1
7031           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7032         enddo
7033       enddo
7034       do kkk=1,5
7035         do lll=1,3
7036           mmm=0
7037           do iii=1,2
7038             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7039               auxvec(1))
7040             do jjj=1,2
7041               mmm=mmm+1
7042               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7043             enddo
7044           enddo
7045         enddo
7046       enddo
7047       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7048       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7049       do iii=1,2
7050         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7051       enddo
7052       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7053       do iii=1,2
7054         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7055       enddo
7056       return
7057       end subroutine dipole
7058 #endif
7059 !-----------------------------------------------------------------------------
7060       subroutine calc_eello(i,j,k,l,jj,kk)
7061 !
7062 ! This subroutine computes matrices and vectors needed to calculate
7063 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7064 !
7065       use comm_kut
7066 !      implicit real*8 (a-h,o-z)
7067 !      include 'DIMENSIONS'
7068 !      include 'COMMON.IOUNITS'
7069 !      include 'COMMON.CHAIN'
7070 !      include 'COMMON.DERIV'
7071 !      include 'COMMON.INTERACT'
7072 !      include 'COMMON.CONTACTS'
7073 !      include 'COMMON.TORSION'
7074 !      include 'COMMON.VAR'
7075 !      include 'COMMON.GEO'
7076 !      include 'COMMON.FFIELD'
7077       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7078       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7079       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7080               itj1
7081 !el      logical :: lprn
7082 !el      common /kutas/ lprn
7083 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7084 !d     & ' jj=',jj,' kk=',kk
7085 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7086 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7087 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7088       do iii=1,2
7089         do jjj=1,2
7090           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7091           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7092         enddo
7093       enddo
7094       call transpose2(aa1(1,1),aa1t(1,1))
7095       call transpose2(aa2(1,1),aa2t(1,1))
7096       do kkk=1,5
7097         do lll=1,3
7098           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7099             aa1tder(1,1,lll,kkk))
7100           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7101             aa2tder(1,1,lll,kkk))
7102         enddo
7103       enddo
7104       if (l.eq.j+1) then
7105 ! parallel orientation of the two CA-CA-CA frames.
7106         if (i.gt.1) then
7107           iti=itortyp(itype(i))
7108         else
7109           iti=ntortyp+1
7110         endif
7111         itk1=itortyp(itype(k+1))
7112         itj=itortyp(itype(j))
7113         if (l.lt.nres-1) then
7114           itl1=itortyp(itype(l+1))
7115         else
7116           itl1=ntortyp+1
7117         endif
7118 ! A1 kernel(j+1) A2T
7119 !d        do iii=1,2
7120 !d          write (iout,'(3f10.5,5x,3f10.5)')
7121 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7122 !d        enddo
7123         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7124          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7125          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7126 ! Following matrices are needed only for 6-th order cumulants
7127         IF (wcorr6.gt.0.0d0) THEN
7128         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7129          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7130          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7131         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7132          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7133          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7134          ADtEAderx(1,1,1,1,1,1))
7135         lprn=.false.
7136         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7137          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7138          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7139          ADtEA1derx(1,1,1,1,1,1))
7140         ENDIF
7141 ! End 6-th order cumulants
7142 !d        lprn=.false.
7143 !d        if (lprn) then
7144 !d        write (2,*) 'In calc_eello6'
7145 !d        do iii=1,2
7146 !d          write (2,*) 'iii=',iii
7147 !d          do kkk=1,5
7148 !d            write (2,*) 'kkk=',kkk
7149 !d            do jjj=1,2
7150 !d              write (2,'(3(2f10.5),5x)')
7151 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7152 !d            enddo
7153 !d          enddo
7154 !d        enddo
7155 !d        endif
7156         call transpose2(EUgder(1,1,k),auxmat(1,1))
7157         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7158         call transpose2(EUg(1,1,k),auxmat(1,1))
7159         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7160         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7161         do iii=1,2
7162           do kkk=1,5
7163             do lll=1,3
7164               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7165                 EAEAderx(1,1,lll,kkk,iii,1))
7166             enddo
7167           enddo
7168         enddo
7169 ! A1T kernel(i+1) A2
7170         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7171          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7172          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7173 ! Following matrices are needed only for 6-th order cumulants
7174         IF (wcorr6.gt.0.0d0) THEN
7175         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7176          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7177          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7178         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7179          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7180          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7181          ADtEAderx(1,1,1,1,1,2))
7182         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7183          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7184          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7185          ADtEA1derx(1,1,1,1,1,2))
7186         ENDIF
7187 ! End 6-th order cumulants
7188         call transpose2(EUgder(1,1,l),auxmat(1,1))
7189         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7190         call transpose2(EUg(1,1,l),auxmat(1,1))
7191         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7192         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7193         do iii=1,2
7194           do kkk=1,5
7195             do lll=1,3
7196               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7197                 EAEAderx(1,1,lll,kkk,iii,2))
7198             enddo
7199           enddo
7200         enddo
7201 ! AEAb1 and AEAb2
7202 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7203 ! They are needed only when the fifth- or the sixth-order cumulants are
7204 ! indluded.
7205         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7206         call transpose2(AEA(1,1,1),auxmat(1,1))
7207         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7208         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7209         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7210         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7211         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7212         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7213         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7214         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7215         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7216         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7217         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7218         call transpose2(AEA(1,1,2),auxmat(1,1))
7219         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7220         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7221         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7222         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7223         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7224         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7225         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7226         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7227         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7228         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7229         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7230 ! Calculate the Cartesian derivatives of the vectors.
7231         do iii=1,2
7232           do kkk=1,5
7233             do lll=1,3
7234               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7235               call matvec2(auxmat(1,1),b1(1,iti),&
7236                 AEAb1derx(1,lll,kkk,iii,1,1))
7237               call matvec2(auxmat(1,1),Ub2(1,i),&
7238                 AEAb2derx(1,lll,kkk,iii,1,1))
7239               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7240                 AEAb1derx(1,lll,kkk,iii,2,1))
7241               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7242                 AEAb2derx(1,lll,kkk,iii,2,1))
7243               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7244               call matvec2(auxmat(1,1),b1(1,itj),&
7245                 AEAb1derx(1,lll,kkk,iii,1,2))
7246               call matvec2(auxmat(1,1),Ub2(1,j),&
7247                 AEAb2derx(1,lll,kkk,iii,1,2))
7248               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7249                 AEAb1derx(1,lll,kkk,iii,2,2))
7250               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7251                 AEAb2derx(1,lll,kkk,iii,2,2))
7252             enddo
7253           enddo
7254         enddo
7255         ENDIF
7256 ! End vectors
7257       else
7258 ! Antiparallel orientation of the two CA-CA-CA frames.
7259         if (i.gt.1) then
7260           iti=itortyp(itype(i))
7261         else
7262           iti=ntortyp+1
7263         endif
7264         itk1=itortyp(itype(k+1))
7265         itl=itortyp(itype(l))
7266         itj=itortyp(itype(j))
7267         if (j.lt.nres-1) then
7268           itj1=itortyp(itype(j+1))
7269         else
7270           itj1=ntortyp+1
7271         endif
7272 ! A2 kernel(j-1)T A1T
7273         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7274          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7275          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7276 ! Following matrices are needed only for 6-th order cumulants
7277         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7278            j.eq.i+4 .and. l.eq.i+3)) THEN
7279         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7280          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7281          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7282         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7283          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7284          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7285          ADtEAderx(1,1,1,1,1,1))
7286         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7287          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7288          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7289          ADtEA1derx(1,1,1,1,1,1))
7290         ENDIF
7291 ! End 6-th order cumulants
7292         call transpose2(EUgder(1,1,k),auxmat(1,1))
7293         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7294         call transpose2(EUg(1,1,k),auxmat(1,1))
7295         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7296         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7297         do iii=1,2
7298           do kkk=1,5
7299             do lll=1,3
7300               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7301                 EAEAderx(1,1,lll,kkk,iii,1))
7302             enddo
7303           enddo
7304         enddo
7305 ! A2T kernel(i+1)T A1
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7307          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7308          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7309 ! Following matrices are needed only for 6-th order cumulants
7310         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7311            j.eq.i+4 .and. l.eq.i+3)) THEN
7312         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7313          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7314          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7315         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7316          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7317          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7318          ADtEAderx(1,1,1,1,1,2))
7319         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7320          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7321          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7322          ADtEA1derx(1,1,1,1,1,2))
7323         ENDIF
7324 ! End 6-th order cumulants
7325         call transpose2(EUgder(1,1,j),auxmat(1,1))
7326         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7327         call transpose2(EUg(1,1,j),auxmat(1,1))
7328         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7329         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7330         do iii=1,2
7331           do kkk=1,5
7332             do lll=1,3
7333               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7334                 EAEAderx(1,1,lll,kkk,iii,2))
7335             enddo
7336           enddo
7337         enddo
7338 ! AEAb1 and AEAb2
7339 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7340 ! They are needed only when the fifth- or the sixth-order cumulants are
7341 ! indluded.
7342         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7343           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7344         call transpose2(AEA(1,1,1),auxmat(1,1))
7345         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7346         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7347         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7348         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7349         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7350         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7351         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7352         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7353         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7354         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7355         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7356         call transpose2(AEA(1,1,2),auxmat(1,1))
7357         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7358         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7359         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7360         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7361         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7362         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7363         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7364         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7365         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7366         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7367         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7368 ! Calculate the Cartesian derivatives of the vectors.
7369         do iii=1,2
7370           do kkk=1,5
7371             do lll=1,3
7372               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7373               call matvec2(auxmat(1,1),b1(1,iti),&
7374                 AEAb1derx(1,lll,kkk,iii,1,1))
7375               call matvec2(auxmat(1,1),Ub2(1,i),&
7376                 AEAb2derx(1,lll,kkk,iii,1,1))
7377               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7378                 AEAb1derx(1,lll,kkk,iii,2,1))
7379               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7380                 AEAb2derx(1,lll,kkk,iii,2,1))
7381               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7382               call matvec2(auxmat(1,1),b1(1,itl),&
7383                 AEAb1derx(1,lll,kkk,iii,1,2))
7384               call matvec2(auxmat(1,1),Ub2(1,l),&
7385                 AEAb2derx(1,lll,kkk,iii,1,2))
7386               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7387                 AEAb1derx(1,lll,kkk,iii,2,2))
7388               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7389                 AEAb2derx(1,lll,kkk,iii,2,2))
7390             enddo
7391           enddo
7392         enddo
7393         ENDIF
7394 ! End vectors
7395       endif
7396       return
7397       end subroutine calc_eello
7398 !-----------------------------------------------------------------------------
7399       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7400       use comm_kut
7401       implicit none
7402       integer :: nderg
7403       logical :: transp
7404       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7405       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7406       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7407       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7408       integer :: iii,kkk,lll
7409       integer :: jjj,mmm
7410 !el      logical :: lprn
7411 !el      common /kutas/ lprn
7412       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7413       do iii=1,nderg
7414         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7415           AKAderg(1,1,iii))
7416       enddo
7417 !d      if (lprn) write (2,*) 'In kernel'
7418       do kkk=1,5
7419 !d        if (lprn) write (2,*) 'kkk=',kkk
7420         do lll=1,3
7421           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7422             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7423 !d          if (lprn) then
7424 !d            write (2,*) 'lll=',lll
7425 !d            write (2,*) 'iii=1'
7426 !d            do jjj=1,2
7427 !d              write (2,'(3(2f10.5),5x)')
7428 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7429 !d            enddo
7430 !d          endif
7431           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7432             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7433 !d          if (lprn) then
7434 !d            write (2,*) 'lll=',lll
7435 !d            write (2,*) 'iii=2'
7436 !d            do jjj=1,2
7437 !d              write (2,'(3(2f10.5),5x)')
7438 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7439 !d            enddo
7440 !d          endif
7441         enddo
7442       enddo
7443       return
7444       end subroutine kernel
7445 !-----------------------------------------------------------------------------
7446       real(kind=8) function eello4(i,j,k,l,jj,kk)
7447 !      implicit real*8 (a-h,o-z)
7448 !      include 'DIMENSIONS'
7449 !      include 'COMMON.IOUNITS'
7450 !      include 'COMMON.CHAIN'
7451 !      include 'COMMON.DERIV'
7452 !      include 'COMMON.INTERACT'
7453 !      include 'COMMON.CONTACTS'
7454 !      include 'COMMON.TORSION'
7455 !      include 'COMMON.VAR'
7456 !      include 'COMMON.GEO'
7457       real(kind=8),dimension(2,2) :: pizda
7458       real(kind=8),dimension(3) :: ggg1,ggg2
7459       real(kind=8) ::  eel4,glongij,glongkl
7460       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7461 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7462 !d        eello4=0.0d0
7463 !d        return
7464 !d      endif
7465 !d      print *,'eello4:',i,j,k,l,jj,kk
7466 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7467 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7468 !old      eij=facont_hb(jj,i)
7469 !old      ekl=facont_hb(kk,k)
7470 !old      ekont=eij*ekl
7471       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7472 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7473       gcorr_loc(k-1)=gcorr_loc(k-1) &
7474          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7475       if (l.eq.j+1) then
7476         gcorr_loc(l-1)=gcorr_loc(l-1) &
7477            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7478       else
7479         gcorr_loc(j-1)=gcorr_loc(j-1) &
7480            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7481       endif
7482       do iii=1,2
7483         do kkk=1,5
7484           do lll=1,3
7485             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7486                               -EAEAderx(2,2,lll,kkk,iii,1)
7487 !d            derx(lll,kkk,iii)=0.0d0
7488           enddo
7489         enddo
7490       enddo
7491 !d      gcorr_loc(l-1)=0.0d0
7492 !d      gcorr_loc(j-1)=0.0d0
7493 !d      gcorr_loc(k-1)=0.0d0
7494 !d      eel4=1.0d0
7495 !d      write (iout,*)'Contacts have occurred for peptide groups',
7496 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7497 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7498       if (j.lt.nres-1) then
7499         j1=j+1
7500         j2=j-1
7501       else
7502         j1=j-1
7503         j2=j-2
7504       endif
7505       if (l.lt.nres-1) then
7506         l1=l+1
7507         l2=l-1
7508       else
7509         l1=l-1
7510         l2=l-2
7511       endif
7512       do ll=1,3
7513 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7514 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7515         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7516         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7517 !grad        ghalf=0.5d0*ggg1(ll)
7518         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7519         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7520         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7521         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7522         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7523         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7524 !grad        ghalf=0.5d0*ggg2(ll)
7525         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7526         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7527         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7528         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7529         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7530         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7531       enddo
7532 !grad      do m=i+1,j-1
7533 !grad        do ll=1,3
7534 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7535 !grad        enddo
7536 !grad      enddo
7537 !grad      do m=k+1,l-1
7538 !grad        do ll=1,3
7539 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7540 !grad        enddo
7541 !grad      enddo
7542 !grad      do m=i+2,j2
7543 !grad        do ll=1,3
7544 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7545 !grad        enddo
7546 !grad      enddo
7547 !grad      do m=k+2,l2
7548 !grad        do ll=1,3
7549 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7550 !grad        enddo
7551 !grad      enddo
7552 !d      do iii=1,nres-3
7553 !d        write (2,*) iii,gcorr_loc(iii)
7554 !d      enddo
7555       eello4=ekont*eel4
7556 !d      write (2,*) 'ekont',ekont
7557 !d      write (iout,*) 'eello4',ekont*eel4
7558       return
7559       end function eello4
7560 !-----------------------------------------------------------------------------
7561       real(kind=8) function eello5(i,j,k,l,jj,kk)
7562 !      implicit real*8 (a-h,o-z)
7563 !      include 'DIMENSIONS'
7564 !      include 'COMMON.IOUNITS'
7565 !      include 'COMMON.CHAIN'
7566 !      include 'COMMON.DERIV'
7567 !      include 'COMMON.INTERACT'
7568 !      include 'COMMON.CONTACTS'
7569 !      include 'COMMON.TORSION'
7570 !      include 'COMMON.VAR'
7571 !      include 'COMMON.GEO'
7572       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
7573       real(kind=8),dimension(2) :: vv
7574       real(kind=8),dimension(3) :: ggg1,ggg2
7575       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7576       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7577       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7578 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7579 !                                                                              C
7580 !                            Parallel chains                                   C
7581 !                                                                              C
7582 !          o             o                   o             o                   C
7583 !         /l\           / \             \   / \           / \   /              C
7584 !        /   \         /   \             \ /   \         /   \ /               C
7585 !       j| o |l1       | o |              o| o |         | o |o                C
7586 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7587 !      \i/   \         /   \ /             /   \         /   \                 C
7588 !       o    k1             o                                                  C
7589 !         (I)          (II)                (III)          (IV)                 C
7590 !                                                                              C
7591 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7592 !                                                                              C
7593 !                            Antiparallel chains                               C
7594 !                                                                              C
7595 !          o             o                   o             o                   C
7596 !         /j\           / \             \   / \           / \   /              C
7597 !        /   \         /   \             \ /   \         /   \ /               C
7598 !      j1| o |l        | o |              o| o |         | o |o                C
7599 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7600 !      \i/   \         /   \ /             /   \         /   \                 C
7601 !       o     k1            o                                                  C
7602 !         (I)          (II)                (III)          (IV)                 C
7603 !                                                                              C
7604 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7605 !                                                                              C
7606 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7607 !                                                                              C
7608 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7609 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7610 !d        eello5=0.0d0
7611 !d        return
7612 !d      endif
7613 !d      write (iout,*)
7614 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7615 !d     &   ' and',k,l
7616       itk=itortyp(itype(k))
7617       itl=itortyp(itype(l))
7618       itj=itortyp(itype(j))
7619       eello5_1=0.0d0
7620       eello5_2=0.0d0
7621       eello5_3=0.0d0
7622       eello5_4=0.0d0
7623 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7624 !d     &   eel5_3_num,eel5_4_num)
7625       do iii=1,2
7626         do kkk=1,5
7627           do lll=1,3
7628             derx(lll,kkk,iii)=0.0d0
7629           enddo
7630         enddo
7631       enddo
7632 !d      eij=facont_hb(jj,i)
7633 !d      ekl=facont_hb(kk,k)
7634 !d      ekont=eij*ekl
7635 !d      write (iout,*)'Contacts have occurred for peptide groups',
7636 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7637 !d      goto 1111
7638 ! Contribution from the graph I.
7639 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7640 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7641       call transpose2(EUg(1,1,k),auxmat(1,1))
7642       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7643       vv(1)=pizda(1,1)-pizda(2,2)
7644       vv(2)=pizda(1,2)+pizda(2,1)
7645       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7646        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7647 ! Explicit gradient in virtual-dihedral angles.
7648       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7649        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7650        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7651       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7652       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7653       vv(1)=pizda(1,1)-pizda(2,2)
7654       vv(2)=pizda(1,2)+pizda(2,1)
7655       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7656        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7657        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7658       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7659       vv(1)=pizda(1,1)-pizda(2,2)
7660       vv(2)=pizda(1,2)+pizda(2,1)
7661       if (l.eq.j+1) then
7662         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7663          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7664          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7665       else
7666         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7667          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7668          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7669       endif
7670 ! Cartesian gradient
7671       do iii=1,2
7672         do kkk=1,5
7673           do lll=1,3
7674             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7675               pizda(1,1))
7676             vv(1)=pizda(1,1)-pizda(2,2)
7677             vv(2)=pizda(1,2)+pizda(2,1)
7678             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7679              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7680              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7681           enddo
7682         enddo
7683       enddo
7684 !      goto 1112
7685 !1111  continue
7686 ! Contribution from graph II
7687       call transpose2(EE(1,1,itk),auxmat(1,1))
7688       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7689       vv(1)=pizda(1,1)+pizda(2,2)
7690       vv(2)=pizda(2,1)-pizda(1,2)
7691       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7692        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7693 ! Explicit gradient in virtual-dihedral angles.
7694       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7695        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7696       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7697       vv(1)=pizda(1,1)+pizda(2,2)
7698       vv(2)=pizda(2,1)-pizda(1,2)
7699       if (l.eq.j+1) then
7700         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7701          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7702          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7703       else
7704         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7705          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7706          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7707       endif
7708 ! Cartesian gradient
7709       do iii=1,2
7710         do kkk=1,5
7711           do lll=1,3
7712             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7713               pizda(1,1))
7714             vv(1)=pizda(1,1)+pizda(2,2)
7715             vv(2)=pizda(2,1)-pizda(1,2)
7716             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7717              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7718              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7719           enddo
7720         enddo
7721       enddo
7722 !d      goto 1112
7723 !d1111  continue
7724       if (l.eq.j+1) then
7725 !d        goto 1110
7726 ! Parallel orientation
7727 ! Contribution from graph III
7728         call transpose2(EUg(1,1,l),auxmat(1,1))
7729         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7730         vv(1)=pizda(1,1)-pizda(2,2)
7731         vv(2)=pizda(1,2)+pizda(2,1)
7732         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7733          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7734 ! Explicit gradient in virtual-dihedral angles.
7735         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7736          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7737          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7738         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7739         vv(1)=pizda(1,1)-pizda(2,2)
7740         vv(2)=pizda(1,2)+pizda(2,1)
7741         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7742          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7743          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7744         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7745         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7746         vv(1)=pizda(1,1)-pizda(2,2)
7747         vv(2)=pizda(1,2)+pizda(2,1)
7748         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7749          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7750          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7751 ! Cartesian gradient
7752         do iii=1,2
7753           do kkk=1,5
7754             do lll=1,3
7755               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7756                 pizda(1,1))
7757               vv(1)=pizda(1,1)-pizda(2,2)
7758               vv(2)=pizda(1,2)+pizda(2,1)
7759               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7760                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7761                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7762             enddo
7763           enddo
7764         enddo
7765 !d        goto 1112
7766 ! Contribution from graph IV
7767 !d1110    continue
7768         call transpose2(EE(1,1,itl),auxmat(1,1))
7769         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7770         vv(1)=pizda(1,1)+pizda(2,2)
7771         vv(2)=pizda(2,1)-pizda(1,2)
7772         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7773          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7774 ! Explicit gradient in virtual-dihedral angles.
7775         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7776          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7777         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7778         vv(1)=pizda(1,1)+pizda(2,2)
7779         vv(2)=pizda(2,1)-pizda(1,2)
7780         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7781          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7782          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7783 ! Cartesian gradient
7784         do iii=1,2
7785           do kkk=1,5
7786             do lll=1,3
7787               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7788                 pizda(1,1))
7789               vv(1)=pizda(1,1)+pizda(2,2)
7790               vv(2)=pizda(2,1)-pizda(1,2)
7791               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7792                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7793                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7794             enddo
7795           enddo
7796         enddo
7797       else
7798 ! Antiparallel orientation
7799 ! Contribution from graph III
7800 !        goto 1110
7801         call transpose2(EUg(1,1,j),auxmat(1,1))
7802         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7803         vv(1)=pizda(1,1)-pizda(2,2)
7804         vv(2)=pizda(1,2)+pizda(2,1)
7805         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7806          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7807 ! Explicit gradient in virtual-dihedral angles.
7808         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7809          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7810          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7811         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7812         vv(1)=pizda(1,1)-pizda(2,2)
7813         vv(2)=pizda(1,2)+pizda(2,1)
7814         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7815          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7816          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7817         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7818         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7819         vv(1)=pizda(1,1)-pizda(2,2)
7820         vv(2)=pizda(1,2)+pizda(2,1)
7821         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7822          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7823          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7824 ! Cartesian gradient
7825         do iii=1,2
7826           do kkk=1,5
7827             do lll=1,3
7828               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7829                 pizda(1,1))
7830               vv(1)=pizda(1,1)-pizda(2,2)
7831               vv(2)=pizda(1,2)+pizda(2,1)
7832               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7833                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7834                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7835             enddo
7836           enddo
7837         enddo
7838 !d        goto 1112
7839 ! Contribution from graph IV
7840 1110    continue
7841         call transpose2(EE(1,1,itj),auxmat(1,1))
7842         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7843         vv(1)=pizda(1,1)+pizda(2,2)
7844         vv(2)=pizda(2,1)-pizda(1,2)
7845         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7846          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7847 ! Explicit gradient in virtual-dihedral angles.
7848         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7849          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7850         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7851         vv(1)=pizda(1,1)+pizda(2,2)
7852         vv(2)=pizda(2,1)-pizda(1,2)
7853         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7854          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7855          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7856 ! Cartesian gradient
7857         do iii=1,2
7858           do kkk=1,5
7859             do lll=1,3
7860               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7861                 pizda(1,1))
7862               vv(1)=pizda(1,1)+pizda(2,2)
7863               vv(2)=pizda(2,1)-pizda(1,2)
7864               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7865                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7866                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7867             enddo
7868           enddo
7869         enddo
7870       endif
7871 1112  continue
7872       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7873 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7874 !d        write (2,*) 'ijkl',i,j,k,l
7875 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7876 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7877 !d      endif
7878 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7879 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7880 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7881 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7882       if (j.lt.nres-1) then
7883         j1=j+1
7884         j2=j-1
7885       else
7886         j1=j-1
7887         j2=j-2
7888       endif
7889       if (l.lt.nres-1) then
7890         l1=l+1
7891         l2=l-1
7892       else
7893         l1=l-1
7894         l2=l-2
7895       endif
7896 !d      eij=1.0d0
7897 !d      ekl=1.0d0
7898 !d      ekont=1.0d0
7899 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7900 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7901 !        summed up outside the subrouine as for the other subroutines
7902 !        handling long-range interactions. The old code is commented out
7903 !        with "cgrad" to keep track of changes.
7904       do ll=1,3
7905 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7906 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7907         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7908         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7909 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7910 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7911 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7912 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7913 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7914 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7915 !     &   gradcorr5ij,
7916 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7917 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7918 !grad        ghalf=0.5d0*ggg1(ll)
7919 !d        ghalf=0.0d0
7920         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7921         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7922         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7923         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7924         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7925         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7926 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7927 !grad        ghalf=0.5d0*ggg2(ll)
7928         ghalf=0.0d0
7929         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7930         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7931         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7932         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7933         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7934         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7935       enddo
7936 !d      goto 1112
7937 !grad      do m=i+1,j-1
7938 !grad        do ll=1,3
7939 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7940 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7941 !grad        enddo
7942 !grad      enddo
7943 !grad      do m=k+1,l-1
7944 !grad        do ll=1,3
7945 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7946 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7947 !grad        enddo
7948 !grad      enddo
7949 !1112  continue
7950 !grad      do m=i+2,j2
7951 !grad        do ll=1,3
7952 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7953 !grad        enddo
7954 !grad      enddo
7955 !grad      do m=k+2,l2
7956 !grad        do ll=1,3
7957 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7958 !grad        enddo
7959 !grad      enddo
7960 !d      do iii=1,nres-3
7961 !d        write (2,*) iii,g_corr5_loc(iii)
7962 !d      enddo
7963       eello5=ekont*eel5
7964 !d      write (2,*) 'ekont',ekont
7965 !d      write (iout,*) 'eello5',ekont*eel5
7966       return
7967       end function eello5
7968 !-----------------------------------------------------------------------------
7969       real(kind=8) function eello6(i,j,k,l,jj,kk)
7970 !      implicit real*8 (a-h,o-z)
7971 !      include 'DIMENSIONS'
7972 !      include 'COMMON.IOUNITS'
7973 !      include 'COMMON.CHAIN'
7974 !      include 'COMMON.DERIV'
7975 !      include 'COMMON.INTERACT'
7976 !      include 'COMMON.CONTACTS'
7977 !      include 'COMMON.TORSION'
7978 !      include 'COMMON.VAR'
7979 !      include 'COMMON.GEO'
7980 !      include 'COMMON.FFIELD'
7981       real(kind=8),dimension(3) :: ggg1,ggg2
7982       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7983                    eello6_6,eel6
7984       real(kind=8) :: gradcorr6ij,gradcorr6kl
7985       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7986 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7987 !d        eello6=0.0d0
7988 !d        return
7989 !d      endif
7990 !d      write (iout,*)
7991 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7992 !d     &   ' and',k,l
7993       eello6_1=0.0d0
7994       eello6_2=0.0d0
7995       eello6_3=0.0d0
7996       eello6_4=0.0d0
7997       eello6_5=0.0d0
7998       eello6_6=0.0d0
7999 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8000 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8001       do iii=1,2
8002         do kkk=1,5
8003           do lll=1,3
8004             derx(lll,kkk,iii)=0.0d0
8005           enddo
8006         enddo
8007       enddo
8008 !d      eij=facont_hb(jj,i)
8009 !d      ekl=facont_hb(kk,k)
8010 !d      ekont=eij*ekl
8011 !d      eij=1.0d0
8012 !d      ekl=1.0d0
8013 !d      ekont=1.0d0
8014       if (l.eq.j+1) then
8015         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8016         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8017         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8018         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8019         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8020         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8021       else
8022         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8023         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8024         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8025         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8026         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8027           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8028         else
8029           eello6_5=0.0d0
8030         endif
8031         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8032       endif
8033 ! If turn contributions are considered, they will be handled separately.
8034       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8035 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8036 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8037 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8038 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8039 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8040 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8041 !d      goto 1112
8042       if (j.lt.nres-1) then
8043         j1=j+1
8044         j2=j-1
8045       else
8046         j1=j-1
8047         j2=j-2
8048       endif
8049       if (l.lt.nres-1) then
8050         l1=l+1
8051         l2=l-1
8052       else
8053         l1=l-1
8054         l2=l-2
8055       endif
8056       do ll=1,3
8057 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8058 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8059 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8060 !grad        ghalf=0.5d0*ggg1(ll)
8061 !d        ghalf=0.0d0
8062         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8063         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8064         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8065         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8066         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8067         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8068         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8069         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8070 !grad        ghalf=0.5d0*ggg2(ll)
8071 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8072 !d        ghalf=0.0d0
8073         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8074         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8075         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8076         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8077         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8078         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8079       enddo
8080 !d      goto 1112
8081 !grad      do m=i+1,j-1
8082 !grad        do ll=1,3
8083 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8084 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8085 !grad        enddo
8086 !grad      enddo
8087 !grad      do m=k+1,l-1
8088 !grad        do ll=1,3
8089 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8090 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8091 !grad        enddo
8092 !grad      enddo
8093 !grad1112  continue
8094 !grad      do m=i+2,j2
8095 !grad        do ll=1,3
8096 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8097 !grad        enddo
8098 !grad      enddo
8099 !grad      do m=k+2,l2
8100 !grad        do ll=1,3
8101 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8102 !grad        enddo
8103 !grad      enddo
8104 !d      do iii=1,nres-3
8105 !d        write (2,*) iii,g_corr6_loc(iii)
8106 !d      enddo
8107       eello6=ekont*eel6
8108 !d      write (2,*) 'ekont',ekont
8109 !d      write (iout,*) 'eello6',ekont*eel6
8110       return
8111       end function eello6
8112 !-----------------------------------------------------------------------------
8113       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8114       use comm_kut
8115 !      implicit real*8 (a-h,o-z)
8116 !      include 'DIMENSIONS'
8117 !      include 'COMMON.IOUNITS'
8118 !      include 'COMMON.CHAIN'
8119 !      include 'COMMON.DERIV'
8120 !      include 'COMMON.INTERACT'
8121 !      include 'COMMON.CONTACTS'
8122 !      include 'COMMON.TORSION'
8123 !      include 'COMMON.VAR'
8124 !      include 'COMMON.GEO'
8125       real(kind=8),dimension(2) :: vv,vv1
8126       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8127       logical :: swap
8128 !el      logical :: lprn
8129 !el      common /kutas/ lprn
8130       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8131       real(kind=8) :: s1,s2,s3,s4,s5
8132 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8133 !                                                                              C
8134 !      Parallel       Antiparallel                                             C
8135 !                                                                              C
8136 !          o             o                                                     C
8137 !         /l\           /j\                                                    C
8138 !        /   \         /   \                                                   C
8139 !       /| o |         | o |\                                                  C
8140 !     \ j|/k\|  /   \  |/k\|l /                                                C
8141 !      \ /   \ /     \ /   \ /                                                 C
8142 !       o     o       o     o                                                  C
8143 !       i             i                                                        C
8144 !                                                                              C
8145 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8146       itk=itortyp(itype(k))
8147       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8148       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8149       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8150       call transpose2(EUgC(1,1,k),auxmat(1,1))
8151       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8152       vv1(1)=pizda1(1,1)-pizda1(2,2)
8153       vv1(2)=pizda1(1,2)+pizda1(2,1)
8154       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8155       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8156       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8157       s5=scalar2(vv(1),Dtobr2(1,i))
8158 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8159       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8160       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8161        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8162        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8163        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8164        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8165        +scalar2(vv(1),Dtobr2der(1,i)))
8166       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8167       vv1(1)=pizda1(1,1)-pizda1(2,2)
8168       vv1(2)=pizda1(1,2)+pizda1(2,1)
8169       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8170       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8171       if (l.eq.j+1) then
8172         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8173        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8174        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8175        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8176        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8177       else
8178         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8179        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8180        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8181        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8182        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8183       endif
8184       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8185       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8186       vv1(1)=pizda1(1,1)-pizda1(2,2)
8187       vv1(2)=pizda1(1,2)+pizda1(2,1)
8188       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8189        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8190        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8191        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8192       do iii=1,2
8193         if (swap) then
8194           ind=3-iii
8195         else
8196           ind=iii
8197         endif
8198         do kkk=1,5
8199           do lll=1,3
8200             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8201             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8202             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8203             call transpose2(EUgC(1,1,k),auxmat(1,1))
8204             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8205               pizda1(1,1))
8206             vv1(1)=pizda1(1,1)-pizda1(2,2)
8207             vv1(2)=pizda1(1,2)+pizda1(2,1)
8208             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8209             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8210              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8211             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8212              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8213             s5=scalar2(vv(1),Dtobr2(1,i))
8214             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8215           enddo
8216         enddo
8217       enddo
8218       return
8219       end function eello6_graph1
8220 !-----------------------------------------------------------------------------
8221       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8222       use comm_kut
8223 !      implicit real*8 (a-h,o-z)
8224 !      include 'DIMENSIONS'
8225 !      include 'COMMON.IOUNITS'
8226 !      include 'COMMON.CHAIN'
8227 !      include 'COMMON.DERIV'
8228 !      include 'COMMON.INTERACT'
8229 !      include 'COMMON.CONTACTS'
8230 !      include 'COMMON.TORSION'
8231 !      include 'COMMON.VAR'
8232 !      include 'COMMON.GEO'
8233       logical :: swap
8234       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8235       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8236 !el      logical :: lprn
8237 !el      common /kutas/ lprn
8238       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8239       real(kind=8) :: s2,s3,s4
8240 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8241 !                                                                              C
8242 !      Parallel       Antiparallel                                             C
8243 !                                                                              C
8244 !          o             o                                                     C
8245 !     \   /l\           /j\   /                                                C
8246 !      \ /   \         /   \ /                                                 C
8247 !       o| o |         | o |o                                                  C
8248 !     \ j|/k\|      \  |/k\|l                                                  C
8249 !      \ /   \       \ /   \                                                   C
8250 !       o             o                                                        C
8251 !       i             i                                                        C
8252 !                                                                              C
8253 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8254 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8255 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8256 !           but not in a cluster cumulant
8257 #ifdef MOMENT
8258       s1=dip(1,jj,i)*dip(1,kk,k)
8259 #endif
8260       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8261       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8262       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8263       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8264       call transpose2(EUg(1,1,k),auxmat(1,1))
8265       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8266       vv(1)=pizda(1,1)-pizda(2,2)
8267       vv(2)=pizda(1,2)+pizda(2,1)
8268       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8269 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8270 #ifdef MOMENT
8271       eello6_graph2=-(s1+s2+s3+s4)
8272 #else
8273       eello6_graph2=-(s2+s3+s4)
8274 #endif
8275 !      eello6_graph2=-s3
8276 ! Derivatives in gamma(i-1)
8277       if (i.gt.1) then
8278 #ifdef MOMENT
8279         s1=dipderg(1,jj,i)*dip(1,kk,k)
8280 #endif
8281         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8282         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8283         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8284         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8285 #ifdef MOMENT
8286         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8287 #else
8288         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8289 #endif
8290 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8291       endif
8292 ! Derivatives in gamma(k-1)
8293 #ifdef MOMENT
8294       s1=dip(1,jj,i)*dipderg(1,kk,k)
8295 #endif
8296       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8297       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8298       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8299       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8300       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8301       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8302       vv(1)=pizda(1,1)-pizda(2,2)
8303       vv(2)=pizda(1,2)+pizda(2,1)
8304       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8305 #ifdef MOMENT
8306       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8307 #else
8308       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8309 #endif
8310 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8311 ! Derivatives in gamma(j-1) or gamma(l-1)
8312       if (j.gt.1) then
8313 #ifdef MOMENT
8314         s1=dipderg(3,jj,i)*dip(1,kk,k)
8315 #endif
8316         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8317         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8318         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8319         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8320         vv(1)=pizda(1,1)-pizda(2,2)
8321         vv(2)=pizda(1,2)+pizda(2,1)
8322         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8323 #ifdef MOMENT
8324         if (swap) then
8325           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8326         else
8327           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8328         endif
8329 #endif
8330         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8331 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8332       endif
8333 ! Derivatives in gamma(l-1) or gamma(j-1)
8334       if (l.gt.1) then
8335 #ifdef MOMENT
8336         s1=dip(1,jj,i)*dipderg(3,kk,k)
8337 #endif
8338         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8339         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8340         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8341         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8342         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8343         vv(1)=pizda(1,1)-pizda(2,2)
8344         vv(2)=pizda(1,2)+pizda(2,1)
8345         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8346 #ifdef MOMENT
8347         if (swap) then
8348           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8349         else
8350           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8351         endif
8352 #endif
8353         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8354 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8355       endif
8356 ! Cartesian derivatives.
8357       if (lprn) then
8358         write (2,*) 'In eello6_graph2'
8359         do iii=1,2
8360           write (2,*) 'iii=',iii
8361           do kkk=1,5
8362             write (2,*) 'kkk=',kkk
8363             do jjj=1,2
8364               write (2,'(3(2f10.5),5x)') &
8365               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8366             enddo
8367           enddo
8368         enddo
8369       endif
8370       do iii=1,2
8371         do kkk=1,5
8372           do lll=1,3
8373 #ifdef MOMENT
8374             if (iii.eq.1) then
8375               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8376             else
8377               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8378             endif
8379 #endif
8380             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8381               auxvec(1))
8382             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8383             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8384               auxvec(1))
8385             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8386             call transpose2(EUg(1,1,k),auxmat(1,1))
8387             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8388               pizda(1,1))
8389             vv(1)=pizda(1,1)-pizda(2,2)
8390             vv(2)=pizda(1,2)+pizda(2,1)
8391             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8392 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8393 #ifdef MOMENT
8394             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8395 #else
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8397 #endif
8398             if (swap) then
8399               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8400             else
8401               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8402             endif
8403           enddo
8404         enddo
8405       enddo
8406       return
8407       end function eello6_graph2
8408 !-----------------------------------------------------------------------------
8409       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8410 !      implicit real*8 (a-h,o-z)
8411 !      include 'DIMENSIONS'
8412 !      include 'COMMON.IOUNITS'
8413 !      include 'COMMON.CHAIN'
8414 !      include 'COMMON.DERIV'
8415 !      include 'COMMON.INTERACT'
8416 !      include 'COMMON.CONTACTS'
8417 !      include 'COMMON.TORSION'
8418 !      include 'COMMON.VAR'
8419 !      include 'COMMON.GEO'
8420       real(kind=8),dimension(2) :: vv,auxvec
8421       real(kind=8),dimension(2,2) :: pizda,auxmat
8422       logical :: swap
8423       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8424       real(kind=8) :: s1,s2,s3,s4
8425 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8426 !                                                                              C
8427 !      Parallel       Antiparallel                                             C
8428 !                                                                              C
8429 !          o             o                                                     C
8430 !         /l\   /   \   /j\                                                    C
8431 !        /   \ /     \ /   \                                                   C
8432 !       /| o |o       o| o |\                                                  C
8433 !       j|/k\|  /      |/k\|l /                                                C
8434 !        /   \ /       /   \ /                                                 C
8435 !       /     o       /     o                                                  C
8436 !       i             i                                                        C
8437 !                                                                              C
8438 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8439 !
8440 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8441 !           energy moment and not to the cluster cumulant.
8442       iti=itortyp(itype(i))
8443       if (j.lt.nres-1) then
8444         itj1=itortyp(itype(j+1))
8445       else
8446         itj1=ntortyp+1
8447       endif
8448       itk=itortyp(itype(k))
8449       itk1=itortyp(itype(k+1))
8450       if (l.lt.nres-1) then
8451         itl1=itortyp(itype(l+1))
8452       else
8453         itl1=ntortyp+1
8454       endif
8455 #ifdef MOMENT
8456       s1=dip(4,jj,i)*dip(4,kk,k)
8457 #endif
8458       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8459       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8460       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8461       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8462       call transpose2(EE(1,1,itk),auxmat(1,1))
8463       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8464       vv(1)=pizda(1,1)+pizda(2,2)
8465       vv(2)=pizda(2,1)-pizda(1,2)
8466       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8467 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8468 !d     & "sum",-(s2+s3+s4)
8469 #ifdef MOMENT
8470       eello6_graph3=-(s1+s2+s3+s4)
8471 #else
8472       eello6_graph3=-(s2+s3+s4)
8473 #endif
8474 !      eello6_graph3=-s4
8475 ! Derivatives in gamma(k-1)
8476       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8477       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8478       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8479       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8480 ! Derivatives in gamma(l-1)
8481       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8482       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8483       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8484       vv(1)=pizda(1,1)+pizda(2,2)
8485       vv(2)=pizda(2,1)-pizda(1,2)
8486       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8487       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8488 ! Cartesian derivatives.
8489       do iii=1,2
8490         do kkk=1,5
8491           do lll=1,3
8492 #ifdef MOMENT
8493             if (iii.eq.1) then
8494               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8495             else
8496               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8497             endif
8498 #endif
8499             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8500               auxvec(1))
8501             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8502             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8503               auxvec(1))
8504             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8505             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8506               pizda(1,1))
8507             vv(1)=pizda(1,1)+pizda(2,2)
8508             vv(2)=pizda(2,1)-pizda(1,2)
8509             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8510 #ifdef MOMENT
8511             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8512 #else
8513             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8514 #endif
8515             if (swap) then
8516               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8517             else
8518               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8519             endif
8520 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8521           enddo
8522         enddo
8523       enddo
8524       return
8525       end function eello6_graph3
8526 !-----------------------------------------------------------------------------
8527       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8528 !      implicit real*8 (a-h,o-z)
8529 !      include 'DIMENSIONS'
8530 !      include 'COMMON.IOUNITS'
8531 !      include 'COMMON.CHAIN'
8532 !      include 'COMMON.DERIV'
8533 !      include 'COMMON.INTERACT'
8534 !      include 'COMMON.CONTACTS'
8535 !      include 'COMMON.TORSION'
8536 !      include 'COMMON.VAR'
8537 !      include 'COMMON.GEO'
8538 !      include 'COMMON.FFIELD'
8539       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8540       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8541       logical :: swap
8542       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8543               iii,kkk,lll
8544       real(kind=8) :: s1,s2,s3,s4
8545 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8546 !                                                                              C
8547 !      Parallel       Antiparallel                                             C
8548 !                                                                              C
8549 !          o             o                                                     C
8550 !         /l\   /   \   /j\                                                    C
8551 !        /   \ /     \ /   \                                                   C
8552 !       /| o |o       o| o |\                                                  C
8553 !     \ j|/k\|      \  |/k\|l                                                  C
8554 !      \ /   \       \ /   \                                                   C
8555 !       o     \       o     \                                                  C
8556 !       i             i                                                        C
8557 !                                                                              C
8558 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8559 !
8560 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8561 !           energy moment and not to the cluster cumulant.
8562 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8563       iti=itortyp(itype(i))
8564       itj=itortyp(itype(j))
8565       if (j.lt.nres-1) then
8566         itj1=itortyp(itype(j+1))
8567       else
8568         itj1=ntortyp+1
8569       endif
8570       itk=itortyp(itype(k))
8571       if (k.lt.nres-1) then
8572         itk1=itortyp(itype(k+1))
8573       else
8574         itk1=ntortyp+1
8575       endif
8576       itl=itortyp(itype(l))
8577       if (l.lt.nres-1) then
8578         itl1=itortyp(itype(l+1))
8579       else
8580         itl1=ntortyp+1
8581       endif
8582 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8583 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8584 !d     & ' itl',itl,' itl1',itl1
8585 #ifdef MOMENT
8586       if (imat.eq.1) then
8587         s1=dip(3,jj,i)*dip(3,kk,k)
8588       else
8589         s1=dip(2,jj,j)*dip(2,kk,l)
8590       endif
8591 #endif
8592       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8593       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8594       if (j.eq.l+1) then
8595         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8596         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8597       else
8598         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8599         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8600       endif
8601       call transpose2(EUg(1,1,k),auxmat(1,1))
8602       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8603       vv(1)=pizda(1,1)-pizda(2,2)
8604       vv(2)=pizda(2,1)+pizda(1,2)
8605       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8606 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8607 #ifdef MOMENT
8608       eello6_graph4=-(s1+s2+s3+s4)
8609 #else
8610       eello6_graph4=-(s2+s3+s4)
8611 #endif
8612 ! Derivatives in gamma(i-1)
8613       if (i.gt.1) then
8614 #ifdef MOMENT
8615         if (imat.eq.1) then
8616           s1=dipderg(2,jj,i)*dip(3,kk,k)
8617         else
8618           s1=dipderg(4,jj,j)*dip(2,kk,l)
8619         endif
8620 #endif
8621         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8622         if (j.eq.l+1) then
8623           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8624           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8625         else
8626           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8627           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8628         endif
8629         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8630         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8631 !d          write (2,*) 'turn6 derivatives'
8632 #ifdef MOMENT
8633           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8634 #else
8635           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8636 #endif
8637         else
8638 #ifdef MOMENT
8639           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8640 #else
8641           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8642 #endif
8643         endif
8644       endif
8645 ! Derivatives in gamma(k-1)
8646 #ifdef MOMENT
8647       if (imat.eq.1) then
8648         s1=dip(3,jj,i)*dipderg(2,kk,k)
8649       else
8650         s1=dip(2,jj,j)*dipderg(4,kk,l)
8651       endif
8652 #endif
8653       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8654       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8655       if (j.eq.l+1) then
8656         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8657         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8658       else
8659         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8660         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8661       endif
8662       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8663       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8664       vv(1)=pizda(1,1)-pizda(2,2)
8665       vv(2)=pizda(2,1)+pizda(1,2)
8666       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8667       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8668 #ifdef MOMENT
8669         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8670 #else
8671         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8672 #endif
8673       else
8674 #ifdef MOMENT
8675         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8676 #else
8677         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8678 #endif
8679       endif
8680 ! Derivatives in gamma(j-1) or gamma(l-1)
8681       if (l.eq.j+1 .and. l.gt.1) then
8682         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8683         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8684         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8685         vv(1)=pizda(1,1)-pizda(2,2)
8686         vv(2)=pizda(2,1)+pizda(1,2)
8687         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8688         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8689       else if (j.gt.1) then
8690         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8691         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8692         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8693         vv(1)=pizda(1,1)-pizda(2,2)
8694         vv(2)=pizda(2,1)+pizda(1,2)
8695         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8697           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8698         else
8699           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8700         endif
8701       endif
8702 ! Cartesian derivatives.
8703       do iii=1,2
8704         do kkk=1,5
8705           do lll=1,3
8706 #ifdef MOMENT
8707             if (iii.eq.1) then
8708               if (imat.eq.1) then
8709                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8710               else
8711                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8712               endif
8713             else
8714               if (imat.eq.1) then
8715                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8716               else
8717                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8718               endif
8719             endif
8720 #endif
8721             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8722               auxvec(1))
8723             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8724             if (j.eq.l+1) then
8725               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8726                 b1(1,itj1),auxvec(1))
8727               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8728             else
8729               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8730                 b1(1,itl1),auxvec(1))
8731               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8732             endif
8733             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8734               pizda(1,1))
8735             vv(1)=pizda(1,1)-pizda(2,2)
8736             vv(2)=pizda(2,1)+pizda(1,2)
8737             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8738             if (swap) then
8739               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8740 #ifdef MOMENT
8741                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8742                    -(s1+s2+s4)
8743 #else
8744                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8745                    -(s2+s4)
8746 #endif
8747                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8748               else
8749 #ifdef MOMENT
8750                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8751 #else
8752                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8753 #endif
8754                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8755               endif
8756             else
8757 #ifdef MOMENT
8758               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8759 #else
8760               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8761 #endif
8762               if (l.eq.j+1) then
8763                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8764               else
8765                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8766               endif
8767             endif
8768           enddo
8769         enddo
8770       enddo
8771       return
8772       end function eello6_graph4
8773 !-----------------------------------------------------------------------------
8774       real(kind=8) function eello_turn6(i,jj,kk)
8775 !      implicit real*8 (a-h,o-z)
8776 !      include 'DIMENSIONS'
8777 !      include 'COMMON.IOUNITS'
8778 !      include 'COMMON.CHAIN'
8779 !      include 'COMMON.DERIV'
8780 !      include 'COMMON.INTERACT'
8781 !      include 'COMMON.CONTACTS'
8782 !      include 'COMMON.TORSION'
8783 !      include 'COMMON.VAR'
8784 !      include 'COMMON.GEO'
8785       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8786       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8787       real(kind=8),dimension(3) :: ggg1,ggg2
8788       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8789       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8790 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8791 !           the respective energy moment and not to the cluster cumulant.
8792 !el local variables
8793       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8794       integer :: j1,j2,l1,l2,ll
8795       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8796       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8797       s1=0.0d0
8798       s8=0.0d0
8799       s13=0.0d0
8800 !
8801       eello_turn6=0.0d0
8802       j=i+4
8803       k=i+1
8804       l=i+3
8805       iti=itortyp(itype(i))
8806       itk=itortyp(itype(k))
8807       itk1=itortyp(itype(k+1))
8808       itl=itortyp(itype(l))
8809       itj=itortyp(itype(j))
8810 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8811 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8812 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8813 !d        eello6=0.0d0
8814 !d        return
8815 !d      endif
8816 !d      write (iout,*)
8817 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8818 !d     &   ' and',k,l
8819 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8820       do iii=1,2
8821         do kkk=1,5
8822           do lll=1,3
8823             derx_turn(lll,kkk,iii)=0.0d0
8824           enddo
8825         enddo
8826       enddo
8827 !d      eij=1.0d0
8828 !d      ekl=1.0d0
8829 !d      ekont=1.0d0
8830       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8831 !d      eello6_5=0.0d0
8832 !d      write (2,*) 'eello6_5',eello6_5
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,1),auxmat(1,1))
8835       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8836       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8837       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8838 #endif
8839       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8840       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8841       s2 = scalar2(b1(1,itk),vtemp1(1))
8842 #ifdef MOMENT
8843       call transpose2(AEA(1,1,2),atemp(1,1))
8844       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8845       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8846       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8847 #endif
8848       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8849       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8850       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8851 #ifdef MOMENT
8852       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8853       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8854       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8855       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8856       ss13 = scalar2(b1(1,itk),vtemp4(1))
8857       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8858 #endif
8859 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8860 !      s1=0.0d0
8861 !      s2=0.0d0
8862 !      s8=0.0d0
8863 !      s12=0.0d0
8864 !      s13=0.0d0
8865       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8866 ! Derivatives in gamma(i+2)
8867       s1d =0.0d0
8868       s8d =0.0d0
8869 #ifdef MOMENT
8870       call transpose2(AEA(1,1,1),auxmatd(1,1))
8871       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8872       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8873       call transpose2(AEAderg(1,1,2),atempd(1,1))
8874       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8875       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8876 #endif
8877       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8878       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8879       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8880 !      s1d=0.0d0
8881 !      s2d=0.0d0
8882 !      s8d=0.0d0
8883 !      s12d=0.0d0
8884 !      s13d=0.0d0
8885       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8886 ! Derivatives in gamma(i+3)
8887 #ifdef MOMENT
8888       call transpose2(AEA(1,1,1),auxmatd(1,1))
8889       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8890       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8891       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8892 #endif
8893       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8894       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8895       s2d = scalar2(b1(1,itk),vtemp1d(1))
8896 #ifdef MOMENT
8897       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8898       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8899 #endif
8900       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8901 #ifdef MOMENT
8902       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8903       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8904       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8905 #endif
8906 !      s1d=0.0d0
8907 !      s2d=0.0d0
8908 !      s8d=0.0d0
8909 !      s12d=0.0d0
8910 !      s13d=0.0d0
8911 #ifdef MOMENT
8912       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8913                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8914 #else
8915       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8916                     -0.5d0*ekont*(s2d+s12d)
8917 #endif
8918 ! Derivatives in gamma(i+4)
8919       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8920       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8921       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8922 #ifdef MOMENT
8923       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8924       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8925       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8926 #endif
8927 !      s1d=0.0d0
8928 !      s2d=0.0d0
8929 !      s8d=0.0d0
8930 !      s12d=0.0d0
8931 !      s13d=0.0d0
8932 #ifdef MOMENT
8933       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8934 #else
8935       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8936 #endif
8937 ! Derivatives in gamma(i+5)
8938 #ifdef MOMENT
8939       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8940       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8941       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8942 #endif
8943       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8944       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8945       s2d = scalar2(b1(1,itk),vtemp1d(1))
8946 #ifdef MOMENT
8947       call transpose2(AEA(1,1,2),atempd(1,1))
8948       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8949       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8950 #endif
8951       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8952       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8953 #ifdef MOMENT
8954       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8955       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8956       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8957 #endif
8958 !      s1d=0.0d0
8959 !      s2d=0.0d0
8960 !      s8d=0.0d0
8961 !      s12d=0.0d0
8962 !      s13d=0.0d0
8963 #ifdef MOMENT
8964       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8965                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8966 #else
8967       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8968                     -0.5d0*ekont*(s2d+s12d)
8969 #endif
8970 ! Cartesian derivatives
8971       do iii=1,2
8972         do kkk=1,5
8973           do lll=1,3
8974 #ifdef MOMENT
8975             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8976             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8977             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8978 #endif
8979             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8980             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8981                 vtemp1d(1))
8982             s2d = scalar2(b1(1,itk),vtemp1d(1))
8983 #ifdef MOMENT
8984             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8985             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8986             s8d = -(atempd(1,1)+atempd(2,2))* &
8987                  scalar2(cc(1,1,itl),vtemp2(1))
8988 #endif
8989             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8990                  auxmatd(1,1))
8991             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8992             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8993 !      s1d=0.0d0
8994 !      s2d=0.0d0
8995 !      s8d=0.0d0
8996 !      s12d=0.0d0
8997 !      s13d=0.0d0
8998 #ifdef MOMENT
8999             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9000               - 0.5d0*(s1d+s2d)
9001 #else
9002             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9003               - 0.5d0*s2d
9004 #endif
9005 #ifdef MOMENT
9006             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9007               - 0.5d0*(s8d+s12d)
9008 #else
9009             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9010               - 0.5d0*s12d
9011 #endif
9012           enddo
9013         enddo
9014       enddo
9015 #ifdef MOMENT
9016       do kkk=1,5
9017         do lll=1,3
9018           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9019             achuj_tempd(1,1))
9020           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9021           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9022           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9023           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9024           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9025             vtemp4d(1))
9026           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9027           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9028           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9029         enddo
9030       enddo
9031 #endif
9032 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9033 !d     &  16*eel_turn6_num
9034 !d      goto 1112
9035       if (j.lt.nres-1) then
9036         j1=j+1
9037         j2=j-1
9038       else
9039         j1=j-1
9040         j2=j-2
9041       endif
9042       if (l.lt.nres-1) then
9043         l1=l+1
9044         l2=l-1
9045       else
9046         l1=l-1
9047         l2=l-2
9048       endif
9049       do ll=1,3
9050 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9051 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9052 !grad        ghalf=0.5d0*ggg1(ll)
9053 !d        ghalf=0.0d0
9054         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9055         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9056         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9057           +ekont*derx_turn(ll,2,1)
9058         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9059         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9060           +ekont*derx_turn(ll,4,1)
9061         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9062         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9063         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9064 !grad        ghalf=0.5d0*ggg2(ll)
9065 !d        ghalf=0.0d0
9066         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9067           +ekont*derx_turn(ll,2,2)
9068         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9069         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9070           +ekont*derx_turn(ll,4,2)
9071         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9072         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9073         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9074       enddo
9075 !d      goto 1112
9076 !grad      do m=i+1,j-1
9077 !grad        do ll=1,3
9078 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9079 !grad        enddo
9080 !grad      enddo
9081 !grad      do m=k+1,l-1
9082 !grad        do ll=1,3
9083 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9084 !grad        enddo
9085 !grad      enddo
9086 !grad1112  continue
9087 !grad      do m=i+2,j2
9088 !grad        do ll=1,3
9089 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9090 !grad        enddo
9091 !grad      enddo
9092 !grad      do m=k+2,l2
9093 !grad        do ll=1,3
9094 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9095 !grad        enddo
9096 !grad      enddo
9097 !d      do iii=1,nres-3
9098 !d        write (2,*) iii,g_corr6_loc(iii)
9099 !d      enddo
9100       eello_turn6=ekont*eel_turn6
9101 !d      write (2,*) 'ekont',ekont
9102 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9103       return
9104       end function eello_turn6
9105 !-----------------------------------------------------------------------------
9106       subroutine MATVEC2(A1,V1,V2)
9107 !DIR$ INLINEALWAYS MATVEC2
9108 #ifndef OSF
9109 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9110 #endif
9111 !      implicit real*8 (a-h,o-z)
9112 !      include 'DIMENSIONS'
9113       real(kind=8),dimension(2) :: V1,V2
9114       real(kind=8),dimension(2,2) :: A1
9115       real(kind=8) :: vaux1,vaux2
9116 !      DO 1 I=1,2
9117 !        VI=0.0
9118 !        DO 3 K=1,2
9119 !    3     VI=VI+A1(I,K)*V1(K)
9120 !        Vaux(I)=VI
9121 !    1 CONTINUE
9122
9123       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9124       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9125
9126       v2(1)=vaux1
9127       v2(2)=vaux2
9128       end subroutine MATVEC2
9129 !-----------------------------------------------------------------------------
9130       subroutine MATMAT2(A1,A2,A3)
9131 #ifndef OSF
9132 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9133 #endif
9134 !      implicit real*8 (a-h,o-z)
9135 !      include 'DIMENSIONS'
9136       real(kind=8),dimension(2,2) :: A1,A2,A3
9137       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9138 !      DIMENSION AI3(2,2)
9139 !        DO  J=1,2
9140 !          A3IJ=0.0
9141 !          DO K=1,2
9142 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9143 !          enddo
9144 !          A3(I,J)=A3IJ
9145 !       enddo
9146 !      enddo
9147
9148       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9149       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9150       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9151       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9152
9153       A3(1,1)=AI3_11
9154       A3(2,1)=AI3_21
9155       A3(1,2)=AI3_12
9156       A3(2,2)=AI3_22
9157       end subroutine MATMAT2
9158 !-----------------------------------------------------------------------------
9159       real(kind=8) function scalar2(u,v)
9160 !DIR$ INLINEALWAYS scalar2
9161       implicit none
9162       real(kind=8),dimension(2) :: u,v
9163       real(kind=8) :: sc
9164       integer :: i
9165       scalar2=u(1)*v(1)+u(2)*v(2)
9166       return
9167       end function scalar2
9168 !-----------------------------------------------------------------------------
9169       subroutine transpose2(a,at)
9170 !DIR$ INLINEALWAYS transpose2
9171 #ifndef OSF
9172 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9173 #endif
9174       implicit none
9175       real(kind=8),dimension(2,2) :: a,at
9176       at(1,1)=a(1,1)
9177       at(1,2)=a(2,1)
9178       at(2,1)=a(1,2)
9179       at(2,2)=a(2,2)
9180       return
9181       end subroutine transpose2
9182 !-----------------------------------------------------------------------------
9183       subroutine transpose(n,a,at)
9184       implicit none
9185       integer :: n,i,j
9186       real(kind=8),dimension(n,n) :: a,at
9187       do i=1,n
9188         do j=1,n
9189           at(j,i)=a(i,j)
9190         enddo
9191       enddo
9192       return
9193       end subroutine transpose
9194 !-----------------------------------------------------------------------------
9195       subroutine prodmat3(a1,a2,kk,transp,prod)
9196 !DIR$ INLINEALWAYS prodmat3
9197 #ifndef OSF
9198 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9199 #endif
9200       implicit none
9201       integer :: i,j
9202       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9203       logical :: transp
9204 !rc      double precision auxmat(2,2),prod_(2,2)
9205
9206       if (transp) then
9207 !rc        call transpose2(kk(1,1),auxmat(1,1))
9208 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9209 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9210
9211            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9212        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9213            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9214        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9215            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9216        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9217            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9218        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9219
9220       else
9221 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9222 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9223
9224            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9225         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9226            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9227         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9228            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9229         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9230            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9231         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9232
9233       endif
9234 !      call transpose2(a2(1,1),a2t(1,1))
9235
9236 !rc      print *,transp
9237 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9238 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9239
9240       return
9241       end subroutine prodmat3
9242 !-----------------------------------------------------------------------------
9243 ! energy_p_new_barrier.F
9244 !-----------------------------------------------------------------------------
9245       subroutine sum_gradient
9246 !      implicit real*8 (a-h,o-z)
9247       use io_base, only: pdbout
9248 !      include 'DIMENSIONS'
9249 #ifndef ISNAN
9250       external proc_proc
9251 #ifdef WINPGI
9252 !MS$ATTRIBUTES C ::  proc_proc
9253 #endif
9254 #endif
9255 #ifdef MPI
9256       include 'mpif.h'
9257 #endif
9258       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9259                    gloc_scbuf !(3,maxres)
9260
9261       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9262 !#endif
9263 !el local variables
9264       integer :: i,j,k,ierror,ierr
9265       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9266                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9267                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9268                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9269                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9270                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9271                    gsccorr_max,gsccorrx_max,time00
9272
9273 !      include 'COMMON.SETUP'
9274 !      include 'COMMON.IOUNITS'
9275 !      include 'COMMON.FFIELD'
9276 !      include 'COMMON.DERIV'
9277 !      include 'COMMON.INTERACT'
9278 !      include 'COMMON.SBRIDGE'
9279 !      include 'COMMON.CHAIN'
9280 !      include 'COMMON.VAR'
9281 !      include 'COMMON.CONTROL'
9282 !      include 'COMMON.TIME1'
9283 !      include 'COMMON.MAXGRAD'
9284 !      include 'COMMON.SCCOR'
9285 #ifdef TIMING
9286       time01=MPI_Wtime()
9287 #endif
9288 #ifdef DEBUG
9289       write (iout,*) "sum_gradient gvdwc, gvdwx"
9290       do i=1,nres
9291         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9292          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9293       enddo
9294       call flush(iout)
9295 #endif
9296 #ifdef MPI
9297         gradbufc=0.0d0
9298         gradbufx=0.0d0
9299         gradbufc_sum=0.0d0
9300         gloc_scbuf=0.0d0
9301         glocbuf=0.0d0
9302 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9303         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9304           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9305 #endif
9306 !
9307 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9308 !            in virtual-bond-vector coordinates
9309 !
9310 #ifdef DEBUG
9311 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9312 !      do i=1,nres-1
9313 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9314 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9315 !      enddo
9316 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9317 !      do i=1,nres-1
9318 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9319 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9320 !      enddo
9321       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9322       do i=1,nres
9323         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9324          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9325          (gvdwc_scpp(j,i),j=1,3)
9326       enddo
9327       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9328       do i=1,nres
9329         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9330          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9331          (gelc_loc_long(j,i),j=1,3)
9332       enddo
9333       call flush(iout)
9334 #endif
9335 #ifdef SPLITELE
9336       do i=1,nct
9337         do j=1,3
9338           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9339                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9340                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9341                       wel_loc*gel_loc_long(j,i)+ &
9342                       wcorr*gradcorr_long(j,i)+ &
9343                       wcorr5*gradcorr5_long(j,i)+ &
9344                       wcorr6*gradcorr6_long(j,i)+ &
9345                       wturn6*gcorr6_turn_long(j,i)+ &
9346                       wstrain*ghpbc(j,i)
9347         enddo
9348       enddo
9349 #else
9350       do i=1,nct
9351         do j=1,3
9352           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9353                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9354                       welec*gelc_long(j,i)+ &
9355                       wbond*gradb(j,i)+ &
9356                       wel_loc*gel_loc_long(j,i)+ &
9357                       wcorr*gradcorr_long(j,i)+ &
9358                       wcorr5*gradcorr5_long(j,i)+ &
9359                       wcorr6*gradcorr6_long(j,i)+ &
9360                       wturn6*gcorr6_turn_long(j,i)+ &
9361                       wstrain*ghpbc(j,i)
9362         enddo
9363       enddo
9364 #endif
9365 #ifdef MPI
9366       if (nfgtasks.gt.1) then
9367       time00=MPI_Wtime()
9368 #ifdef DEBUG
9369       write (iout,*) "gradbufc before allreduce"
9370       do i=1,nres
9371         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9372       enddo
9373       call flush(iout)
9374 #endif
9375       do i=1,nres
9376         do j=1,3
9377           gradbufc_sum(j,i)=gradbufc(j,i)
9378         enddo
9379       enddo
9380 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9381 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9382 !      time_reduce=time_reduce+MPI_Wtime()-time00
9383 #ifdef DEBUG
9384 !      write (iout,*) "gradbufc_sum after allreduce"
9385 !      do i=1,nres
9386 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9387 !      enddo
9388 !      call flush(iout)
9389 #endif
9390 #ifdef TIMING
9391 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9392 #endif
9393       do i=nnt,nres
9394         do k=1,3
9395           gradbufc(k,i)=0.0d0
9396         enddo
9397       enddo
9398 #ifdef DEBUG
9399       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9400       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9401                         " jgrad_end  ",jgrad_end(i),&
9402                         i=igrad_start,igrad_end)
9403 #endif
9404 !
9405 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9406 ! do not parallelize this part.
9407 !
9408 !      do i=igrad_start,igrad_end
9409 !        do j=jgrad_start(i),jgrad_end(i)
9410 !          do k=1,3
9411 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9412 !          enddo
9413 !        enddo
9414 !      enddo
9415       do j=1,3
9416         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9417       enddo
9418       do i=nres-2,nnt,-1
9419         do j=1,3
9420           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9421         enddo
9422       enddo
9423 #ifdef DEBUG
9424       write (iout,*) "gradbufc after summing"
9425       do i=1,nres
9426         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9427       enddo
9428       call flush(iout)
9429 #endif
9430       else
9431 #endif
9432 !el#define DEBUG
9433 #ifdef DEBUG
9434       write (iout,*) "gradbufc"
9435       do i=1,nres
9436         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9437       enddo
9438       call flush(iout)
9439 #endif
9440 !el#undef DEBUG
9441       do i=1,nres
9442         do j=1,3
9443           gradbufc_sum(j,i)=gradbufc(j,i)
9444           gradbufc(j,i)=0.0d0
9445         enddo
9446       enddo
9447       do j=1,3
9448         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9449       enddo
9450       do i=nres-2,nnt,-1
9451         do j=1,3
9452           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9453         enddo
9454       enddo
9455 !      do i=nnt,nres-1
9456 !        do k=1,3
9457 !          gradbufc(k,i)=0.0d0
9458 !        enddo
9459 !        do j=i+1,nres
9460 !          do k=1,3
9461 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9462 !          enddo
9463 !        enddo
9464 !      enddo
9465 !el#define DEBUG
9466 #ifdef DEBUG
9467       write (iout,*) "gradbufc after summing"
9468       do i=1,nres
9469         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9470       enddo
9471       call flush(iout)
9472 #endif
9473 !el#undef DEBUG
9474 #ifdef MPI
9475       endif
9476 #endif
9477       do k=1,3
9478         gradbufc(k,nres)=0.0d0
9479       enddo
9480 !el----------------
9481 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9482 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9483 !el-----------------
9484       do i=1,nct
9485         do j=1,3
9486 #ifdef SPLITELE
9487           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9488                       wel_loc*gel_loc(j,i)+ &
9489                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9490                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9491                       wel_loc*gel_loc_long(j,i)+ &
9492                       wcorr*gradcorr_long(j,i)+ &
9493                       wcorr5*gradcorr5_long(j,i)+ &
9494                       wcorr6*gradcorr6_long(j,i)+ &
9495                       wturn6*gcorr6_turn_long(j,i))+ &
9496                       wbond*gradb(j,i)+ &
9497                       wcorr*gradcorr(j,i)+ &
9498                       wturn3*gcorr3_turn(j,i)+ &
9499                       wturn4*gcorr4_turn(j,i)+ &
9500                       wcorr5*gradcorr5(j,i)+ &
9501                       wcorr6*gradcorr6(j,i)+ &
9502                       wturn6*gcorr6_turn(j,i)+ &
9503                       wsccor*gsccorc(j,i) &
9504                      +wscloc*gscloc(j,i)
9505 #else
9506           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9507                       wel_loc*gel_loc(j,i)+ &
9508                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9509                       welec*gelc_long(j,i)+ &
9510                       wel_loc*gel_loc_long(j,i)+ &
9511 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9512                       wcorr5*gradcorr5_long(j,i)+ &
9513                       wcorr6*gradcorr6_long(j,i)+ &
9514                       wturn6*gcorr6_turn_long(j,i))+ &
9515                       wbond*gradb(j,i)+ &
9516                       wcorr*gradcorr(j,i)+ &
9517                       wturn3*gcorr3_turn(j,i)+ &
9518                       wturn4*gcorr4_turn(j,i)+ &
9519                       wcorr5*gradcorr5(j,i)+ &
9520                       wcorr6*gradcorr6(j,i)+ &
9521                       wturn6*gcorr6_turn(j,i)+ &
9522                       wsccor*gsccorc(j,i) &
9523                      +wscloc*gscloc(j,i)
9524 #endif
9525           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9526                         wbond*gradbx(j,i)+ &
9527                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9528                         wsccor*gsccorx(j,i) &
9529                        +wscloc*gsclocx(j,i)
9530         enddo
9531       enddo
9532 #ifdef DEBUG
9533       write (iout,*) "gloc before adding corr"
9534       do i=1,4*nres
9535         write (iout,*) i,gloc(i,icg)
9536       enddo
9537 #endif
9538       do i=1,nres-3
9539         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9540          +wcorr5*g_corr5_loc(i) &
9541          +wcorr6*g_corr6_loc(i) &
9542          +wturn4*gel_loc_turn4(i) &
9543          +wturn3*gel_loc_turn3(i) &
9544          +wturn6*gel_loc_turn6(i) &
9545          +wel_loc*gel_loc_loc(i)
9546       enddo
9547 #ifdef DEBUG
9548       write (iout,*) "gloc after adding corr"
9549       do i=1,4*nres
9550         write (iout,*) i,gloc(i,icg)
9551       enddo
9552 #endif
9553 #ifdef MPI
9554       if (nfgtasks.gt.1) then
9555         do j=1,3
9556           do i=1,nres
9557             gradbufc(j,i)=gradc(j,i,icg)
9558             gradbufx(j,i)=gradx(j,i,icg)
9559           enddo
9560         enddo
9561         do i=1,4*nres
9562           glocbuf(i)=gloc(i,icg)
9563         enddo
9564 !#define DEBUG
9565 #ifdef DEBUG
9566       write (iout,*) "gloc_sc before reduce"
9567       do i=1,nres
9568        do j=1,1
9569         write (iout,*) i,j,gloc_sc(j,i,icg)
9570        enddo
9571       enddo
9572 #endif
9573 !#undef DEBUG
9574         do i=1,nres
9575          do j=1,3
9576           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9577          enddo
9578         enddo
9579         time00=MPI_Wtime()
9580         call MPI_Barrier(FG_COMM,IERR)
9581         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9582         time00=MPI_Wtime()
9583         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9584           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9585         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9586           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9587         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9588           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9589         time_reduce=time_reduce+MPI_Wtime()-time00
9590         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9591           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9592         time_reduce=time_reduce+MPI_Wtime()-time00
9593 !#define DEBUG
9594 #ifdef DEBUG
9595       write (iout,*) "gloc_sc after reduce"
9596       do i=1,nres
9597        do j=1,1
9598         write (iout,*) i,j,gloc_sc(j,i,icg)
9599        enddo
9600       enddo
9601 #endif
9602 !#undef DEBUG
9603 #ifdef DEBUG
9604       write (iout,*) "gloc after reduce"
9605       do i=1,4*nres
9606         write (iout,*) i,gloc(i,icg)
9607       enddo
9608 #endif
9609       endif
9610 #endif
9611       if (gnorm_check) then
9612 !
9613 ! Compute the maximum elements of the gradient
9614 !
9615       gvdwc_max=0.0d0
9616       gvdwc_scp_max=0.0d0
9617       gelc_max=0.0d0
9618       gvdwpp_max=0.0d0
9619       gradb_max=0.0d0
9620       ghpbc_max=0.0d0
9621       gradcorr_max=0.0d0
9622       gel_loc_max=0.0d0
9623       gcorr3_turn_max=0.0d0
9624       gcorr4_turn_max=0.0d0
9625       gradcorr5_max=0.0d0
9626       gradcorr6_max=0.0d0
9627       gcorr6_turn_max=0.0d0
9628       gsccorc_max=0.0d0
9629       gscloc_max=0.0d0
9630       gvdwx_max=0.0d0
9631       gradx_scp_max=0.0d0
9632       ghpbx_max=0.0d0
9633       gradxorr_max=0.0d0
9634       gsccorx_max=0.0d0
9635       gsclocx_max=0.0d0
9636       do i=1,nct
9637         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9638         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9639         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9640         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9641          gvdwc_scp_max=gvdwc_scp_norm
9642         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9643         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9644         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9645         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9646         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9647         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9648         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9649         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9650         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9651         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9652         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9653         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9654         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9655           gcorr3_turn(1,i)))
9656         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9657           gcorr3_turn_max=gcorr3_turn_norm
9658         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9659           gcorr4_turn(1,i)))
9660         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9661           gcorr4_turn_max=gcorr4_turn_norm
9662         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9663         if (gradcorr5_norm.gt.gradcorr5_max) &
9664           gradcorr5_max=gradcorr5_norm
9665         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9666         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9667         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9668           gcorr6_turn(1,i)))
9669         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9670           gcorr6_turn_max=gcorr6_turn_norm
9671         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9672         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9673         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9674         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9675         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9676         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9677         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9678         if (gradx_scp_norm.gt.gradx_scp_max) &
9679           gradx_scp_max=gradx_scp_norm
9680         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9681         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9682         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9683         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9684         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9685         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9686         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9687         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9688       enddo
9689       if (gradout) then
9690 #ifdef AIX
9691         open(istat,file=statname,position="append")
9692 #else
9693         open(istat,file=statname,access="append")
9694 #endif
9695         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9696            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9697            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9698            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9699            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9700            gsccorx_max,gsclocx_max
9701         close(istat)
9702         if (gvdwc_max.gt.1.0d4) then
9703           write (iout,*) "gvdwc gvdwx gradb gradbx"
9704           do i=nnt,nct
9705             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9706               gradb(j,i),gradbx(j,i),j=1,3)
9707           enddo
9708           call pdbout(0.0d0,'cipiszcze',iout)
9709           call flush(iout)
9710         endif
9711       endif
9712       endif
9713 !el#define DEBUG
9714 #ifdef DEBUG
9715       write (iout,*) "gradc gradx gloc"
9716       do i=1,nres
9717         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9718          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9719       enddo
9720 #endif
9721 !el#undef DEBUG
9722 #ifdef TIMING
9723       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9724 #endif
9725       return
9726       end subroutine sum_gradient
9727 !-----------------------------------------------------------------------------
9728       subroutine sc_grad
9729 !      implicit real*8 (a-h,o-z)
9730       use calc_data
9731 !      include 'DIMENSIONS'
9732 !      include 'COMMON.CHAIN'
9733 !      include 'COMMON.DERIV'
9734 !      include 'COMMON.CALC'
9735 !      include 'COMMON.IOUNITS'
9736       real(kind=8), dimension(3) :: dcosom1,dcosom2
9737
9738       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9739       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9740       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9741            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9742 ! diagnostics only
9743 !      eom1=0.0d0
9744 !      eom2=0.0d0
9745 !      eom12=evdwij*eps1_om12
9746 ! end diagnostics
9747 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9748 !       " sigder",sigder
9749 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9750 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9751 !C      print *,sss_ele_cut,'in sc_grad'
9752       do k=1,3
9753         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9754         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9755       enddo
9756       do k=1,3
9757         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9758 !C      print *,'gg',k,gg(k)
9759       enddo
9760 !      write (iout,*) "gg",(gg(k),k=1,3)
9761       do k=1,3
9762         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9763                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9764                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9765                   *sss_ele_cut
9766
9767         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9768                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9769                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9770                   *sss_ele_cut
9771
9772 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9773 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9774 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9775 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9776       enddo
9777 !
9778 ! Calculate the components of the gradient in DC and X
9779 !
9780 !grad      do k=i,j-1
9781 !grad        do l=1,3
9782 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9783 !grad        enddo
9784 !grad      enddo
9785       do l=1,3
9786         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9787         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9788       enddo
9789       return
9790       end subroutine sc_grad
9791 #ifdef CRYST_THETA
9792 !-----------------------------------------------------------------------------
9793       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9794
9795       use comm_calcthet
9796 !      implicit real*8 (a-h,o-z)
9797 !      include 'DIMENSIONS'
9798 !      include 'COMMON.LOCAL'
9799 !      include 'COMMON.IOUNITS'
9800 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9801 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9802 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9803       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9804       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9805 !el      integer :: it
9806 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9807 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9808 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9809 !el local variables
9810
9811       delthec=thetai-thet_pred_mean
9812       delthe0=thetai-theta0i
9813 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9814       t3 = thetai-thet_pred_mean
9815       t6 = t3**2
9816       t9 = term1
9817       t12 = t3*sigcsq
9818       t14 = t12+t6*sigsqtc
9819       t16 = 1.0d0
9820       t21 = thetai-theta0i
9821       t23 = t21**2
9822       t26 = term2
9823       t27 = t21*t26
9824       t32 = termexp
9825       t40 = t32**2
9826       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9827        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9828        *(-t12*t9-ak*sig0inv*t27)
9829       return
9830       end subroutine mixder
9831 #endif
9832 !-----------------------------------------------------------------------------
9833 ! cartder.F
9834 !-----------------------------------------------------------------------------
9835       subroutine cartder
9836 !-----------------------------------------------------------------------------
9837 ! This subroutine calculates the derivatives of the consecutive virtual
9838 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9839 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9840 ! in the angles alpha and omega, describing the location of a side chain
9841 ! in its local coordinate system.
9842 !
9843 ! The derivatives are stored in the following arrays:
9844 !
9845 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9846 ! The structure is as follows:
9847 !
9848 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9849 ! 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)
9850 !         . . . . . . . . . . . .  . . . . . .
9851 ! 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)
9852 !                          .
9853 !                          .
9854 !                          .
9855 ! 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)
9856 !
9857 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9858 ! The structure is same as above.
9859 !
9860 ! DCDS - the derivatives of the side chain vectors in the local spherical
9861 ! andgles alph and omega:
9862 !
9863 ! 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)
9864 ! 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)
9865 !                          .
9866 !                          .
9867 !                          .
9868 ! 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)
9869 !
9870 ! Version of March '95, based on an early version of November '91.
9871 !
9872 !**********************************************************************
9873 !      implicit real*8 (a-h,o-z)
9874 !      include 'DIMENSIONS'
9875 !      include 'COMMON.VAR'
9876 !      include 'COMMON.CHAIN'
9877 !      include 'COMMON.DERIV'
9878 !      include 'COMMON.GEO'
9879 !      include 'COMMON.LOCAL'
9880 !      include 'COMMON.INTERACT'
9881       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9882       real(kind=8),dimension(3,3) :: dp,temp
9883 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9884       real(kind=8),dimension(3) :: xx,xx1
9885 !el local variables
9886       integer :: i,k,l,j,m,ind,ind1,jjj
9887       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9888                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9889                  sint2,xp,yp,xxp,yyp,zzp,dj
9890
9891 !      common /przechowalnia/ fromto
9892       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9893 ! get the position of the jth ijth fragment of the chain coordinate system
9894 ! in the fromto array.
9895 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9896 !
9897 !      maxdim=(nres-1)*(nres-2)/2
9898 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9899 ! calculate the derivatives of transformation matrix elements in theta
9900 !
9901
9902 !el      call flush(iout) !el
9903       do i=1,nres-2
9904         rdt(1,1,i)=-rt(1,2,i)
9905         rdt(1,2,i)= rt(1,1,i)
9906         rdt(1,3,i)= 0.0d0
9907         rdt(2,1,i)=-rt(2,2,i)
9908         rdt(2,2,i)= rt(2,1,i)
9909         rdt(2,3,i)= 0.0d0
9910         rdt(3,1,i)=-rt(3,2,i)
9911         rdt(3,2,i)= rt(3,1,i)
9912         rdt(3,3,i)= 0.0d0
9913       enddo
9914 !
9915 ! derivatives in phi
9916 !
9917       do i=2,nres-2
9918         drt(1,1,i)= 0.0d0
9919         drt(1,2,i)= 0.0d0
9920         drt(1,3,i)= 0.0d0
9921         drt(2,1,i)= rt(3,1,i)
9922         drt(2,2,i)= rt(3,2,i)
9923         drt(2,3,i)= rt(3,3,i)
9924         drt(3,1,i)=-rt(2,1,i)
9925         drt(3,2,i)=-rt(2,2,i)
9926         drt(3,3,i)=-rt(2,3,i)
9927       enddo
9928 !
9929 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9930 !
9931       do i=2,nres-2
9932         ind=indmat(i,i+1)
9933         do k=1,3
9934           do l=1,3
9935             temp(k,l)=rt(k,l,i)
9936           enddo
9937         enddo
9938         do k=1,3
9939           do l=1,3
9940             fromto(k,l,ind)=temp(k,l)
9941           enddo
9942         enddo
9943         do j=i+1,nres-2
9944           ind=indmat(i,j+1)
9945           do k=1,3
9946             do l=1,3
9947               dpkl=0.0d0
9948               do m=1,3
9949                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9950               enddo
9951               dp(k,l)=dpkl
9952               fromto(k,l,ind)=dpkl
9953             enddo
9954           enddo
9955           do k=1,3
9956             do l=1,3
9957               temp(k,l)=dp(k,l)
9958             enddo
9959           enddo
9960         enddo
9961       enddo
9962 !
9963 ! Calculate derivatives.
9964 !
9965       ind1=0
9966       do i=1,nres-2
9967         ind1=ind1+1
9968 !
9969 ! Derivatives of DC(i+1) in theta(i+2)
9970 !
9971         do j=1,3
9972           do k=1,2
9973             dpjk=0.0D0
9974             do l=1,3
9975               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9976             enddo
9977             dp(j,k)=dpjk
9978             prordt(j,k,i)=dp(j,k)
9979           enddo
9980           dp(j,3)=0.0D0
9981           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9982         enddo
9983 !
9984 ! Derivatives of SC(i+1) in theta(i+2)
9985 !
9986         xx1(1)=-0.5D0*xloc(2,i+1)
9987         xx1(2)= 0.5D0*xloc(1,i+1)
9988         do j=1,3
9989           xj=0.0D0
9990           do k=1,2
9991             xj=xj+r(j,k,i)*xx1(k)
9992           enddo
9993           xx(j)=xj
9994         enddo
9995         do j=1,3
9996           rj=0.0D0
9997           do k=1,3
9998             rj=rj+prod(j,k,i)*xx(k)
9999           enddo
10000           dxdv(j,ind1)=rj
10001         enddo
10002 !
10003 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10004 ! than the other off-diagonal derivatives.
10005 !
10006         do j=1,3
10007           dxoiij=0.0D0
10008           do k=1,3
10009             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10010           enddo
10011           dxdv(j,ind1+1)=dxoiij
10012         enddo
10013 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10014 !
10015 ! Derivatives of DC(i+1) in phi(i+2)
10016 !
10017         do j=1,3
10018           do k=1,3
10019             dpjk=0.0
10020             do l=2,3
10021               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10022             enddo
10023             dp(j,k)=dpjk
10024             prodrt(j,k,i)=dp(j,k)
10025           enddo
10026           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10027         enddo
10028 !
10029 ! Derivatives of SC(i+1) in phi(i+2)
10030 !
10031         xx(1)= 0.0D0
10032         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10033         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10034         do j=1,3
10035           rj=0.0D0
10036           do k=2,3
10037             rj=rj+prod(j,k,i)*xx(k)
10038           enddo
10039           dxdv(j+3,ind1)=-rj
10040         enddo
10041 !
10042 ! Derivatives of SC(i+1) in phi(i+3).
10043 !
10044         do j=1,3
10045           dxoiij=0.0D0
10046           do k=1,3
10047             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10048           enddo
10049           dxdv(j+3,ind1+1)=dxoiij
10050         enddo
10051 !
10052 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10053 ! theta(nres) and phi(i+3) thru phi(nres).
10054 !
10055         do j=i+1,nres-2
10056           ind1=ind1+1
10057           ind=indmat(i+1,j+1)
10058 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10059           do k=1,3
10060             do l=1,3
10061               tempkl=0.0D0
10062               do m=1,2
10063                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10064               enddo
10065               temp(k,l)=tempkl
10066             enddo
10067           enddo
10068 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10069 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10070 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10071 ! Derivatives of virtual-bond vectors in theta
10072           do k=1,3
10073             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10074           enddo
10075 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10076 ! Derivatives of SC vectors in theta
10077           do k=1,3
10078             dxoijk=0.0D0
10079             do l=1,3
10080               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10081             enddo
10082             dxdv(k,ind1+1)=dxoijk
10083           enddo
10084 !
10085 !--- Calculate the derivatives in phi
10086 !
10087           do k=1,3
10088             do l=1,3
10089               tempkl=0.0D0
10090               do m=1,3
10091                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10092               enddo
10093               temp(k,l)=tempkl
10094             enddo
10095           enddo
10096           do k=1,3
10097             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10098           enddo
10099           do k=1,3
10100             dxoijk=0.0D0
10101             do l=1,3
10102               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10103             enddo
10104             dxdv(k+3,ind1+1)=dxoijk
10105           enddo
10106         enddo
10107       enddo
10108 !
10109 ! Derivatives in alpha and omega:
10110 !
10111       do i=2,nres-1
10112 !       dsci=dsc(itype(i))
10113         dsci=vbld(i+nres)
10114 #ifdef OSF
10115         alphi=alph(i)
10116         omegi=omeg(i)
10117         if(alphi.ne.alphi) alphi=100.0
10118         if(omegi.ne.omegi) omegi=-100.0
10119 #else
10120         alphi=alph(i)
10121         omegi=omeg(i)
10122 #endif
10123 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10124         cosalphi=dcos(alphi)
10125         sinalphi=dsin(alphi)
10126         cosomegi=dcos(omegi)
10127         sinomegi=dsin(omegi)
10128         temp(1,1)=-dsci*sinalphi
10129         temp(2,1)= dsci*cosalphi*cosomegi
10130         temp(3,1)=-dsci*cosalphi*sinomegi
10131         temp(1,2)=0.0D0
10132         temp(2,2)=-dsci*sinalphi*sinomegi
10133         temp(3,2)=-dsci*sinalphi*cosomegi
10134         theta2=pi-0.5D0*theta(i+1)
10135         cost2=dcos(theta2)
10136         sint2=dsin(theta2)
10137         jjj=0
10138 !d      print *,((temp(l,k),l=1,3),k=1,2)
10139         do j=1,2
10140           xp=temp(1,j)
10141           yp=temp(2,j)
10142           xxp= xp*cost2+yp*sint2
10143           yyp=-xp*sint2+yp*cost2
10144           zzp=temp(3,j)
10145           xx(1)=xxp
10146           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10147           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10148           do k=1,3
10149             dj=0.0D0
10150             do l=1,3
10151               dj=dj+prod(k,l,i-1)*xx(l)
10152             enddo
10153             dxds(jjj+k,i)=dj
10154           enddo
10155           jjj=jjj+3
10156         enddo
10157       enddo
10158       return
10159       end subroutine cartder
10160 !-----------------------------------------------------------------------------
10161 ! checkder_p.F
10162 !-----------------------------------------------------------------------------
10163       subroutine check_cartgrad
10164 ! Check the gradient of Cartesian coordinates in internal coordinates.
10165 !      implicit real*8 (a-h,o-z)
10166 !      include 'DIMENSIONS'
10167 !      include 'COMMON.IOUNITS'
10168 !      include 'COMMON.VAR'
10169 !      include 'COMMON.CHAIN'
10170 !      include 'COMMON.GEO'
10171 !      include 'COMMON.LOCAL'
10172 !      include 'COMMON.DERIV'
10173       real(kind=8),dimension(6,nres) :: temp
10174       real(kind=8),dimension(3) :: xx,gg
10175       integer :: i,k,j,ii
10176       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10177 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10178 !
10179 ! Check the gradient of the virtual-bond and SC vectors in the internal
10180 ! coordinates.
10181 !
10182       aincr=1.0d-7
10183       aincr2=5.0d-8
10184       call cartder
10185       write (iout,'(a)') '**************** dx/dalpha'
10186       write (iout,'(a)')
10187       do i=2,nres-1
10188         alphi=alph(i)
10189         alph(i)=alph(i)+aincr
10190         do k=1,3
10191           temp(k,i)=dc(k,nres+i)
10192         enddo
10193         call chainbuild
10194         do k=1,3
10195           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10196           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10197         enddo
10198         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10199         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10200         write (iout,'(a)')
10201         alph(i)=alphi
10202         call chainbuild
10203       enddo
10204       write (iout,'(a)')
10205       write (iout,'(a)') '**************** dx/domega'
10206       write (iout,'(a)')
10207       do i=2,nres-1
10208         omegi=omeg(i)
10209         omeg(i)=omeg(i)+aincr
10210         do k=1,3
10211           temp(k,i)=dc(k,nres+i)
10212         enddo
10213         call chainbuild
10214         do k=1,3
10215           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10216           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10217                 (aincr*dabs(dxds(k+3,i))+aincr))
10218         enddo
10219         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10220             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10221         write (iout,'(a)')
10222         omeg(i)=omegi
10223         call chainbuild
10224       enddo
10225       write (iout,'(a)')
10226       write (iout,'(a)') '**************** dx/dtheta'
10227       write (iout,'(a)')
10228       do i=3,nres
10229         theti=theta(i)
10230         theta(i)=theta(i)+aincr
10231         do j=i-1,nres-1
10232           do k=1,3
10233             temp(k,j)=dc(k,nres+j)
10234           enddo
10235         enddo
10236         call chainbuild
10237         do j=i-1,nres-1
10238           ii = indmat(i-2,j)
10239 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10240           do k=1,3
10241             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10242             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10243                   (aincr*dabs(dxdv(k,ii))+aincr))
10244           enddo
10245           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10246               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10247           write(iout,'(a)')
10248         enddo
10249         write (iout,'(a)')
10250         theta(i)=theti
10251         call chainbuild
10252       enddo
10253       write (iout,'(a)') '***************** dx/dphi'
10254       write (iout,'(a)')
10255       do i=4,nres
10256         phi(i)=phi(i)+aincr
10257         do j=i-1,nres-1
10258           do k=1,3
10259             temp(k,j)=dc(k,nres+j)
10260           enddo
10261         enddo
10262         call chainbuild
10263         do j=i-1,nres-1
10264           ii = indmat(i-2,j)
10265 !         print *,'ii=',ii
10266           do k=1,3
10267             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10268             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10269                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10270           enddo
10271           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10272               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10273           write(iout,'(a)')
10274         enddo
10275         phi(i)=phi(i)-aincr
10276         call chainbuild
10277       enddo
10278       write (iout,'(a)') '****************** ddc/dtheta'
10279       do i=1,nres-2
10280         thet=theta(i+2)
10281         theta(i+2)=thet+aincr
10282         do j=i,nres
10283           do k=1,3
10284             temp(k,j)=dc(k,j)
10285           enddo
10286         enddo
10287         call chainbuild
10288         do j=i+1,nres-1
10289           ii = indmat(i,j)
10290 !         print *,'ii=',ii
10291           do k=1,3
10292             gg(k)=(dc(k,j)-temp(k,j))/aincr
10293             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10294                  (aincr*dabs(dcdv(k,ii))+aincr))
10295           enddo
10296           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10297                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10298           write (iout,'(a)')
10299         enddo
10300         do j=1,nres
10301           do k=1,3
10302             dc(k,j)=temp(k,j)
10303           enddo
10304         enddo
10305         theta(i+2)=thet
10306       enddo
10307       write (iout,'(a)') '******************* ddc/dphi'
10308       do i=1,nres-3
10309         phii=phi(i+3)
10310         phi(i+3)=phii+aincr
10311         do j=1,nres
10312           do k=1,3
10313             temp(k,j)=dc(k,j)
10314           enddo
10315         enddo
10316         call chainbuild
10317         do j=i+2,nres-1
10318           ii = indmat(i+1,j)
10319 !         print *,'ii=',ii
10320           do k=1,3
10321             gg(k)=(dc(k,j)-temp(k,j))/aincr
10322             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10323                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10324           enddo
10325           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10326                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10327           write (iout,'(a)')
10328         enddo
10329         do j=1,nres
10330           do k=1,3
10331             dc(k,j)=temp(k,j)
10332           enddo
10333         enddo
10334         phi(i+3)=phii
10335       enddo
10336       return
10337       end subroutine check_cartgrad
10338 !-----------------------------------------------------------------------------
10339       subroutine check_ecart
10340 ! Check the gradient of the energy in Cartesian coordinates.
10341 !     implicit real*8 (a-h,o-z)
10342 !     include 'DIMENSIONS'
10343 !     include 'COMMON.CHAIN'
10344 !     include 'COMMON.DERIV'
10345 !     include 'COMMON.IOUNITS'
10346 !     include 'COMMON.VAR'
10347 !     include 'COMMON.CONTACTS'
10348       use comm_srutu
10349 !el      integer :: icall
10350 !el      common /srutu/ icall
10351       real(kind=8),dimension(6) :: ggg
10352       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10353       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10354       real(kind=8),dimension(6,nres) :: grad_s
10355       real(kind=8),dimension(0:n_ene) :: energia,energia1
10356       integer :: uiparm(1)
10357       real(kind=8) :: urparm(1)
10358 !EL      external fdum
10359       integer :: nf,i,j,k
10360       real(kind=8) :: aincr,etot,etot1
10361       icg=1
10362       nf=0
10363       nfl=0
10364       call zerograd
10365       aincr=1.0D-7
10366       print '(a)','CG processor',me,' calling CHECK_CART.'
10367       nf=0
10368       icall=0
10369       call geom_to_var(nvar,x)
10370       call etotal(energia)
10371       etot=energia(0)
10372 !el      call enerprint(energia)
10373       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10374       icall =1
10375       do i=1,nres
10376         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10377       enddo
10378       do i=1,nres
10379         do j=1,3
10380           grad_s(j,i)=gradc(j,i,icg)
10381           grad_s(j+3,i)=gradx(j,i,icg)
10382         enddo
10383       enddo
10384       call flush(iout)
10385       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10386       do i=1,nres
10387         do j=1,3
10388           xx(j)=c(j,i+nres)
10389           ddc(j)=dc(j,i)
10390           ddx(j)=dc(j,i+nres)
10391         enddo
10392         do j=1,3
10393           dc(j,i)=dc(j,i)+aincr
10394           do k=i+1,nres
10395             c(j,k)=c(j,k)+aincr
10396             c(j,k+nres)=c(j,k+nres)+aincr
10397           enddo
10398           call etotal(energia1)
10399           etot1=energia1(0)
10400           ggg(j)=(etot1-etot)/aincr
10401           dc(j,i)=ddc(j)
10402           do k=i+1,nres
10403             c(j,k)=c(j,k)-aincr
10404             c(j,k+nres)=c(j,k+nres)-aincr
10405           enddo
10406         enddo
10407         do j=1,3
10408           c(j,i+nres)=c(j,i+nres)+aincr
10409           dc(j,i+nres)=dc(j,i+nres)+aincr
10410           call etotal(energia1)
10411           etot1=energia1(0)
10412           ggg(j+3)=(etot1-etot)/aincr
10413           c(j,i+nres)=xx(j)
10414           dc(j,i+nres)=ddx(j)
10415         enddo
10416         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10417          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10418       enddo
10419       return
10420       end subroutine check_ecart
10421 #ifdef CARGRAD
10422 !-----------------------------------------------------------------------------
10423       subroutine check_ecartint
10424 ! Check the gradient of the energy in Cartesian coordinates.
10425       use io_base, only: intout
10426 !      implicit real*8 (a-h,o-z)
10427 !      include 'DIMENSIONS'
10428 !      include 'COMMON.CONTROL'
10429 !      include 'COMMON.CHAIN'
10430 !      include 'COMMON.DERIV'
10431 !      include 'COMMON.IOUNITS'
10432 !      include 'COMMON.VAR'
10433 !      include 'COMMON.CONTACTS'
10434 !      include 'COMMON.MD'
10435 !      include 'COMMON.LOCAL'
10436 !      include 'COMMON.SPLITELE'
10437       use comm_srutu
10438 !el      integer :: icall
10439 !el      common /srutu/ icall
10440       real(kind=8),dimension(6) :: ggg,ggg1
10441       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10442       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10443       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10444       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10445       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10446       real(kind=8),dimension(0:n_ene) :: energia,energia1
10447       integer :: uiparm(1)
10448       real(kind=8) :: urparm(1)
10449 !EL      external fdum
10450       integer :: i,j,k,nf
10451       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10452                    etot21,etot22
10453       r_cut=2.0d0
10454       rlambd=0.3d0
10455       icg=1
10456       nf=0
10457       nfl=0
10458       call intout
10459 !      call intcartderiv
10460 !      call checkintcartgrad
10461       call zerograd
10462       aincr=1.0D-5
10463       write(iout,*) 'Calling CHECK_ECARTINT.'
10464       nf=0
10465       icall=0
10466       write (iout,*) "Before geom_to_var"
10467       call geom_to_var(nvar,x)
10468       write (iout,*) "after geom_to_var"
10469       write (iout,*) "split_ene ",split_ene
10470       call flush(iout)
10471       if (.not.split_ene) then
10472         write(iout,*) 'Calling CHECK_ECARTINT if'
10473         call etotal(energia)
10474 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10475         etot=energia(0)
10476         write (iout,*) "etot",etot
10477         call flush(iout)
10478 !el        call enerprint(energia)
10479 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10480         call flush(iout)
10481         write (iout,*) "enter cartgrad"
10482         call flush(iout)
10483         call cartgrad
10484 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10485         write (iout,*) "exit cartgrad"
10486         call flush(iout)
10487         icall =1
10488         do i=1,nres
10489           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10490         enddo
10491         do j=1,3
10492           grad_s(j,0)=gcart(j,0)
10493         enddo
10494 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10495         do i=1,nres
10496           do j=1,3
10497             grad_s(j,i)=gcart(j,i)
10498             grad_s(j+3,i)=gxcart(j,i)
10499           enddo
10500         enddo
10501       else
10502 write(iout,*) 'Calling CHECK_ECARTIN else.'
10503 !- split gradient check
10504         call zerograd
10505         call etotal_long(energia)
10506 !el        call enerprint(energia)
10507         call flush(iout)
10508         write (iout,*) "enter cartgrad"
10509         call flush(iout)
10510         call cartgrad
10511         write (iout,*) "exit cartgrad"
10512         call flush(iout)
10513         icall =1
10514         write (iout,*) "longrange grad"
10515         do i=1,nres
10516           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10517           (gxcart(j,i),j=1,3)
10518         enddo
10519         do j=1,3
10520           grad_s(j,0)=gcart(j,0)
10521         enddo
10522         do i=1,nres
10523           do j=1,3
10524             grad_s(j,i)=gcart(j,i)
10525             grad_s(j+3,i)=gxcart(j,i)
10526           enddo
10527         enddo
10528         call zerograd
10529         call etotal_short(energia)
10530 !el        call enerprint(energia)
10531         call flush(iout)
10532         write (iout,*) "enter cartgrad"
10533         call flush(iout)
10534         call cartgrad
10535         write (iout,*) "exit cartgrad"
10536         call flush(iout)
10537         icall =1
10538         write (iout,*) "shortrange grad"
10539         do i=1,nres
10540           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10541           (gxcart(j,i),j=1,3)
10542         enddo
10543         do j=1,3
10544           grad_s1(j,0)=gcart(j,0)
10545         enddo
10546         do i=1,nres
10547           do j=1,3
10548             grad_s1(j,i)=gcart(j,i)
10549             grad_s1(j+3,i)=gxcart(j,i)
10550           enddo
10551         enddo
10552       endif
10553       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10554 !      do i=1,nres
10555       do i=nnt,nct
10556         do j=1,3
10557           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10558           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10559           ddc(j)=c(j,i)
10560           ddx(j)=c(j,i+nres)
10561           dcnorm_safe1(j)=dc_norm(j,i-1)
10562           dcnorm_safe2(j)=dc_norm(j,i)
10563           dxnorm_safe(j)=dc_norm(j,i+nres)
10564         enddo
10565         do j=1,3
10566           c(j,i)=ddc(j)+aincr
10567           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10568           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10569           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10570           dc(j,i)=c(j,i+1)-c(j,i)
10571           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10572           call int_from_cart1(.false.)
10573           if (.not.split_ene) then
10574             call etotal(energia1)
10575             etot1=energia1(0)
10576             write (iout,*) "ij",i,j," etot1",etot1
10577           else
10578 !- split gradient
10579             call etotal_long(energia1)
10580             etot11=energia1(0)
10581             call etotal_short(energia1)
10582             etot12=energia1(0)
10583           endif
10584 !- end split gradient
10585 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10586           c(j,i)=ddc(j)-aincr
10587           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10588           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10589           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10590           dc(j,i)=c(j,i+1)-c(j,i)
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             write (iout,*) "ij",i,j," etot2",etot2
10597             ggg(j)=(etot1-etot2)/(2*aincr)
10598           else
10599 !- split gradient
10600             call etotal_long(energia1)
10601             etot21=energia1(0)
10602             ggg(j)=(etot11-etot21)/(2*aincr)
10603             call etotal_short(energia1)
10604             etot22=energia1(0)
10605             ggg1(j)=(etot12-etot22)/(2*aincr)
10606 !- end split gradient
10607 !            write (iout,*) "etot21",etot21," etot22",etot22
10608           endif
10609 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10610           c(j,i)=ddc(j)
10611           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10612           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10613           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10614           dc(j,i)=c(j,i+1)-c(j,i)
10615           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10616           dc_norm(j,i-1)=dcnorm_safe1(j)
10617           dc_norm(j,i)=dcnorm_safe2(j)
10618           dc_norm(j,i+nres)=dxnorm_safe(j)
10619         enddo
10620         do j=1,3
10621           c(j,i+nres)=ddx(j)+aincr
10622           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10623           call int_from_cart1(.false.)
10624           if (.not.split_ene) then
10625             call etotal(energia1)
10626             etot1=energia1(0)
10627           else
10628 !- split gradient
10629             call etotal_long(energia1)
10630             etot11=energia1(0)
10631             call etotal_short(energia1)
10632             etot12=energia1(0)
10633           endif
10634 !- end split gradient
10635           c(j,i+nres)=ddx(j)-aincr
10636           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10637           call int_from_cart1(.false.)
10638           if (.not.split_ene) then
10639             call etotal(energia1)
10640             etot2=energia1(0)
10641             ggg(j+3)=(etot1-etot2)/(2*aincr)
10642           else
10643 !- split gradient
10644             call etotal_long(energia1)
10645             etot21=energia1(0)
10646             ggg(j+3)=(etot11-etot21)/(2*aincr)
10647             call etotal_short(energia1)
10648             etot22=energia1(0)
10649             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10650 !- end split gradient
10651           endif
10652 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10653           c(j,i+nres)=ddx(j)
10654           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10655           dc_norm(j,i+nres)=dxnorm_safe(j)
10656           call int_from_cart1(.false.)
10657         enddo
10658         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10659          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10660         if (split_ene) then
10661           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10662          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10663          k=1,6)
10664          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10665          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10666          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10667         endif
10668       enddo
10669       return
10670       end subroutine check_ecartint
10671 #else
10672 !-----------------------------------------------------------------------------
10673       subroutine check_ecartint
10674 ! Check the gradient of the energy in Cartesian coordinates.
10675       use io_base, only: intout
10676 !      implicit real*8 (a-h,o-z)
10677 !      include 'DIMENSIONS'
10678 !      include 'COMMON.CONTROL'
10679 !      include 'COMMON.CHAIN'
10680 !      include 'COMMON.DERIV'
10681 !      include 'COMMON.IOUNITS'
10682 !      include 'COMMON.VAR'
10683 !      include 'COMMON.CONTACTS'
10684 !      include 'COMMON.MD'
10685 !      include 'COMMON.LOCAL'
10686 !      include 'COMMON.SPLITELE'
10687       use comm_srutu
10688 !el      integer :: icall
10689 !el      common /srutu/ icall
10690       real(kind=8),dimension(6) :: ggg,ggg1
10691       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10692       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10693       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10694       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10695       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10696       real(kind=8),dimension(0:n_ene) :: energia,energia1
10697       integer :: uiparm(1)
10698       real(kind=8) :: urparm(1)
10699 !EL      external fdum
10700       integer :: i,j,k,nf
10701       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10702                    etot21,etot22
10703       r_cut=2.0d0
10704       rlambd=0.3d0
10705       icg=1
10706       nf=0
10707       nfl=0
10708       call intout
10709 !      call intcartderiv
10710 !      call checkintcartgrad
10711       call zerograd
10712       aincr=1.0D-6
10713       write(iout,*) 'Calling CHECK_ECARTINT.'
10714       nf=0
10715       icall=0
10716       call geom_to_var(nvar,x)
10717       if (.not.split_ene) then
10718         call etotal(energia)
10719         etot=energia(0)
10720 !el        call enerprint(energia)
10721         call flush(iout)
10722         write (iout,*) "enter cartgrad"
10723         call flush(iout)
10724         call cartgrad
10725         write (iout,*) "exit cartgrad"
10726         call flush(iout)
10727         icall =1
10728         do i=1,nres
10729           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10730         enddo
10731         do j=1,3
10732           grad_s(j,0)=gcart(j,0)
10733         enddo
10734         do i=1,nres
10735           do j=1,3
10736             grad_s(j,i)=gcart(j,i)
10737             grad_s(j+3,i)=gxcart(j,i)
10738           enddo
10739         enddo
10740       else
10741 !- split gradient check
10742         call zerograd
10743         call etotal_long(energia)
10744 !el        call enerprint(energia)
10745         call flush(iout)
10746         write (iout,*) "enter cartgrad"
10747         call flush(iout)
10748         call cartgrad
10749         write (iout,*) "exit cartgrad"
10750         call flush(iout)
10751         icall =1
10752         write (iout,*) "longrange grad"
10753         do i=1,nres
10754           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10755           (gxcart(j,i),j=1,3)
10756         enddo
10757         do j=1,3
10758           grad_s(j,0)=gcart(j,0)
10759         enddo
10760         do i=1,nres
10761           do j=1,3
10762             grad_s(j,i)=gcart(j,i)
10763             grad_s(j+3,i)=gxcart(j,i)
10764           enddo
10765         enddo
10766         call zerograd
10767         call etotal_short(energia)
10768 !el        call enerprint(energia)
10769         call flush(iout)
10770         write (iout,*) "enter cartgrad"
10771         call flush(iout)
10772         call cartgrad
10773         write (iout,*) "exit cartgrad"
10774         call flush(iout)
10775         icall =1
10776         write (iout,*) "shortrange grad"
10777         do i=1,nres
10778           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10779           (gxcart(j,i),j=1,3)
10780         enddo
10781         do j=1,3
10782           grad_s1(j,0)=gcart(j,0)
10783         enddo
10784         do i=1,nres
10785           do j=1,3
10786             grad_s1(j,i)=gcart(j,i)
10787             grad_s1(j+3,i)=gxcart(j,i)
10788           enddo
10789         enddo
10790       endif
10791       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10792       do i=0,nres
10793         do j=1,3
10794           xx(j)=c(j,i+nres)
10795           ddc(j)=dc(j,i)
10796           ddx(j)=dc(j,i+nres)
10797           do k=1,3
10798             dcnorm_safe(k)=dc_norm(k,i)
10799             dxnorm_safe(k)=dc_norm(k,i+nres)
10800           enddo
10801         enddo
10802         do j=1,3
10803           dc(j,i)=ddc(j)+aincr
10804           call chainbuild_cart
10805 #ifdef MPI
10806 ! Broadcast the order to compute internal coordinates to the slaves.
10807 !          if (nfgtasks.gt.1)
10808 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10809 #endif
10810 !          call int_from_cart1(.false.)
10811           if (.not.split_ene) then
10812             call etotal(energia1)
10813             etot1=energia1(0)
10814           else
10815 !- split gradient
10816             call etotal_long(energia1)
10817             etot11=energia1(0)
10818             call etotal_short(energia1)
10819             etot12=energia1(0)
10820 !            write (iout,*) "etot11",etot11," etot12",etot12
10821           endif
10822 !- end split gradient
10823 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10824           dc(j,i)=ddc(j)-aincr
10825           call chainbuild_cart
10826 !          call int_from_cart1(.false.)
10827           if (.not.split_ene) then
10828             call etotal(energia1)
10829             etot2=energia1(0)
10830             ggg(j)=(etot1-etot2)/(2*aincr)
10831           else
10832 !- split gradient
10833             call etotal_long(energia1)
10834             etot21=energia1(0)
10835             ggg(j)=(etot11-etot21)/(2*aincr)
10836             call etotal_short(energia1)
10837             etot22=energia1(0)
10838             ggg1(j)=(etot12-etot22)/(2*aincr)
10839 !- end split gradient
10840 !            write (iout,*) "etot21",etot21," etot22",etot22
10841           endif
10842 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10843           dc(j,i)=ddc(j)
10844           call chainbuild_cart
10845         enddo
10846         do j=1,3
10847           dc(j,i+nres)=ddx(j)+aincr
10848           call chainbuild_cart
10849 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10850 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10851 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10852 !          write (iout,*) "dxnormnorm",dsqrt(
10853 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10854 !          write (iout,*) "dxnormnormsafe",dsqrt(
10855 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10856 !          write (iout,*)
10857           if (.not.split_ene) then
10858             call etotal(energia1)
10859             etot1=energia1(0)
10860           else
10861 !- split gradient
10862             call etotal_long(energia1)
10863             etot11=energia1(0)
10864             call etotal_short(energia1)
10865             etot12=energia1(0)
10866           endif
10867 !- end split gradient
10868 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10869           dc(j,i+nres)=ddx(j)-aincr
10870           call chainbuild_cart
10871 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10872 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10873 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10874 !          write (iout,*)
10875 !          write (iout,*) "dxnormnorm",dsqrt(
10876 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10877 !          write (iout,*) "dxnormnormsafe",dsqrt(
10878 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10879           if (.not.split_ene) then
10880             call etotal(energia1)
10881             etot2=energia1(0)
10882             ggg(j+3)=(etot1-etot2)/(2*aincr)
10883           else
10884 !- split gradient
10885             call etotal_long(energia1)
10886             etot21=energia1(0)
10887             ggg(j+3)=(etot11-etot21)/(2*aincr)
10888             call etotal_short(energia1)
10889             etot22=energia1(0)
10890             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10891 !- end split gradient
10892           endif
10893 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10894           dc(j,i+nres)=ddx(j)
10895           call chainbuild_cart
10896         enddo
10897         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10898          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10899         if (split_ene) then
10900           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10901          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10902          k=1,6)
10903          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10904          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10905          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10906         endif
10907       enddo
10908       return
10909       end subroutine check_ecartint
10910 #endif
10911 !-----------------------------------------------------------------------------
10912       subroutine check_eint
10913 ! Check the gradient of energy in internal coordinates.
10914 !      implicit real*8 (a-h,o-z)
10915 !      include 'DIMENSIONS'
10916 !      include 'COMMON.CHAIN'
10917 !      include 'COMMON.DERIV'
10918 !      include 'COMMON.IOUNITS'
10919 !      include 'COMMON.VAR'
10920 !      include 'COMMON.GEO'
10921       use comm_srutu
10922 !el      integer :: icall
10923 !el      common /srutu/ icall
10924       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10925       integer :: uiparm(1)
10926       real(kind=8) :: urparm(1)
10927       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10928       character(len=6) :: key
10929 !EL      external fdum
10930       integer :: i,ii,nf
10931       real(kind=8) :: xi,aincr,etot,etot1,etot2
10932       call zerograd
10933       aincr=1.0D-7
10934       print '(a)','Calling CHECK_INT.'
10935       nf=0
10936       nfl=0
10937       icg=1
10938       call geom_to_var(nvar,x)
10939       call var_to_geom(nvar,x)
10940       call chainbuild
10941       icall=1
10942       print *,'ICG=',ICG
10943       call etotal(energia)
10944       etot = energia(0)
10945 !el      call enerprint(energia)
10946       print *,'ICG=',ICG
10947 #ifdef MPL
10948       if (MyID.ne.BossID) then
10949         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10950         nf=x(nvar+1)
10951         nfl=x(nvar+2)
10952         icg=x(nvar+3)
10953       endif
10954 #endif
10955       nf=1
10956       nfl=3
10957 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10958       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10959 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10960       icall=1
10961       do i=1,nvar
10962         xi=x(i)
10963         x(i)=xi-0.5D0*aincr
10964         call var_to_geom(nvar,x)
10965         call chainbuild
10966         call etotal(energia1)
10967         etot1=energia1(0)
10968         x(i)=xi+0.5D0*aincr
10969         call var_to_geom(nvar,x)
10970         call chainbuild
10971         call etotal(energia2)
10972         etot2=energia2(0)
10973         gg(i)=(etot2-etot1)/aincr
10974         write (iout,*) i,etot1,etot2
10975         x(i)=xi
10976       enddo
10977       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10978           '     RelDiff*100% '
10979       do i=1,nvar
10980         if (i.le.nphi) then
10981           ii=i
10982           key = ' phi'
10983         else if (i.le.nphi+ntheta) then
10984           ii=i-nphi
10985           key=' theta'
10986         else if (i.le.nphi+ntheta+nside) then
10987            ii=i-(nphi+ntheta)
10988            key=' alpha'
10989         else
10990            ii=i-(nphi+ntheta+nside)
10991            key=' omega'
10992         endif
10993         write (iout,'(i3,a,i3,3(1pd16.6))') &
10994        i,key,ii,gg(i),gana(i),&
10995        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10996       enddo
10997       return
10998       end subroutine check_eint
10999 !-----------------------------------------------------------------------------
11000 ! econstr_local.F
11001 !-----------------------------------------------------------------------------
11002       subroutine Econstr_back
11003 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11004 !      implicit real*8 (a-h,o-z)
11005 !      include 'DIMENSIONS'
11006 !      include 'COMMON.CONTROL'
11007 !      include 'COMMON.VAR'
11008 !      include 'COMMON.MD'
11009       use MD_data
11010 !#ifndef LANG0
11011 !      include 'COMMON.LANGEVIN'
11012 !#else
11013 !      include 'COMMON.LANGEVIN.lang0'
11014 !#endif
11015 !      include 'COMMON.CHAIN'
11016 !      include 'COMMON.DERIV'
11017 !      include 'COMMON.GEO'
11018 !      include 'COMMON.LOCAL'
11019 !      include 'COMMON.INTERACT'
11020 !      include 'COMMON.IOUNITS'
11021 !      include 'COMMON.NAMES'
11022 !      include 'COMMON.TIME1'
11023       integer :: i,j,ii,k
11024       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11025
11026       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11027       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11028       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11029
11030       Uconst_back=0.0d0
11031       do i=1,nres
11032         dutheta(i)=0.0d0
11033         dugamma(i)=0.0d0
11034         do j=1,3
11035           duscdiff(j,i)=0.0d0
11036           duscdiffx(j,i)=0.0d0
11037         enddo
11038       enddo
11039       do i=1,nfrag_back
11040         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11041 !
11042 ! Deviations from theta angles
11043 !
11044         utheta_i=0.0d0
11045         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11046           dtheta_i=theta(j)-thetaref(j)
11047           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11048           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11049         enddo
11050         utheta(i)=utheta_i/(ii-1)
11051 !
11052 ! Deviations from gamma angles
11053 !
11054         ugamma_i=0.0d0
11055         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11056           dgamma_i=pinorm(phi(j)-phiref(j))
11057 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11058           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11059           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11060 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11061         enddo
11062         ugamma(i)=ugamma_i/(ii-2)
11063 !
11064 ! Deviations from local SC geometry
11065 !
11066         uscdiff(i)=0.0d0
11067         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11068           dxx=xxtab(j)-xxref(j)
11069           dyy=yytab(j)-yyref(j)
11070           dzz=zztab(j)-zzref(j)
11071           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11072           do k=1,3
11073             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11074              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11075              (ii-1)
11076             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11077              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11078              (ii-1)
11079             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11080            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11081             /(ii-1)
11082           enddo
11083 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11084 !     &      xxref(j),yyref(j),zzref(j)
11085         enddo
11086         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11087 !        write (iout,*) i," uscdiff",uscdiff(i)
11088 !
11089 ! Put together deviations from local geometry
11090 !
11091         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11092           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11093 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11094 !     &   " uconst_back",uconst_back
11095         utheta(i)=dsqrt(utheta(i))
11096         ugamma(i)=dsqrt(ugamma(i))
11097         uscdiff(i)=dsqrt(uscdiff(i))
11098       enddo
11099       return
11100       end subroutine Econstr_back
11101 !-----------------------------------------------------------------------------
11102 ! energy_p_new-sep_barrier.F
11103 !-----------------------------------------------------------------------------
11104       real(kind=8) function sscale(r)
11105 !      include "COMMON.SPLITELE"
11106       real(kind=8) :: r,gamm
11107       if(r.lt.r_cut-rlamb) then
11108         sscale=1.0d0
11109       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11110         gamm=(r-(r_cut-rlamb))/rlamb
11111         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11112       else
11113         sscale=0d0
11114       endif
11115       return
11116       end function sscale
11117       real(kind=8) function sscale_grad(r)
11118 !      include "COMMON.SPLITELE"
11119       real(kind=8) :: r,gamm
11120       if(r.lt.r_cut-rlamb) then
11121         sscale_grad=0.0d0
11122       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11123         gamm=(r-(r_cut-rlamb))/rlamb
11124         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11125       else
11126         sscale_grad=0d0
11127       endif
11128       return
11129       end function sscale_grad
11130
11131 !!!!!!!!!! PBCSCALE
11132       real(kind=8) function sscale_ele(r)
11133 !      include "COMMON.SPLITELE"
11134       real(kind=8) :: r,gamm
11135       if(r.lt.r_cut_ele-rlamb_ele) then
11136         sscale_ele=1.0d0
11137       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11138         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11139         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11140       else
11141         sscale_ele=0d0
11142       endif
11143       return
11144       end function sscale_ele
11145
11146       real(kind=8)  function sscagrad_ele(r)
11147       real(kind=8) :: r,gamm
11148 !      include "COMMON.SPLITELE"
11149       if(r.lt.r_cut_ele-rlamb_ele) then
11150         sscagrad_ele=0.0d0
11151       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11152         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11153         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11154       else
11155         sscagrad_ele=0.0d0
11156       endif
11157       return
11158       end function sscagrad_ele
11159 !!!!!!!!!!!!!!!
11160 !-----------------------------------------------------------------------------
11161       subroutine elj_long(evdw)
11162 !
11163 ! This subroutine calculates the interaction energy of nonbonded side chains
11164 ! assuming the LJ potential of interaction.
11165 !
11166 !      implicit real*8 (a-h,o-z)
11167 !      include 'DIMENSIONS'
11168 !      include 'COMMON.GEO'
11169 !      include 'COMMON.VAR'
11170 !      include 'COMMON.LOCAL'
11171 !      include 'COMMON.CHAIN'
11172 !      include 'COMMON.DERIV'
11173 !      include 'COMMON.INTERACT'
11174 !      include 'COMMON.TORSION'
11175 !      include 'COMMON.SBRIDGE'
11176 !      include 'COMMON.NAMES'
11177 !      include 'COMMON.IOUNITS'
11178 !      include 'COMMON.CONTACTS'
11179       real(kind=8),parameter :: accur=1.0d-10
11180       real(kind=8),dimension(3) :: gg
11181 !el local variables
11182       integer :: i,iint,j,k,itypi,itypi1,itypj
11183       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11184       real(kind=8) :: e1,e2,evdwij,evdw
11185 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11186       evdw=0.0D0
11187       do i=iatsc_s,iatsc_e
11188         itypi=itype(i)
11189         if (itypi.eq.ntyp1) cycle
11190         itypi1=itype(i+1)
11191         xi=c(1,nres+i)
11192         yi=c(2,nres+i)
11193         zi=c(3,nres+i)
11194 !
11195 ! Calculate SC interaction energy.
11196 !
11197         do iint=1,nint_gr(i)
11198 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11199 !d   &                  'iend=',iend(i,iint)
11200           do j=istart(i,iint),iend(i,iint)
11201             itypj=itype(j)
11202             if (itypj.eq.ntyp1) cycle
11203             xj=c(1,nres+j)-xi
11204             yj=c(2,nres+j)-yi
11205             zj=c(3,nres+j)-zi
11206             rij=xj*xj+yj*yj+zj*zj
11207             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11208             if (sss.lt.1.0d0) then
11209               rrij=1.0D0/rij
11210               eps0ij=eps(itypi,itypj)
11211               fac=rrij**expon2
11212               e1=fac*fac*aa(itypi,itypj)
11213               e2=fac*bb(itypi,itypj)
11214               evdwij=e1+e2
11215               evdw=evdw+(1.0d0-sss)*evdwij
11216 !
11217 ! Calculate the components of the gradient in DC and X
11218 !
11219               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11220               gg(1)=xj*fac
11221               gg(2)=yj*fac
11222               gg(3)=zj*fac
11223               do k=1,3
11224                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11225                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11226                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11227                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11228               enddo
11229             endif
11230           enddo      ! j
11231         enddo        ! iint
11232       enddo          ! i
11233       do i=1,nct
11234         do j=1,3
11235           gvdwc(j,i)=expon*gvdwc(j,i)
11236           gvdwx(j,i)=expon*gvdwx(j,i)
11237         enddo
11238       enddo
11239 !******************************************************************************
11240 !
11241 !                              N O T E !!!
11242 !
11243 ! To save time, the factor of EXPON has been extracted from ALL components
11244 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11245 ! use!
11246 !
11247 !******************************************************************************
11248       return
11249       end subroutine elj_long
11250 !-----------------------------------------------------------------------------
11251       subroutine elj_short(evdw)
11252 !
11253 ! This subroutine calculates the interaction energy of nonbonded side chains
11254 ! assuming the LJ potential of interaction.
11255 !
11256 !      implicit real*8 (a-h,o-z)
11257 !      include 'DIMENSIONS'
11258 !      include 'COMMON.GEO'
11259 !      include 'COMMON.VAR'
11260 !      include 'COMMON.LOCAL'
11261 !      include 'COMMON.CHAIN'
11262 !      include 'COMMON.DERIV'
11263 !      include 'COMMON.INTERACT'
11264 !      include 'COMMON.TORSION'
11265 !      include 'COMMON.SBRIDGE'
11266 !      include 'COMMON.NAMES'
11267 !      include 'COMMON.IOUNITS'
11268 !      include 'COMMON.CONTACTS'
11269       real(kind=8),parameter :: accur=1.0d-10
11270       real(kind=8),dimension(3) :: gg
11271 !el local variables
11272       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11273       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11274       real(kind=8) :: e1,e2,evdwij,evdw
11275 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11276       evdw=0.0D0
11277       do i=iatsc_s,iatsc_e
11278         itypi=itype(i)
11279         if (itypi.eq.ntyp1) cycle
11280         itypi1=itype(i+1)
11281         xi=c(1,nres+i)
11282         yi=c(2,nres+i)
11283         zi=c(3,nres+i)
11284 ! Change 12/1/95
11285         num_conti=0
11286 !
11287 ! Calculate SC interaction energy.
11288 !
11289         do iint=1,nint_gr(i)
11290 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11291 !d   &                  'iend=',iend(i,iint)
11292           do j=istart(i,iint),iend(i,iint)
11293             itypj=itype(j)
11294             if (itypj.eq.ntyp1) cycle
11295             xj=c(1,nres+j)-xi
11296             yj=c(2,nres+j)-yi
11297             zj=c(3,nres+j)-zi
11298 ! Change 12/1/95 to calculate four-body interactions
11299             rij=xj*xj+yj*yj+zj*zj
11300             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11301             if (sss.gt.0.0d0) then
11302               rrij=1.0D0/rij
11303               eps0ij=eps(itypi,itypj)
11304               fac=rrij**expon2
11305               e1=fac*fac*aa(itypi,itypj)
11306               e2=fac*bb(itypi,itypj)
11307               evdwij=e1+e2
11308               evdw=evdw+sss*evdwij
11309 !
11310 ! Calculate the components of the gradient in DC and X
11311 !
11312               fac=-rrij*(e1+evdwij)*sss
11313               gg(1)=xj*fac
11314               gg(2)=yj*fac
11315               gg(3)=zj*fac
11316               do k=1,3
11317                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11318                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11319                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11320                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11321               enddo
11322             endif
11323           enddo      ! j
11324         enddo        ! iint
11325       enddo          ! i
11326       do i=1,nct
11327         do j=1,3
11328           gvdwc(j,i)=expon*gvdwc(j,i)
11329           gvdwx(j,i)=expon*gvdwx(j,i)
11330         enddo
11331       enddo
11332 !******************************************************************************
11333 !
11334 !                              N O T E !!!
11335 !
11336 ! To save time, the factor of EXPON has been extracted from ALL components
11337 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11338 ! use!
11339 !
11340 !******************************************************************************
11341       return
11342       end subroutine elj_short
11343 !-----------------------------------------------------------------------------
11344       subroutine eljk_long(evdw)
11345 !
11346 ! This subroutine calculates the interaction energy of nonbonded side chains
11347 ! assuming the LJK potential of interaction.
11348 !
11349 !      implicit real*8 (a-h,o-z)
11350 !      include 'DIMENSIONS'
11351 !      include 'COMMON.GEO'
11352 !      include 'COMMON.VAR'
11353 !      include 'COMMON.LOCAL'
11354 !      include 'COMMON.CHAIN'
11355 !      include 'COMMON.DERIV'
11356 !      include 'COMMON.INTERACT'
11357 !      include 'COMMON.IOUNITS'
11358 !      include 'COMMON.NAMES'
11359       real(kind=8),dimension(3) :: gg
11360       logical :: scheck
11361 !el local variables
11362       integer :: i,iint,j,k,itypi,itypi1,itypj
11363       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11364                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11365 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11366       evdw=0.0D0
11367       do i=iatsc_s,iatsc_e
11368         itypi=itype(i)
11369         if (itypi.eq.ntyp1) cycle
11370         itypi1=itype(i+1)
11371         xi=c(1,nres+i)
11372         yi=c(2,nres+i)
11373         zi=c(3,nres+i)
11374 !
11375 ! Calculate SC interaction energy.
11376 !
11377         do iint=1,nint_gr(i)
11378           do j=istart(i,iint),iend(i,iint)
11379             itypj=itype(j)
11380             if (itypj.eq.ntyp1) cycle
11381             xj=c(1,nres+j)-xi
11382             yj=c(2,nres+j)-yi
11383             zj=c(3,nres+j)-zi
11384             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11385             fac_augm=rrij**expon
11386             e_augm=augm(itypi,itypj)*fac_augm
11387             r_inv_ij=dsqrt(rrij)
11388             rij=1.0D0/r_inv_ij
11389             sss=sscale(rij/sigma(itypi,itypj))
11390             if (sss.lt.1.0d0) then
11391               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11392               fac=r_shift_inv**expon
11393               e1=fac*fac*aa(itypi,itypj)
11394               e2=fac*bb(itypi,itypj)
11395               evdwij=e_augm+e1+e2
11396 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11397 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11398 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11399 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11400 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11401 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11402 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11403               evdw=evdw+(1.0d0-sss)*evdwij
11404 !
11405 ! Calculate the components of the gradient in DC and X
11406 !
11407               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11408               fac=fac*(1.0d0-sss)
11409               gg(1)=xj*fac
11410               gg(2)=yj*fac
11411               gg(3)=zj*fac
11412               do k=1,3
11413                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11414                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11415                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11416                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11417               enddo
11418             endif
11419           enddo      ! j
11420         enddo        ! iint
11421       enddo          ! i
11422       do i=1,nct
11423         do j=1,3
11424           gvdwc(j,i)=expon*gvdwc(j,i)
11425           gvdwx(j,i)=expon*gvdwx(j,i)
11426         enddo
11427       enddo
11428       return
11429       end subroutine eljk_long
11430 !-----------------------------------------------------------------------------
11431       subroutine eljk_short(evdw)
11432 !
11433 ! This subroutine calculates the interaction energy of nonbonded side chains
11434 ! assuming the LJK potential of interaction.
11435 !
11436 !      implicit real*8 (a-h,o-z)
11437 !      include 'DIMENSIONS'
11438 !      include 'COMMON.GEO'
11439 !      include 'COMMON.VAR'
11440 !      include 'COMMON.LOCAL'
11441 !      include 'COMMON.CHAIN'
11442 !      include 'COMMON.DERIV'
11443 !      include 'COMMON.INTERACT'
11444 !      include 'COMMON.IOUNITS'
11445 !      include 'COMMON.NAMES'
11446       real(kind=8),dimension(3) :: gg
11447       logical :: scheck
11448 !el local variables
11449       integer :: i,iint,j,k,itypi,itypi1,itypj
11450       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11451                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11452 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11453       evdw=0.0D0
11454       do i=iatsc_s,iatsc_e
11455         itypi=itype(i)
11456         if (itypi.eq.ntyp1) cycle
11457         itypi1=itype(i+1)
11458         xi=c(1,nres+i)
11459         yi=c(2,nres+i)
11460         zi=c(3,nres+i)
11461 !
11462 ! Calculate SC interaction energy.
11463 !
11464         do iint=1,nint_gr(i)
11465           do j=istart(i,iint),iend(i,iint)
11466             itypj=itype(j)
11467             if (itypj.eq.ntyp1) cycle
11468             xj=c(1,nres+j)-xi
11469             yj=c(2,nres+j)-yi
11470             zj=c(3,nres+j)-zi
11471             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11472             fac_augm=rrij**expon
11473             e_augm=augm(itypi,itypj)*fac_augm
11474             r_inv_ij=dsqrt(rrij)
11475             rij=1.0D0/r_inv_ij
11476             sss=sscale(rij/sigma(itypi,itypj))
11477             if (sss.gt.0.0d0) then
11478               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11479               fac=r_shift_inv**expon
11480               e1=fac*fac*aa(itypi,itypj)
11481               e2=fac*bb(itypi,itypj)
11482               evdwij=e_augm+e1+e2
11483 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11484 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11485 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11486 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11487 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11488 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11489 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11490               evdw=evdw+sss*evdwij
11491 !
11492 ! Calculate the components of the gradient in DC and X
11493 !
11494               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11495               fac=fac*sss
11496               gg(1)=xj*fac
11497               gg(2)=yj*fac
11498               gg(3)=zj*fac
11499               do k=1,3
11500                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11501                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11502                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11503                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11504               enddo
11505             endif
11506           enddo      ! j
11507         enddo        ! iint
11508       enddo          ! i
11509       do i=1,nct
11510         do j=1,3
11511           gvdwc(j,i)=expon*gvdwc(j,i)
11512           gvdwx(j,i)=expon*gvdwx(j,i)
11513         enddo
11514       enddo
11515       return
11516       end subroutine eljk_short
11517 !-----------------------------------------------------------------------------
11518       subroutine ebp_long(evdw)
11519 !
11520 ! This subroutine calculates the interaction energy of nonbonded side chains
11521 ! assuming the Berne-Pechukas potential of interaction.
11522 !
11523       use calc_data
11524 !      implicit real*8 (a-h,o-z)
11525 !      include 'DIMENSIONS'
11526 !      include 'COMMON.GEO'
11527 !      include 'COMMON.VAR'
11528 !      include 'COMMON.LOCAL'
11529 !      include 'COMMON.CHAIN'
11530 !      include 'COMMON.DERIV'
11531 !      include 'COMMON.NAMES'
11532 !      include 'COMMON.INTERACT'
11533 !      include 'COMMON.IOUNITS'
11534 !      include 'COMMON.CALC'
11535       use comm_srutu
11536 !el      integer :: icall
11537 !el      common /srutu/ icall
11538 !     double precision rrsave(maxdim)
11539       logical :: lprn
11540 !el local variables
11541       integer :: iint,itypi,itypi1,itypj
11542       real(kind=8) :: rrij,xi,yi,zi,fac
11543       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11544       evdw=0.0D0
11545 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11546       evdw=0.0D0
11547 !     if (icall.eq.0) then
11548 !       lprn=.true.
11549 !     else
11550         lprn=.false.
11551 !     endif
11552 !el      ind=0
11553       do i=iatsc_s,iatsc_e
11554         itypi=itype(i)
11555         if (itypi.eq.ntyp1) cycle
11556         itypi1=itype(i+1)
11557         xi=c(1,nres+i)
11558         yi=c(2,nres+i)
11559         zi=c(3,nres+i)
11560         dxi=dc_norm(1,nres+i)
11561         dyi=dc_norm(2,nres+i)
11562         dzi=dc_norm(3,nres+i)
11563 !        dsci_inv=dsc_inv(itypi)
11564         dsci_inv=vbld_inv(i+nres)
11565 !
11566 ! Calculate SC interaction energy.
11567 !
11568         do iint=1,nint_gr(i)
11569           do j=istart(i,iint),iend(i,iint)
11570 !el            ind=ind+1
11571             itypj=itype(j)
11572             if (itypj.eq.ntyp1) cycle
11573 !            dscj_inv=dsc_inv(itypj)
11574             dscj_inv=vbld_inv(j+nres)
11575             chi1=chi(itypi,itypj)
11576             chi2=chi(itypj,itypi)
11577             chi12=chi1*chi2
11578             chip1=chip(itypi)
11579             chip2=chip(itypj)
11580             chip12=chip1*chip2
11581             alf1=alp(itypi)
11582             alf2=alp(itypj)
11583             alf12=0.5D0*(alf1+alf2)
11584             xj=c(1,nres+j)-xi
11585             yj=c(2,nres+j)-yi
11586             zj=c(3,nres+j)-zi
11587             dxj=dc_norm(1,nres+j)
11588             dyj=dc_norm(2,nres+j)
11589             dzj=dc_norm(3,nres+j)
11590             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11591             rij=dsqrt(rrij)
11592             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11593
11594             if (sss.lt.1.0d0) then
11595
11596 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11597               call sc_angular
11598 ! Calculate whole angle-dependent part of epsilon and contributions
11599 ! to its derivatives
11600               fac=(rrij*sigsq)**expon2
11601               e1=fac*fac*aa(itypi,itypj)
11602               e2=fac*bb(itypi,itypj)
11603               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11604               eps2der=evdwij*eps3rt
11605               eps3der=evdwij*eps2rt
11606               evdwij=evdwij*eps2rt*eps3rt
11607               evdw=evdw+evdwij*(1.0d0-sss)
11608               if (lprn) then
11609               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11610               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11611 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11612 !d     &          restyp(itypi),i,restyp(itypj),j,
11613 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11614 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11615 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11616 !d     &          evdwij
11617               endif
11618 ! Calculate gradient components.
11619               e1=e1*eps1*eps2rt**2*eps3rt**2
11620               fac=-expon*(e1+evdwij)
11621               sigder=fac/sigsq
11622               fac=rrij*fac
11623 ! Calculate radial part of the gradient
11624               gg(1)=xj*fac
11625               gg(2)=yj*fac
11626               gg(3)=zj*fac
11627 ! Calculate the angular part of the gradient and sum add the contributions
11628 ! to the appropriate components of the Cartesian gradient.
11629               call sc_grad_scale(1.0d0-sss)
11630             endif
11631           enddo      ! j
11632         enddo        ! iint
11633       enddo          ! i
11634 !     stop
11635       return
11636       end subroutine ebp_long
11637 !-----------------------------------------------------------------------------
11638       subroutine ebp_short(evdw)
11639 !
11640 ! This subroutine calculates the interaction energy of nonbonded side chains
11641 ! assuming the Berne-Pechukas potential of interaction.
11642 !
11643       use calc_data
11644 !      implicit real*8 (a-h,o-z)
11645 !      include 'DIMENSIONS'
11646 !      include 'COMMON.GEO'
11647 !      include 'COMMON.VAR'
11648 !      include 'COMMON.LOCAL'
11649 !      include 'COMMON.CHAIN'
11650 !      include 'COMMON.DERIV'
11651 !      include 'COMMON.NAMES'
11652 !      include 'COMMON.INTERACT'
11653 !      include 'COMMON.IOUNITS'
11654 !      include 'COMMON.CALC'
11655       use comm_srutu
11656 !el      integer :: icall
11657 !el      common /srutu/ icall
11658 !     double precision rrsave(maxdim)
11659       logical :: lprn
11660 !el local variables
11661       integer :: iint,itypi,itypi1,itypj
11662       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11663       real(kind=8) :: sss,e1,e2,evdw
11664       evdw=0.0D0
11665 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11666       evdw=0.0D0
11667 !     if (icall.eq.0) then
11668 !       lprn=.true.
11669 !     else
11670         lprn=.false.
11671 !     endif
11672 !el      ind=0
11673       do i=iatsc_s,iatsc_e
11674         itypi=itype(i)
11675         if (itypi.eq.ntyp1) cycle
11676         itypi1=itype(i+1)
11677         xi=c(1,nres+i)
11678         yi=c(2,nres+i)
11679         zi=c(3,nres+i)
11680         dxi=dc_norm(1,nres+i)
11681         dyi=dc_norm(2,nres+i)
11682         dzi=dc_norm(3,nres+i)
11683 !        dsci_inv=dsc_inv(itypi)
11684         dsci_inv=vbld_inv(i+nres)
11685 !
11686 ! Calculate SC interaction energy.
11687 !
11688         do iint=1,nint_gr(i)
11689           do j=istart(i,iint),iend(i,iint)
11690 !el            ind=ind+1
11691             itypj=itype(j)
11692             if (itypj.eq.ntyp1) cycle
11693 !            dscj_inv=dsc_inv(itypj)
11694             dscj_inv=vbld_inv(j+nres)
11695             chi1=chi(itypi,itypj)
11696             chi2=chi(itypj,itypi)
11697             chi12=chi1*chi2
11698             chip1=chip(itypi)
11699             chip2=chip(itypj)
11700             chip12=chip1*chip2
11701             alf1=alp(itypi)
11702             alf2=alp(itypj)
11703             alf12=0.5D0*(alf1+alf2)
11704             xj=c(1,nres+j)-xi
11705             yj=c(2,nres+j)-yi
11706             zj=c(3,nres+j)-zi
11707             dxj=dc_norm(1,nres+j)
11708             dyj=dc_norm(2,nres+j)
11709             dzj=dc_norm(3,nres+j)
11710             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11711             rij=dsqrt(rrij)
11712             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11713
11714             if (sss.gt.0.0d0) then
11715
11716 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11717               call sc_angular
11718 ! Calculate whole angle-dependent part of epsilon and contributions
11719 ! to its derivatives
11720               fac=(rrij*sigsq)**expon2
11721               e1=fac*fac*aa(itypi,itypj)
11722               e2=fac*bb(itypi,itypj)
11723               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11724               eps2der=evdwij*eps3rt
11725               eps3der=evdwij*eps2rt
11726               evdwij=evdwij*eps2rt*eps3rt
11727               evdw=evdw+evdwij*sss
11728               if (lprn) then
11729               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11730               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11731 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11732 !d     &          restyp(itypi),i,restyp(itypj),j,
11733 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11734 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11735 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11736 !d     &          evdwij
11737               endif
11738 ! Calculate gradient components.
11739               e1=e1*eps1*eps2rt**2*eps3rt**2
11740               fac=-expon*(e1+evdwij)
11741               sigder=fac/sigsq
11742               fac=rrij*fac
11743 ! Calculate radial part of the gradient
11744               gg(1)=xj*fac
11745               gg(2)=yj*fac
11746               gg(3)=zj*fac
11747 ! Calculate the angular part of the gradient and sum add the contributions
11748 ! to the appropriate components of the Cartesian gradient.
11749               call sc_grad_scale(sss)
11750             endif
11751           enddo      ! j
11752         enddo        ! iint
11753       enddo          ! i
11754 !     stop
11755       return
11756       end subroutine ebp_short
11757 !-----------------------------------------------------------------------------
11758       subroutine egb_long(evdw)
11759 !
11760 ! This subroutine calculates the interaction energy of nonbonded side chains
11761 ! assuming the Gay-Berne potential of interaction.
11762 !
11763       use calc_data
11764 !      implicit real*8 (a-h,o-z)
11765 !      include 'DIMENSIONS'
11766 !      include 'COMMON.GEO'
11767 !      include 'COMMON.VAR'
11768 !      include 'COMMON.LOCAL'
11769 !      include 'COMMON.CHAIN'
11770 !      include 'COMMON.DERIV'
11771 !      include 'COMMON.NAMES'
11772 !      include 'COMMON.INTERACT'
11773 !      include 'COMMON.IOUNITS'
11774 !      include 'COMMON.CALC'
11775 !      include 'COMMON.CONTROL'
11776       logical :: lprn
11777 !el local variables
11778       integer :: iint,itypi,itypi1,itypj,subchap
11779       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11780       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11781       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11782                     dist_temp, dist_init
11783
11784       evdw=0.0D0
11785 !cccc      energy_dec=.false.
11786 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11787       evdw=0.0D0
11788       lprn=.false.
11789 !     if (icall.eq.0) lprn=.false.
11790 !el      ind=0
11791       do i=iatsc_s,iatsc_e
11792         itypi=itype(i)
11793         if (itypi.eq.ntyp1) cycle
11794         itypi1=itype(i+1)
11795         xi=c(1,nres+i)
11796         yi=c(2,nres+i)
11797         zi=c(3,nres+i)
11798           xi=mod(xi,boxxsize)
11799           if (xi.lt.0) xi=xi+boxxsize
11800           yi=mod(yi,boxysize)
11801           if (yi.lt.0) yi=yi+boxysize
11802           zi=mod(zi,boxzsize)
11803           if (zi.lt.0) zi=zi+boxzsize
11804         dxi=dc_norm(1,nres+i)
11805         dyi=dc_norm(2,nres+i)
11806         dzi=dc_norm(3,nres+i)
11807 !        dsci_inv=dsc_inv(itypi)
11808         dsci_inv=vbld_inv(i+nres)
11809 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11810 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11811 !
11812 ! Calculate SC interaction energy.
11813 !
11814         do iint=1,nint_gr(i)
11815           do j=istart(i,iint),iend(i,iint)
11816 !el            ind=ind+1
11817             itypj=itype(j)
11818             if (itypj.eq.ntyp1) cycle
11819 !            dscj_inv=dsc_inv(itypj)
11820             dscj_inv=vbld_inv(j+nres)
11821 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11822 !     &       1.0d0/vbld(j+nres)
11823 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11824             sig0ij=sigma(itypi,itypj)
11825             chi1=chi(itypi,itypj)
11826             chi2=chi(itypj,itypi)
11827             chi12=chi1*chi2
11828             chip1=chip(itypi)
11829             chip2=chip(itypj)
11830             chip12=chip1*chip2
11831             alf1=alp(itypi)
11832             alf2=alp(itypj)
11833             alf12=0.5D0*(alf1+alf2)
11834             xj=c(1,nres+j)
11835             yj=c(2,nres+j)
11836             zj=c(3,nres+j)
11837 ! Searching for nearest neighbour
11838           xj=mod(xj,boxxsize)
11839           if (xj.lt.0) xj=xj+boxxsize
11840           yj=mod(yj,boxysize)
11841           if (yj.lt.0) yj=yj+boxysize
11842           zj=mod(zj,boxzsize)
11843           if (zj.lt.0) zj=zj+boxzsize
11844           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11845           xj_safe=xj
11846           yj_safe=yj
11847           zj_safe=zj
11848           subchap=0
11849           do xshift=-1,1
11850           do yshift=-1,1
11851           do zshift=-1,1
11852           xj=xj_safe+xshift*boxxsize
11853           yj=yj_safe+yshift*boxysize
11854           zj=zj_safe+zshift*boxzsize
11855           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11856           if(dist_temp.lt.dist_init) then
11857             dist_init=dist_temp
11858             xj_temp=xj
11859             yj_temp=yj
11860             zj_temp=zj
11861             subchap=1
11862           endif
11863           enddo
11864           enddo
11865           enddo
11866           if (subchap.eq.1) then
11867           xj=xj_temp-xi
11868           yj=yj_temp-yi
11869           zj=zj_temp-zi
11870           else
11871           xj=xj_safe-xi
11872           yj=yj_safe-yi
11873           zj=zj_safe-zi
11874           endif
11875
11876             dxj=dc_norm(1,nres+j)
11877             dyj=dc_norm(2,nres+j)
11878             dzj=dc_norm(3,nres+j)
11879             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11880             rij=dsqrt(rrij)
11881             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11882             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11883             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11884             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11885             if (sss_ele_cut.le.0.0) cycle
11886             if (sss.lt.1.0d0) then
11887
11888 ! Calculate angle-dependent terms of energy and contributions to their
11889 ! derivatives.
11890               call sc_angular
11891               sigsq=1.0D0/sigsq
11892               sig=sig0ij*dsqrt(sigsq)
11893               rij_shift=1.0D0/rij-sig+sig0ij
11894 ! for diagnostics; uncomment
11895 !              rij_shift=1.2*sig0ij
11896 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11897               if (rij_shift.le.0.0D0) then
11898                 evdw=1.0D20
11899 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11900 !d     &          restyp(itypi),i,restyp(itypj),j,
11901 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11902                 return
11903               endif
11904               sigder=-sig*sigsq
11905 !---------------------------------------------------------------
11906               rij_shift=1.0D0/rij_shift
11907               fac=rij_shift**expon
11908               e1=fac*fac*aa(itypi,itypj)
11909               e2=fac*bb(itypi,itypj)
11910               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11911               eps2der=evdwij*eps3rt
11912               eps3der=evdwij*eps2rt
11913 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11914 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11915               evdwij=evdwij*eps2rt*eps3rt
11916               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11917               if (lprn) then
11918               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11919               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11920               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11921                 restyp(itypi),i,restyp(itypj),j,&
11922                 epsi,sigm,chi1,chi2,chip1,chip2,&
11923                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11924                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11925                 evdwij
11926               endif
11927
11928               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11929                               'evdw',i,j,evdwij
11930 !              if (energy_dec) write (iout,*) &
11931 !                              'evdw',i,j,evdwij,"egb_long"
11932
11933 ! Calculate gradient components.
11934               e1=e1*eps1*eps2rt**2*eps3rt**2
11935               fac=-expon*(e1+evdwij)*rij_shift
11936               sigder=fac*sigder
11937               fac=rij*fac
11938               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
11939             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
11940             /sigmaii(itypi,itypj))
11941 !              fac=0.0d0
11942 ! Calculate the radial part of the gradient
11943               gg(1)=xj*fac
11944               gg(2)=yj*fac
11945               gg(3)=zj*fac
11946 ! Calculate angular part of the gradient.
11947               call sc_grad_scale(1.0d0-sss)
11948             endif
11949           enddo      ! j
11950         enddo        ! iint
11951       enddo          ! i
11952 !      write (iout,*) "Number of loop steps in EGB:",ind
11953 !ccc      energy_dec=.false.
11954       return
11955       end subroutine egb_long
11956 !-----------------------------------------------------------------------------
11957       subroutine egb_short(evdw)
11958 !
11959 ! This subroutine calculates the interaction energy of nonbonded side chains
11960 ! assuming the Gay-Berne potential of interaction.
11961 !
11962       use calc_data
11963 !      implicit real*8 (a-h,o-z)
11964 !      include 'DIMENSIONS'
11965 !      include 'COMMON.GEO'
11966 !      include 'COMMON.VAR'
11967 !      include 'COMMON.LOCAL'
11968 !      include 'COMMON.CHAIN'
11969 !      include 'COMMON.DERIV'
11970 !      include 'COMMON.NAMES'
11971 !      include 'COMMON.INTERACT'
11972 !      include 'COMMON.IOUNITS'
11973 !      include 'COMMON.CALC'
11974 !      include 'COMMON.CONTROL'
11975       logical :: lprn
11976 !el local variables
11977       integer :: iint,itypi,itypi1,itypj,subchap
11978       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11979       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
11980       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11981                     dist_temp, dist_init
11982       evdw=0.0D0
11983 !cccc      energy_dec=.false.
11984 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11985       evdw=0.0D0
11986       lprn=.false.
11987 !     if (icall.eq.0) lprn=.false.
11988 !el      ind=0
11989       do i=iatsc_s,iatsc_e
11990         itypi=itype(i)
11991         if (itypi.eq.ntyp1) cycle
11992         itypi1=itype(i+1)
11993         xi=c(1,nres+i)
11994         yi=c(2,nres+i)
11995         zi=c(3,nres+i)
11996           xi=mod(xi,boxxsize)
11997           if (xi.lt.0) xi=xi+boxxsize
11998           yi=mod(yi,boxysize)
11999           if (yi.lt.0) yi=yi+boxysize
12000           zi=mod(zi,boxzsize)
12001           if (zi.lt.0) zi=zi+boxzsize
12002         dxi=dc_norm(1,nres+i)
12003         dyi=dc_norm(2,nres+i)
12004         dzi=dc_norm(3,nres+i)
12005 !        dsci_inv=dsc_inv(itypi)
12006         dsci_inv=vbld_inv(i+nres)
12007
12008         dxi=dc_norm(1,nres+i)
12009         dyi=dc_norm(2,nres+i)
12010         dzi=dc_norm(3,nres+i)
12011 !        dsci_inv=dsc_inv(itypi)
12012         dsci_inv=vbld_inv(i+nres)
12013 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12014 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12015 !
12016 ! Calculate SC interaction energy.
12017 !
12018         do iint=1,nint_gr(i)
12019           do j=istart(i,iint),iend(i,iint)
12020 !el            ind=ind+1
12021             itypj=itype(j)
12022             if (itypj.eq.ntyp1) cycle
12023 !            dscj_inv=dsc_inv(itypj)
12024             dscj_inv=vbld_inv(j+nres)
12025 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12026 !     &       1.0d0/vbld(j+nres)
12027 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12028             sig0ij=sigma(itypi,itypj)
12029             chi1=chi(itypi,itypj)
12030             chi2=chi(itypj,itypi)
12031             chi12=chi1*chi2
12032             chip1=chip(itypi)
12033             chip2=chip(itypj)
12034             chip12=chip1*chip2
12035             alf1=alp(itypi)
12036             alf2=alp(itypj)
12037             alf12=0.5D0*(alf1+alf2)
12038 !            xj=c(1,nres+j)-xi
12039 !            yj=c(2,nres+j)-yi
12040 !            zj=c(3,nres+j)-zi
12041             xj=c(1,nres+j)
12042             yj=c(2,nres+j)
12043             zj=c(3,nres+j)
12044 ! Searching for nearest neighbour
12045           xj=mod(xj,boxxsize)
12046           if (xj.lt.0) xj=xj+boxxsize
12047           yj=mod(yj,boxysize)
12048           if (yj.lt.0) yj=yj+boxysize
12049           zj=mod(zj,boxzsize)
12050           if (zj.lt.0) zj=zj+boxzsize
12051           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12052           xj_safe=xj
12053           yj_safe=yj
12054           zj_safe=zj
12055           subchap=0
12056           do xshift=-1,1
12057           do yshift=-1,1
12058           do zshift=-1,1
12059           xj=xj_safe+xshift*boxxsize
12060           yj=yj_safe+yshift*boxysize
12061           zj=zj_safe+zshift*boxzsize
12062           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12063           if(dist_temp.lt.dist_init) then
12064             dist_init=dist_temp
12065             xj_temp=xj
12066             yj_temp=yj
12067             zj_temp=zj
12068             subchap=1
12069           endif
12070           enddo
12071           enddo
12072           enddo
12073           if (subchap.eq.1) then
12074           xj=xj_temp-xi
12075           yj=yj_temp-yi
12076           zj=zj_temp-zi
12077           else
12078           xj=xj_safe-xi
12079           yj=yj_safe-yi
12080           zj=zj_safe-zi
12081           endif
12082
12083             dxj=dc_norm(1,nres+j)
12084             dyj=dc_norm(2,nres+j)
12085             dzj=dc_norm(3,nres+j)
12086             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12087             rij=dsqrt(rrij)
12088             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12089             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12090             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12091             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12092             if (sss_ele_cut.le.0.0) cycle
12093
12094             if (sss.gt.0.0d0) then
12095
12096 ! Calculate angle-dependent terms of energy and contributions to their
12097 ! derivatives.
12098               call sc_angular
12099               sigsq=1.0D0/sigsq
12100               sig=sig0ij*dsqrt(sigsq)
12101               rij_shift=1.0D0/rij-sig+sig0ij
12102 ! for diagnostics; uncomment
12103 !              rij_shift=1.2*sig0ij
12104 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12105               if (rij_shift.le.0.0D0) then
12106                 evdw=1.0D20
12107 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12108 !d     &          restyp(itypi),i,restyp(itypj),j,
12109 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12110                 return
12111               endif
12112               sigder=-sig*sigsq
12113 !---------------------------------------------------------------
12114               rij_shift=1.0D0/rij_shift
12115               fac=rij_shift**expon
12116               e1=fac*fac*aa(itypi,itypj)
12117               e2=fac*bb(itypi,itypj)
12118               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12119               eps2der=evdwij*eps3rt
12120               eps3der=evdwij*eps2rt
12121 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12122 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12123               evdwij=evdwij*eps2rt*eps3rt
12124               evdw=evdw+evdwij*sss*sss_ele_cut
12125               if (lprn) then
12126               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12127               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12128               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12129                 restyp(itypi),i,restyp(itypj),j,&
12130                 epsi,sigm,chi1,chi2,chip1,chip2,&
12131                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12132                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12133                 evdwij
12134               endif
12135
12136               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12137                               'evdw',i,j,evdwij
12138 !              if (energy_dec) write (iout,*) &
12139 !                              'evdw',i,j,evdwij,"egb_short"
12140
12141 ! Calculate gradient components.
12142               e1=e1*eps1*eps2rt**2*eps3rt**2
12143               fac=-expon*(e1+evdwij)*rij_shift
12144               sigder=fac*sigder
12145               fac=rij*fac
12146               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12147             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12148             /sigmaii(itypi,itypj))
12149
12150 !              fac=0.0d0
12151 ! Calculate the radial part of the gradient
12152               gg(1)=xj*fac
12153               gg(2)=yj*fac
12154               gg(3)=zj*fac
12155 ! Calculate angular part of the gradient.
12156               call sc_grad_scale(sss)
12157             endif
12158           enddo      ! j
12159         enddo        ! iint
12160       enddo          ! i
12161 !      write (iout,*) "Number of loop steps in EGB:",ind
12162 !ccc      energy_dec=.false.
12163       return
12164       end subroutine egb_short
12165 !-----------------------------------------------------------------------------
12166       subroutine egbv_long(evdw)
12167 !
12168 ! This subroutine calculates the interaction energy of nonbonded side chains
12169 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12170 !
12171       use calc_data
12172 !      implicit real*8 (a-h,o-z)
12173 !      include 'DIMENSIONS'
12174 !      include 'COMMON.GEO'
12175 !      include 'COMMON.VAR'
12176 !      include 'COMMON.LOCAL'
12177 !      include 'COMMON.CHAIN'
12178 !      include 'COMMON.DERIV'
12179 !      include 'COMMON.NAMES'
12180 !      include 'COMMON.INTERACT'
12181 !      include 'COMMON.IOUNITS'
12182 !      include 'COMMON.CALC'
12183       use comm_srutu
12184 !el      integer :: icall
12185 !el      common /srutu/ icall
12186       logical :: lprn
12187 !el local variables
12188       integer :: iint,itypi,itypi1,itypj
12189       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12190       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12191       evdw=0.0D0
12192 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12193       evdw=0.0D0
12194       lprn=.false.
12195 !     if (icall.eq.0) lprn=.true.
12196 !el      ind=0
12197       do i=iatsc_s,iatsc_e
12198         itypi=itype(i)
12199         if (itypi.eq.ntyp1) cycle
12200         itypi1=itype(i+1)
12201         xi=c(1,nres+i)
12202         yi=c(2,nres+i)
12203         zi=c(3,nres+i)
12204         dxi=dc_norm(1,nres+i)
12205         dyi=dc_norm(2,nres+i)
12206         dzi=dc_norm(3,nres+i)
12207 !        dsci_inv=dsc_inv(itypi)
12208         dsci_inv=vbld_inv(i+nres)
12209 !
12210 ! Calculate SC interaction energy.
12211 !
12212         do iint=1,nint_gr(i)
12213           do j=istart(i,iint),iend(i,iint)
12214 !el            ind=ind+1
12215             itypj=itype(j)
12216             if (itypj.eq.ntyp1) cycle
12217 !            dscj_inv=dsc_inv(itypj)
12218             dscj_inv=vbld_inv(j+nres)
12219             sig0ij=sigma(itypi,itypj)
12220             r0ij=r0(itypi,itypj)
12221             chi1=chi(itypi,itypj)
12222             chi2=chi(itypj,itypi)
12223             chi12=chi1*chi2
12224             chip1=chip(itypi)
12225             chip2=chip(itypj)
12226             chip12=chip1*chip2
12227             alf1=alp(itypi)
12228             alf2=alp(itypj)
12229             alf12=0.5D0*(alf1+alf2)
12230             xj=c(1,nres+j)-xi
12231             yj=c(2,nres+j)-yi
12232             zj=c(3,nres+j)-zi
12233             dxj=dc_norm(1,nres+j)
12234             dyj=dc_norm(2,nres+j)
12235             dzj=dc_norm(3,nres+j)
12236             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12237             rij=dsqrt(rrij)
12238
12239             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12240
12241             if (sss.lt.1.0d0) then
12242
12243 ! Calculate angle-dependent terms of energy and contributions to their
12244 ! derivatives.
12245               call sc_angular
12246               sigsq=1.0D0/sigsq
12247               sig=sig0ij*dsqrt(sigsq)
12248               rij_shift=1.0D0/rij-sig+r0ij
12249 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12250               if (rij_shift.le.0.0D0) then
12251                 evdw=1.0D20
12252                 return
12253               endif
12254               sigder=-sig*sigsq
12255 !---------------------------------------------------------------
12256               rij_shift=1.0D0/rij_shift
12257               fac=rij_shift**expon
12258               e1=fac*fac*aa(itypi,itypj)
12259               e2=fac*bb(itypi,itypj)
12260               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12261               eps2der=evdwij*eps3rt
12262               eps3der=evdwij*eps2rt
12263               fac_augm=rrij**expon
12264               e_augm=augm(itypi,itypj)*fac_augm
12265               evdwij=evdwij*eps2rt*eps3rt
12266               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12267               if (lprn) then
12268               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12269               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12270               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12271                 restyp(itypi),i,restyp(itypj),j,&
12272                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12273                 chi1,chi2,chip1,chip2,&
12274                 eps1,eps2rt**2,eps3rt**2,&
12275                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12276                 evdwij+e_augm
12277               endif
12278 ! Calculate gradient components.
12279               e1=e1*eps1*eps2rt**2*eps3rt**2
12280               fac=-expon*(e1+evdwij)*rij_shift
12281               sigder=fac*sigder
12282               fac=rij*fac-2*expon*rrij*e_augm
12283 ! Calculate the radial part of the gradient
12284               gg(1)=xj*fac
12285               gg(2)=yj*fac
12286               gg(3)=zj*fac
12287 ! Calculate angular part of the gradient.
12288               call sc_grad_scale(1.0d0-sss)
12289             endif
12290           enddo      ! j
12291         enddo        ! iint
12292       enddo          ! i
12293       end subroutine egbv_long
12294 !-----------------------------------------------------------------------------
12295       subroutine egbv_short(evdw)
12296 !
12297 ! This subroutine calculates the interaction energy of nonbonded side chains
12298 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12299 !
12300       use calc_data
12301 !      implicit real*8 (a-h,o-z)
12302 !      include 'DIMENSIONS'
12303 !      include 'COMMON.GEO'
12304 !      include 'COMMON.VAR'
12305 !      include 'COMMON.LOCAL'
12306 !      include 'COMMON.CHAIN'
12307 !      include 'COMMON.DERIV'
12308 !      include 'COMMON.NAMES'
12309 !      include 'COMMON.INTERACT'
12310 !      include 'COMMON.IOUNITS'
12311 !      include 'COMMON.CALC'
12312       use comm_srutu
12313 !el      integer :: icall
12314 !el      common /srutu/ icall
12315       logical :: lprn
12316 !el local variables
12317       integer :: iint,itypi,itypi1,itypj
12318       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12319       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12320       evdw=0.0D0
12321 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12322       evdw=0.0D0
12323       lprn=.false.
12324 !     if (icall.eq.0) lprn=.true.
12325 !el      ind=0
12326       do i=iatsc_s,iatsc_e
12327         itypi=itype(i)
12328         if (itypi.eq.ntyp1) cycle
12329         itypi1=itype(i+1)
12330         xi=c(1,nres+i)
12331         yi=c(2,nres+i)
12332         zi=c(3,nres+i)
12333         dxi=dc_norm(1,nres+i)
12334         dyi=dc_norm(2,nres+i)
12335         dzi=dc_norm(3,nres+i)
12336 !        dsci_inv=dsc_inv(itypi)
12337         dsci_inv=vbld_inv(i+nres)
12338 !
12339 ! Calculate SC interaction energy.
12340 !
12341         do iint=1,nint_gr(i)
12342           do j=istart(i,iint),iend(i,iint)
12343 !el            ind=ind+1
12344             itypj=itype(j)
12345             if (itypj.eq.ntyp1) cycle
12346 !            dscj_inv=dsc_inv(itypj)
12347             dscj_inv=vbld_inv(j+nres)
12348             sig0ij=sigma(itypi,itypj)
12349             r0ij=r0(itypi,itypj)
12350             chi1=chi(itypi,itypj)
12351             chi2=chi(itypj,itypi)
12352             chi12=chi1*chi2
12353             chip1=chip(itypi)
12354             chip2=chip(itypj)
12355             chip12=chip1*chip2
12356             alf1=alp(itypi)
12357             alf2=alp(itypj)
12358             alf12=0.5D0*(alf1+alf2)
12359             xj=c(1,nres+j)-xi
12360             yj=c(2,nres+j)-yi
12361             zj=c(3,nres+j)-zi
12362             dxj=dc_norm(1,nres+j)
12363             dyj=dc_norm(2,nres+j)
12364             dzj=dc_norm(3,nres+j)
12365             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12366             rij=dsqrt(rrij)
12367
12368             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12369
12370             if (sss.gt.0.0d0) then
12371
12372 ! Calculate angle-dependent terms of energy and contributions to their
12373 ! derivatives.
12374               call sc_angular
12375               sigsq=1.0D0/sigsq
12376               sig=sig0ij*dsqrt(sigsq)
12377               rij_shift=1.0D0/rij-sig+r0ij
12378 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12379               if (rij_shift.le.0.0D0) then
12380                 evdw=1.0D20
12381                 return
12382               endif
12383               sigder=-sig*sigsq
12384 !---------------------------------------------------------------
12385               rij_shift=1.0D0/rij_shift
12386               fac=rij_shift**expon
12387               e1=fac*fac*aa(itypi,itypj)
12388               e2=fac*bb(itypi,itypj)
12389               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12390               eps2der=evdwij*eps3rt
12391               eps3der=evdwij*eps2rt
12392               fac_augm=rrij**expon
12393               e_augm=augm(itypi,itypj)*fac_augm
12394               evdwij=evdwij*eps2rt*eps3rt
12395               evdw=evdw+(evdwij+e_augm)*sss
12396               if (lprn) then
12397               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12398               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12399               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12400                 restyp(itypi),i,restyp(itypj),j,&
12401                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12402                 chi1,chi2,chip1,chip2,&
12403                 eps1,eps2rt**2,eps3rt**2,&
12404                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12405                 evdwij+e_augm
12406               endif
12407 ! Calculate gradient components.
12408               e1=e1*eps1*eps2rt**2*eps3rt**2
12409               fac=-expon*(e1+evdwij)*rij_shift
12410               sigder=fac*sigder
12411               fac=rij*fac-2*expon*rrij*e_augm
12412 ! Calculate the radial part of the gradient
12413               gg(1)=xj*fac
12414               gg(2)=yj*fac
12415               gg(3)=zj*fac
12416 ! Calculate angular part of the gradient.
12417               call sc_grad_scale(sss)
12418             endif
12419           enddo      ! j
12420         enddo        ! iint
12421       enddo          ! i
12422       end subroutine egbv_short
12423 !-----------------------------------------------------------------------------
12424       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12425 !
12426 ! This subroutine calculates the average interaction energy and its gradient
12427 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12428 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12429 ! The potential depends both on the distance of peptide-group centers and on
12430 ! the orientation of the CA-CA virtual bonds.
12431 !
12432 !      implicit real*8 (a-h,o-z)
12433
12434       use comm_locel
12435 #ifdef MPI
12436       include 'mpif.h'
12437 #endif
12438 !      include 'DIMENSIONS'
12439 !      include 'COMMON.CONTROL'
12440 !      include 'COMMON.SETUP'
12441 !      include 'COMMON.IOUNITS'
12442 !      include 'COMMON.GEO'
12443 !      include 'COMMON.VAR'
12444 !      include 'COMMON.LOCAL'
12445 !      include 'COMMON.CHAIN'
12446 !      include 'COMMON.DERIV'
12447 !      include 'COMMON.INTERACT'
12448 !      include 'COMMON.CONTACTS'
12449 !      include 'COMMON.TORSION'
12450 !      include 'COMMON.VECTORS'
12451 !      include 'COMMON.FFIELD'
12452 !      include 'COMMON.TIME1'
12453       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12454       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12455       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12456 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12457       real(kind=8),dimension(4) :: muij
12458 !el      integer :: num_conti,j1,j2
12459 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12460 !el                   dz_normi,xmedi,ymedi,zmedi
12461 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12462 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12463 !el          num_conti,j1,j2
12464 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12465 #ifdef MOMENT
12466       real(kind=8) :: scal_el=1.0d0
12467 #else
12468       real(kind=8) :: scal_el=0.5d0
12469 #endif
12470 ! 12/13/98
12471 ! 13-go grudnia roku pamietnego...
12472       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12473                                              0.0d0,1.0d0,0.0d0,&
12474                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12475 !el local variables
12476       integer :: i,j,k
12477       real(kind=8) :: fac
12478       real(kind=8) :: dxj,dyj,dzj
12479       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12480
12481 !      allocate(num_cont_hb(nres)) !(maxres)
12482 !d      write(iout,*) 'In EELEC'
12483 !d      do i=1,nloctyp
12484 !d        write(iout,*) 'Type',i
12485 !d        write(iout,*) 'B1',B1(:,i)
12486 !d        write(iout,*) 'B2',B2(:,i)
12487 !d        write(iout,*) 'CC',CC(:,:,i)
12488 !d        write(iout,*) 'DD',DD(:,:,i)
12489 !d        write(iout,*) 'EE',EE(:,:,i)
12490 !d      enddo
12491 !d      call check_vecgrad
12492 !d      stop
12493       if (icheckgrad.eq.1) then
12494         do i=1,nres-1
12495           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12496           do k=1,3
12497             dc_norm(k,i)=dc(k,i)*fac
12498           enddo
12499 !          write (iout,*) 'i',i,' fac',fac
12500         enddo
12501       endif
12502       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12503           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12504           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12505 !        call vec_and_deriv
12506 #ifdef TIMING
12507         time01=MPI_Wtime()
12508 #endif
12509         call set_matrices
12510 #ifdef TIMING
12511         time_mat=time_mat+MPI_Wtime()-time01
12512 #endif
12513       endif
12514 !d      do i=1,nres-1
12515 !d        write (iout,*) 'i=',i
12516 !d        do k=1,3
12517 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12518 !d        enddo
12519 !d        do k=1,3
12520 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12521 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12522 !d        enddo
12523 !d      enddo
12524       t_eelecij=0.0d0
12525       ees=0.0D0
12526       evdw1=0.0D0
12527       eel_loc=0.0d0
12528       eello_turn3=0.0d0
12529       eello_turn4=0.0d0
12530 !el      ind=0
12531       do i=1,nres
12532         num_cont_hb(i)=0
12533       enddo
12534 !d      print '(a)','Enter EELEC'
12535 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12536 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12537 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12538       do i=1,nres
12539         gel_loc_loc(i)=0.0d0
12540         gcorr_loc(i)=0.0d0
12541       enddo
12542 !
12543 !
12544 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12545 !
12546 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12547 !
12548       do i=iturn3_start,iturn3_end
12549         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12550         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12551         dxi=dc(1,i)
12552         dyi=dc(2,i)
12553         dzi=dc(3,i)
12554         dx_normi=dc_norm(1,i)
12555         dy_normi=dc_norm(2,i)
12556         dz_normi=dc_norm(3,i)
12557         xmedi=c(1,i)+0.5d0*dxi
12558         ymedi=c(2,i)+0.5d0*dyi
12559         zmedi=c(3,i)+0.5d0*dzi
12560         num_conti=0
12561         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12562         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12563         num_cont_hb(i)=num_conti
12564       enddo
12565       do i=iturn4_start,iturn4_end
12566         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12567           .or. itype(i+3).eq.ntyp1 &
12568           .or. itype(i+4).eq.ntyp1) cycle
12569         dxi=dc(1,i)
12570         dyi=dc(2,i)
12571         dzi=dc(3,i)
12572         dx_normi=dc_norm(1,i)
12573         dy_normi=dc_norm(2,i)
12574         dz_normi=dc_norm(3,i)
12575         xmedi=c(1,i)+0.5d0*dxi
12576         ymedi=c(2,i)+0.5d0*dyi
12577         zmedi=c(3,i)+0.5d0*dzi
12578         num_conti=num_cont_hb(i)
12579         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12580         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12581           call eturn4(i,eello_turn4)
12582         num_cont_hb(i)=num_conti
12583       enddo   ! i
12584 !
12585 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12586 !
12587       do i=iatel_s,iatel_e
12588         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12589         dxi=dc(1,i)
12590         dyi=dc(2,i)
12591         dzi=dc(3,i)
12592         dx_normi=dc_norm(1,i)
12593         dy_normi=dc_norm(2,i)
12594         dz_normi=dc_norm(3,i)
12595         xmedi=c(1,i)+0.5d0*dxi
12596         ymedi=c(2,i)+0.5d0*dyi
12597         zmedi=c(3,i)+0.5d0*dzi
12598 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12599         num_conti=num_cont_hb(i)
12600         do j=ielstart(i),ielend(i)
12601           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12602           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12603         enddo ! j
12604         num_cont_hb(i)=num_conti
12605       enddo   ! i
12606 !      write (iout,*) "Number of loop steps in EELEC:",ind
12607 !d      do i=1,nres
12608 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12609 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12610 !d      enddo
12611 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12612 !cc      eel_loc=eel_loc+eello_turn3
12613 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12614       return
12615       end subroutine eelec_scale
12616 !-----------------------------------------------------------------------------
12617       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12618 !      implicit real*8 (a-h,o-z)
12619
12620       use comm_locel
12621 !      include 'DIMENSIONS'
12622 #ifdef MPI
12623       include "mpif.h"
12624 #endif
12625 !      include 'COMMON.CONTROL'
12626 !      include 'COMMON.IOUNITS'
12627 !      include 'COMMON.GEO'
12628 !      include 'COMMON.VAR'
12629 !      include 'COMMON.LOCAL'
12630 !      include 'COMMON.CHAIN'
12631 !      include 'COMMON.DERIV'
12632 !      include 'COMMON.INTERACT'
12633 !      include 'COMMON.CONTACTS'
12634 !      include 'COMMON.TORSION'
12635 !      include 'COMMON.VECTORS'
12636 !      include 'COMMON.FFIELD'
12637 !      include 'COMMON.TIME1'
12638       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12639       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12640       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12641 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12642       real(kind=8),dimension(4) :: muij
12643 !el      integer :: num_conti,j1,j2
12644 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12645 !el                   dz_normi,xmedi,ymedi,zmedi
12646 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12647 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12648 !el          num_conti,j1,j2
12649 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12650 #ifdef MOMENT
12651       real(kind=8) :: scal_el=1.0d0
12652 #else
12653       real(kind=8) :: scal_el=0.5d0
12654 #endif
12655 ! 12/13/98
12656 ! 13-go grudnia roku pamietnego...
12657       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12658                                              0.0d0,1.0d0,0.0d0,&
12659                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12660 !el local variables
12661       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12662       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12663       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12664       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12665       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12666       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12667       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12668                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12669                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12670                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12671                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12672                   ecosam,ecosbm,ecosgm,ghalf,time00
12673 !      integer :: maxconts
12674 !      maxconts = nres/4
12675 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12676 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12677 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12678 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12679 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12680 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12681 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12682 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12683 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12684 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12685 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12686 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12687 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12688
12689 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12690 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12691
12692 #ifdef MPI
12693           time00=MPI_Wtime()
12694 #endif
12695 !d      write (iout,*) "eelecij",i,j
12696 !el          ind=ind+1
12697           iteli=itel(i)
12698           itelj=itel(j)
12699           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12700           aaa=app(iteli,itelj)
12701           bbb=bpp(iteli,itelj)
12702           ael6i=ael6(iteli,itelj)
12703           ael3i=ael3(iteli,itelj)
12704           dxj=dc(1,j)
12705           dyj=dc(2,j)
12706           dzj=dc(3,j)
12707           dx_normj=dc_norm(1,j)
12708           dy_normj=dc_norm(2,j)
12709           dz_normj=dc_norm(3,j)
12710           xj=c(1,j)+0.5D0*dxj-xmedi
12711           yj=c(2,j)+0.5D0*dyj-ymedi
12712           zj=c(3,j)+0.5D0*dzj-zmedi
12713           rij=xj*xj+yj*yj+zj*zj
12714           rrmij=1.0D0/rij
12715           rij=dsqrt(rij)
12716           rmij=1.0D0/rij
12717 ! For extracting the short-range part of Evdwpp
12718           sss=sscale(rij/rpp(iteli,itelj))
12719
12720           r3ij=rrmij*rmij
12721           r6ij=r3ij*r3ij
12722           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12723           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12724           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12725           fac=cosa-3.0D0*cosb*cosg
12726           ev1=aaa*r6ij*r6ij
12727 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12728           if (j.eq.i+2) ev1=scal_el*ev1
12729           ev2=bbb*r6ij
12730           fac3=ael6i*r6ij
12731           fac4=ael3i*r3ij
12732           evdwij=ev1+ev2
12733           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12734           el2=fac4*fac
12735           eesij=el1+el2
12736 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12737           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12738           ees=ees+eesij
12739           evdw1=evdw1+evdwij*(1.0d0-sss)
12740 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12741 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12742 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12743 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12744
12745           if (energy_dec) then
12746               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12747               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12748           endif
12749
12750 !
12751 ! Calculate contributions to the Cartesian gradient.
12752 !
12753 #ifdef SPLITELE
12754           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12755           facel=-3*rrmij*(el1+eesij)
12756           fac1=fac
12757           erij(1)=xj*rmij
12758           erij(2)=yj*rmij
12759           erij(3)=zj*rmij
12760 !
12761 ! Radial derivatives. First process both termini of the fragment (i,j)
12762 !
12763           ggg(1)=facel*xj
12764           ggg(2)=facel*yj
12765           ggg(3)=facel*zj
12766 !          do k=1,3
12767 !            ghalf=0.5D0*ggg(k)
12768 !            gelc(k,i)=gelc(k,i)+ghalf
12769 !            gelc(k,j)=gelc(k,j)+ghalf
12770 !          enddo
12771 ! 9/28/08 AL Gradient compotents will be summed only at the end
12772           do k=1,3
12773             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12774             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12775           enddo
12776 !
12777 ! Loop over residues i+1 thru j-1.
12778 !
12779 !grad          do k=i+1,j-1
12780 !grad            do l=1,3
12781 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12782 !grad            enddo
12783 !grad          enddo
12784           ggg(1)=facvdw*xj
12785           ggg(2)=facvdw*yj
12786           ggg(3)=facvdw*zj
12787 !          do k=1,3
12788 !            ghalf=0.5D0*ggg(k)
12789 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12790 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12791 !          enddo
12792 ! 9/28/08 AL Gradient compotents will be summed only at the end
12793           do k=1,3
12794             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12795             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12796           enddo
12797 !
12798 ! Loop over residues i+1 thru j-1.
12799 !
12800 !grad          do k=i+1,j-1
12801 !grad            do l=1,3
12802 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12803 !grad            enddo
12804 !grad          enddo
12805 #else
12806           facvdw=ev1+evdwij*(1.0d0-sss)
12807           facel=el1+eesij
12808           fac1=fac
12809           fac=-3*rrmij*(facvdw+facvdw+facel)
12810           erij(1)=xj*rmij
12811           erij(2)=yj*rmij
12812           erij(3)=zj*rmij
12813 !
12814 ! Radial derivatives. First process both termini of the fragment (i,j)
12815 !
12816           ggg(1)=fac*xj
12817           ggg(2)=fac*yj
12818           ggg(3)=fac*zj
12819 !          do k=1,3
12820 !            ghalf=0.5D0*ggg(k)
12821 !            gelc(k,i)=gelc(k,i)+ghalf
12822 !            gelc(k,j)=gelc(k,j)+ghalf
12823 !          enddo
12824 ! 9/28/08 AL Gradient compotents will be summed only at the end
12825           do k=1,3
12826             gelc_long(k,j)=gelc(k,j)+ggg(k)
12827             gelc_long(k,i)=gelc(k,i)-ggg(k)
12828           enddo
12829 !
12830 ! Loop over residues i+1 thru j-1.
12831 !
12832 !grad          do k=i+1,j-1
12833 !grad            do l=1,3
12834 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12835 !grad            enddo
12836 !grad          enddo
12837 ! 9/28/08 AL Gradient compotents will be summed only at the end
12838           ggg(1)=facvdw*xj
12839           ggg(2)=facvdw*yj
12840           ggg(3)=facvdw*zj
12841           do k=1,3
12842             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12843             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12844           enddo
12845 #endif
12846 !
12847 ! Angular part
12848 !
12849           ecosa=2.0D0*fac3*fac1+fac4
12850           fac4=-3.0D0*fac4
12851           fac3=-6.0D0*fac3
12852           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12853           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12854           do k=1,3
12855             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12856             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12857           enddo
12858 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12859 !d   &          (dcosg(k),k=1,3)
12860           do k=1,3
12861             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12862           enddo
12863 !          do k=1,3
12864 !            ghalf=0.5D0*ggg(k)
12865 !            gelc(k,i)=gelc(k,i)+ghalf
12866 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12867 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12868 !            gelc(k,j)=gelc(k,j)+ghalf
12869 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12870 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12871 !          enddo
12872 !grad          do k=i+1,j-1
12873 !grad            do l=1,3
12874 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12875 !grad            enddo
12876 !grad          enddo
12877           do k=1,3
12878             gelc(k,i)=gelc(k,i) &
12879                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12880                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12881             gelc(k,j)=gelc(k,j) &
12882                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12883                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12884             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12885             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12886           enddo
12887           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12888               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12889               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12890 !
12891 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12892 !   energy of a peptide unit is assumed in the form of a second-order
12893 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12894 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12895 !   are computed for EVERY pair of non-contiguous peptide groups.
12896 !
12897           if (j.lt.nres-1) then
12898             j1=j+1
12899             j2=j-1
12900           else
12901             j1=j-1
12902             j2=j-2
12903           endif
12904           kkk=0
12905           do k=1,2
12906             do l=1,2
12907               kkk=kkk+1
12908               muij(kkk)=mu(k,i)*mu(l,j)
12909             enddo
12910           enddo
12911 !d         write (iout,*) 'EELEC: i',i,' j',j
12912 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12913 !d          write(iout,*) 'muij',muij
12914           ury=scalar(uy(1,i),erij)
12915           urz=scalar(uz(1,i),erij)
12916           vry=scalar(uy(1,j),erij)
12917           vrz=scalar(uz(1,j),erij)
12918           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12919           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12920           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12921           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12922           fac=dsqrt(-ael6i)*r3ij
12923           a22=a22*fac
12924           a23=a23*fac
12925           a32=a32*fac
12926           a33=a33*fac
12927 !d          write (iout,'(4i5,4f10.5)')
12928 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12929 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12930 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12931 !d     &      uy(:,j),uz(:,j)
12932 !d          write (iout,'(4f10.5)')
12933 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12934 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12935 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12936 !d           write (iout,'(9f10.5/)')
12937 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12938 ! Derivatives of the elements of A in virtual-bond vectors
12939           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12940           do k=1,3
12941             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12942             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12943             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12944             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12945             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12946             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12947             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12948             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12949             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12950             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12951             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12952             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12953           enddo
12954 ! Compute radial contributions to the gradient
12955           facr=-3.0d0*rrmij
12956           a22der=a22*facr
12957           a23der=a23*facr
12958           a32der=a32*facr
12959           a33der=a33*facr
12960           agg(1,1)=a22der*xj
12961           agg(2,1)=a22der*yj
12962           agg(3,1)=a22der*zj
12963           agg(1,2)=a23der*xj
12964           agg(2,2)=a23der*yj
12965           agg(3,2)=a23der*zj
12966           agg(1,3)=a32der*xj
12967           agg(2,3)=a32der*yj
12968           agg(3,3)=a32der*zj
12969           agg(1,4)=a33der*xj
12970           agg(2,4)=a33der*yj
12971           agg(3,4)=a33der*zj
12972 ! Add the contributions coming from er
12973           fac3=-3.0d0*fac
12974           do k=1,3
12975             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12976             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12977             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12978             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12979           enddo
12980           do k=1,3
12981 ! Derivatives in DC(i)
12982 !grad            ghalf1=0.5d0*agg(k,1)
12983 !grad            ghalf2=0.5d0*agg(k,2)
12984 !grad            ghalf3=0.5d0*agg(k,3)
12985 !grad            ghalf4=0.5d0*agg(k,4)
12986             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12987             -3.0d0*uryg(k,2)*vry)!+ghalf1
12988             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12989             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12990             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12991             -3.0d0*urzg(k,2)*vry)!+ghalf3
12992             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12993             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12994 ! Derivatives in DC(i+1)
12995             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12996             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12997             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12998             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12999             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
13000             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
13001             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
13002             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
13003 ! Derivatives in DC(j)
13004             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
13005             -3.0d0*vryg(k,2)*ury)!+ghalf1
13006             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
13007             -3.0d0*vrzg(k,2)*ury)!+ghalf2
13008             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
13009             -3.0d0*vryg(k,2)*urz)!+ghalf3
13010             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
13011             -3.0d0*vrzg(k,2)*urz)!+ghalf4
13012 ! Derivatives in DC(j+1) or DC(nres-1)
13013             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
13014             -3.0d0*vryg(k,3)*ury)
13015             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
13016             -3.0d0*vrzg(k,3)*ury)
13017             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
13018             -3.0d0*vryg(k,3)*urz)
13019             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
13020             -3.0d0*vrzg(k,3)*urz)
13021 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
13022 !grad              do l=1,4
13023 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
13024 !grad              enddo
13025 !grad            endif
13026           enddo
13027           acipa(1,1)=a22
13028           acipa(1,2)=a23
13029           acipa(2,1)=a32
13030           acipa(2,2)=a33
13031           a22=-a22
13032           a23=-a23
13033           do l=1,2
13034             do k=1,3
13035               agg(k,l)=-agg(k,l)
13036               aggi(k,l)=-aggi(k,l)
13037               aggi1(k,l)=-aggi1(k,l)
13038               aggj(k,l)=-aggj(k,l)
13039               aggj1(k,l)=-aggj1(k,l)
13040             enddo
13041           enddo
13042           if (j.lt.nres-1) then
13043             a22=-a22
13044             a32=-a32
13045             do l=1,3,2
13046               do k=1,3
13047                 agg(k,l)=-agg(k,l)
13048                 aggi(k,l)=-aggi(k,l)
13049                 aggi1(k,l)=-aggi1(k,l)
13050                 aggj(k,l)=-aggj(k,l)
13051                 aggj1(k,l)=-aggj1(k,l)
13052               enddo
13053             enddo
13054           else
13055             a22=-a22
13056             a23=-a23
13057             a32=-a32
13058             a33=-a33
13059             do l=1,4
13060               do k=1,3
13061                 agg(k,l)=-agg(k,l)
13062                 aggi(k,l)=-aggi(k,l)
13063                 aggi1(k,l)=-aggi1(k,l)
13064                 aggj(k,l)=-aggj(k,l)
13065                 aggj1(k,l)=-aggj1(k,l)
13066               enddo
13067             enddo
13068           endif
13069           ENDIF ! WCORR
13070           IF (wel_loc.gt.0.0d0) THEN
13071 ! Contribution to the local-electrostatic energy coming from the i-j pair
13072           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
13073            +a33*muij(4)
13074 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
13075
13076           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13077                   'eelloc',i,j,eel_loc_ij
13078 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
13079
13080           eel_loc=eel_loc+eel_loc_ij
13081 ! Partial derivatives in virtual-bond dihedral angles gamma
13082           if (i.gt.1) &
13083           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
13084                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
13085                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
13086           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
13087                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
13088                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
13089 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
13090           do l=1,3
13091             ggg(l)=agg(l,1)*muij(1)+ &
13092                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
13093             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
13094             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
13095 !grad            ghalf=0.5d0*ggg(l)
13096 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
13097 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
13098           enddo
13099 !grad          do k=i+1,j2
13100 !grad            do l=1,3
13101 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
13102 !grad            enddo
13103 !grad          enddo
13104 ! Remaining derivatives of eello
13105           do l=1,3
13106             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
13107                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
13108             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
13109                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
13110             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
13111                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
13112             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
13113                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
13114           enddo
13115           ENDIF
13116 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13117 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13118           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13119              .and. num_conti.le.maxconts) then
13120 !            write (iout,*) i,j," entered corr"
13121 !
13122 ! Calculate the contact function. The ith column of the array JCONT will
13123 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13124 ! greater than I). The arrays FACONT and GACONT will contain the values of
13125 ! the contact function and its derivative.
13126 !           r0ij=1.02D0*rpp(iteli,itelj)
13127 !           r0ij=1.11D0*rpp(iteli,itelj)
13128             r0ij=2.20D0*rpp(iteli,itelj)
13129 !           r0ij=1.55D0*rpp(iteli,itelj)
13130             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13131 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13132             if (fcont.gt.0.0D0) then
13133               num_conti=num_conti+1
13134               if (num_conti.gt.maxconts) then
13135 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13136                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13137                                ' will skip next contacts for this conf.',num_conti
13138               else
13139                 jcont_hb(num_conti,i)=j
13140 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13141 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13142                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13143                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13144 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13145 !  terms.
13146                 d_cont(num_conti,i)=rij
13147 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13148 !     --- Electrostatic-interaction matrix ---
13149                 a_chuj(1,1,num_conti,i)=a22
13150                 a_chuj(1,2,num_conti,i)=a23
13151                 a_chuj(2,1,num_conti,i)=a32
13152                 a_chuj(2,2,num_conti,i)=a33
13153 !     --- Gradient of rij
13154                 do kkk=1,3
13155                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13156                 enddo
13157                 kkll=0
13158                 do k=1,2
13159                   do l=1,2
13160                     kkll=kkll+1
13161                     do m=1,3
13162                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13163                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13164                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13165                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13166                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13167                     enddo
13168                   enddo
13169                 enddo
13170                 ENDIF
13171                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13172 ! Calculate contact energies
13173                 cosa4=4.0D0*cosa
13174                 wij=cosa-3.0D0*cosb*cosg
13175                 cosbg1=cosb+cosg
13176                 cosbg2=cosb-cosg
13177 !               fac3=dsqrt(-ael6i)/r0ij**3
13178                 fac3=dsqrt(-ael6i)*r3ij
13179 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13180                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13181                 if (ees0tmp.gt.0) then
13182                   ees0pij=dsqrt(ees0tmp)
13183                 else
13184                   ees0pij=0
13185                 endif
13186 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13187                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13188                 if (ees0tmp.gt.0) then
13189                   ees0mij=dsqrt(ees0tmp)
13190                 else
13191                   ees0mij=0
13192                 endif
13193 !               ees0mij=0.0D0
13194                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13195                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13196 ! Diagnostics. Comment out or remove after debugging!
13197 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13198 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13199 !               ees0m(num_conti,i)=0.0D0
13200 ! End diagnostics.
13201 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13202 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13203 ! Angular derivatives of the contact function
13204                 ees0pij1=fac3/ees0pij
13205                 ees0mij1=fac3/ees0mij
13206                 fac3p=-3.0D0*fac3*rrmij
13207                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13208                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13209 !               ees0mij1=0.0D0
13210                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13211                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13212                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13213                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13214                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13215                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13216                 ecosap=ecosa1+ecosa2
13217                 ecosbp=ecosb1+ecosb2
13218                 ecosgp=ecosg1+ecosg2
13219                 ecosam=ecosa1-ecosa2
13220                 ecosbm=ecosb1-ecosb2
13221                 ecosgm=ecosg1-ecosg2
13222 ! Diagnostics
13223 !               ecosap=ecosa1
13224 !               ecosbp=ecosb1
13225 !               ecosgp=ecosg1
13226 !               ecosam=0.0D0
13227 !               ecosbm=0.0D0
13228 !               ecosgm=0.0D0
13229 ! End diagnostics
13230                 facont_hb(num_conti,i)=fcont
13231                 fprimcont=fprimcont/rij
13232 !d              facont_hb(num_conti,i)=1.0D0
13233 ! Following line is for diagnostics.
13234 !d              fprimcont=0.0D0
13235                 do k=1,3
13236                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13237                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13238                 enddo
13239                 do k=1,3
13240                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13241                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13242                 enddo
13243                 gggp(1)=gggp(1)+ees0pijp*xj
13244                 gggp(2)=gggp(2)+ees0pijp*yj
13245                 gggp(3)=gggp(3)+ees0pijp*zj
13246                 gggm(1)=gggm(1)+ees0mijp*xj
13247                 gggm(2)=gggm(2)+ees0mijp*yj
13248                 gggm(3)=gggm(3)+ees0mijp*zj
13249 ! Derivatives due to the contact function
13250                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13251                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13252                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13253                 do k=1,3
13254 !
13255 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13256 !          following the change of gradient-summation algorithm.
13257 !
13258 !grad                  ghalfp=0.5D0*gggp(k)
13259 !grad                  ghalfm=0.5D0*gggm(k)
13260                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13261                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13262                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13263                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13264                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13265                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13266                   gacontp_hb3(k,num_conti,i)=gggp(k)
13267                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13268                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13269                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13270                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13271                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13272                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13273                   gacontm_hb3(k,num_conti,i)=gggm(k)
13274                 enddo
13275               ENDIF ! wcorr
13276               endif  ! num_conti.le.maxconts
13277             endif  ! fcont.gt.0
13278           endif    ! j.gt.i+1
13279           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13280             do k=1,4
13281               do l=1,3
13282                 ghalf=0.5d0*agg(l,k)
13283                 aggi(l,k)=aggi(l,k)+ghalf
13284                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13285                 aggj(l,k)=aggj(l,k)+ghalf
13286               enddo
13287             enddo
13288             if (j.eq.nres-1 .and. i.lt.j-2) then
13289               do k=1,4
13290                 do l=1,3
13291                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13292                 enddo
13293               enddo
13294             endif
13295           endif
13296 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13297       return
13298       end subroutine eelecij_scale
13299 !-----------------------------------------------------------------------------
13300       subroutine evdwpp_short(evdw1)
13301 !
13302 ! Compute Evdwpp
13303 !
13304 !      implicit real*8 (a-h,o-z)
13305 !      include 'DIMENSIONS'
13306 !      include 'COMMON.CONTROL'
13307 !      include 'COMMON.IOUNITS'
13308 !      include 'COMMON.GEO'
13309 !      include 'COMMON.VAR'
13310 !      include 'COMMON.LOCAL'
13311 !      include 'COMMON.CHAIN'
13312 !      include 'COMMON.DERIV'
13313 !      include 'COMMON.INTERACT'
13314 !      include 'COMMON.CONTACTS'
13315 !      include 'COMMON.TORSION'
13316 !      include 'COMMON.VECTORS'
13317 !      include 'COMMON.FFIELD'
13318       real(kind=8),dimension(3) :: ggg
13319 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13320 #ifdef MOMENT
13321       real(kind=8) :: scal_el=1.0d0
13322 #else
13323       real(kind=8) :: scal_el=0.5d0
13324 #endif
13325 !el local variables
13326       integer :: i,j,k,iteli,itelj,num_conti
13327       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13328       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13329                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13330                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13331
13332       evdw1=0.0D0
13333 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13334 !     & " iatel_e_vdw",iatel_e_vdw
13335       call flush(iout)
13336       do i=iatel_s_vdw,iatel_e_vdw
13337         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13338         dxi=dc(1,i)
13339         dyi=dc(2,i)
13340         dzi=dc(3,i)
13341         dx_normi=dc_norm(1,i)
13342         dy_normi=dc_norm(2,i)
13343         dz_normi=dc_norm(3,i)
13344         xmedi=c(1,i)+0.5d0*dxi
13345         ymedi=c(2,i)+0.5d0*dyi
13346         zmedi=c(3,i)+0.5d0*dzi
13347         num_conti=0
13348 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13349 !     &   ' ielend',ielend_vdw(i)
13350         call flush(iout)
13351         do j=ielstart_vdw(i),ielend_vdw(i)
13352           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13353 !el          ind=ind+1
13354           iteli=itel(i)
13355           itelj=itel(j)
13356           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13357           aaa=app(iteli,itelj)
13358           bbb=bpp(iteli,itelj)
13359           dxj=dc(1,j)
13360           dyj=dc(2,j)
13361           dzj=dc(3,j)
13362           dx_normj=dc_norm(1,j)
13363           dy_normj=dc_norm(2,j)
13364           dz_normj=dc_norm(3,j)
13365           xj=c(1,j)+0.5D0*dxj-xmedi
13366           yj=c(2,j)+0.5D0*dyj-ymedi
13367           zj=c(3,j)+0.5D0*dzj-zmedi
13368           rij=xj*xj+yj*yj+zj*zj
13369           rrmij=1.0D0/rij
13370           rij=dsqrt(rij)
13371           sss=sscale(rij/rpp(iteli,itelj))
13372           if (sss.gt.0.0d0) then
13373             rmij=1.0D0/rij
13374             r3ij=rrmij*rmij
13375             r6ij=r3ij*r3ij
13376             ev1=aaa*r6ij*r6ij
13377 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13378             if (j.eq.i+2) ev1=scal_el*ev1
13379             ev2=bbb*r6ij
13380             evdwij=ev1+ev2
13381             if (energy_dec) then
13382               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13383             endif
13384             evdw1=evdw1+evdwij*sss
13385 !
13386 ! Calculate contributions to the Cartesian gradient.
13387 !
13388             facvdw=-6*rrmij*(ev1+evdwij)*sss
13389             ggg(1)=facvdw*xj
13390             ggg(2)=facvdw*yj
13391             ggg(3)=facvdw*zj
13392             do k=1,3
13393               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13394               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13395             enddo
13396           endif
13397         enddo ! j
13398       enddo   ! i
13399       return
13400       end subroutine evdwpp_short
13401 !-----------------------------------------------------------------------------
13402       subroutine escp_long(evdw2,evdw2_14)
13403 !
13404 ! This subroutine calculates the excluded-volume interaction energy between
13405 ! peptide-group centers and side chains and its gradient in virtual-bond and
13406 ! side-chain vectors.
13407 !
13408 !      implicit real*8 (a-h,o-z)
13409 !      include 'DIMENSIONS'
13410 !      include 'COMMON.GEO'
13411 !      include 'COMMON.VAR'
13412 !      include 'COMMON.LOCAL'
13413 !      include 'COMMON.CHAIN'
13414 !      include 'COMMON.DERIV'
13415 !      include 'COMMON.INTERACT'
13416 !      include 'COMMON.FFIELD'
13417 !      include 'COMMON.IOUNITS'
13418 !      include 'COMMON.CONTROL'
13419       real(kind=8),dimension(3) :: ggg
13420 !el local variables
13421       integer :: i,iint,j,k,iteli,itypj
13422       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13423       real(kind=8) :: evdw2,evdw2_14,evdwij
13424       evdw2=0.0D0
13425       evdw2_14=0.0d0
13426 !d    print '(a)','Enter ESCP'
13427 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13428       do i=iatscp_s,iatscp_e
13429         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13430         iteli=itel(i)
13431         xi=0.5D0*(c(1,i)+c(1,i+1))
13432         yi=0.5D0*(c(2,i)+c(2,i+1))
13433         zi=0.5D0*(c(3,i)+c(3,i+1))
13434
13435         do iint=1,nscp_gr(i)
13436
13437         do j=iscpstart(i,iint),iscpend(i,iint)
13438           itypj=itype(j)
13439           if (itypj.eq.ntyp1) cycle
13440 ! Uncomment following three lines for SC-p interactions
13441 !         xj=c(1,nres+j)-xi
13442 !         yj=c(2,nres+j)-yi
13443 !         zj=c(3,nres+j)-zi
13444 ! Uncomment following three lines for Ca-p interactions
13445           xj=c(1,j)-xi
13446           yj=c(2,j)-yi
13447           zj=c(3,j)-zi
13448           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13449
13450           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13451
13452           if (sss.lt.1.0d0) then
13453
13454             fac=rrij**expon2
13455             e1=fac*fac*aad(itypj,iteli)
13456             e2=fac*bad(itypj,iteli)
13457             if (iabs(j-i) .le. 2) then
13458               e1=scal14*e1
13459               e2=scal14*e2
13460               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13461             endif
13462             evdwij=e1+e2
13463             evdw2=evdw2+evdwij*(1.0d0-sss)
13464             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13465                 'evdw2',i,j,sss,evdwij
13466 !
13467 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13468 !
13469             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13470             ggg(1)=xj*fac
13471             ggg(2)=yj*fac
13472             ggg(3)=zj*fac
13473 ! Uncomment following three lines for SC-p interactions
13474 !           do k=1,3
13475 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13476 !           enddo
13477 ! Uncomment following line for SC-p interactions
13478 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13479             do k=1,3
13480               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13481               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13482             enddo
13483           endif
13484         enddo
13485
13486         enddo ! iint
13487       enddo ! i
13488       do i=1,nct
13489         do j=1,3
13490           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13491           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13492           gradx_scp(j,i)=expon*gradx_scp(j,i)
13493         enddo
13494       enddo
13495 !******************************************************************************
13496 !
13497 !                              N O T E !!!
13498 !
13499 ! To save time the factor EXPON has been extracted from ALL components
13500 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13501 ! use!
13502 !
13503 !******************************************************************************
13504       return
13505       end subroutine escp_long
13506 !-----------------------------------------------------------------------------
13507       subroutine escp_short(evdw2,evdw2_14)
13508 !
13509 ! This subroutine calculates the excluded-volume interaction energy between
13510 ! peptide-group centers and side chains and its gradient in virtual-bond and
13511 ! side-chain vectors.
13512 !
13513 !      implicit real*8 (a-h,o-z)
13514 !      include 'DIMENSIONS'
13515 !      include 'COMMON.GEO'
13516 !      include 'COMMON.VAR'
13517 !      include 'COMMON.LOCAL'
13518 !      include 'COMMON.CHAIN'
13519 !      include 'COMMON.DERIV'
13520 !      include 'COMMON.INTERACT'
13521 !      include 'COMMON.FFIELD'
13522 !      include 'COMMON.IOUNITS'
13523 !      include 'COMMON.CONTROL'
13524       real(kind=8),dimension(3) :: ggg
13525 !el local variables
13526       integer :: i,iint,j,k,iteli,itypj
13527       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13528       real(kind=8) :: evdw2,evdw2_14,evdwij
13529       evdw2=0.0D0
13530       evdw2_14=0.0d0
13531 !d    print '(a)','Enter ESCP'
13532 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13533       do i=iatscp_s,iatscp_e
13534         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13535         iteli=itel(i)
13536         xi=0.5D0*(c(1,i)+c(1,i+1))
13537         yi=0.5D0*(c(2,i)+c(2,i+1))
13538         zi=0.5D0*(c(3,i)+c(3,i+1))
13539
13540         do iint=1,nscp_gr(i)
13541
13542         do j=iscpstart(i,iint),iscpend(i,iint)
13543           itypj=itype(j)
13544           if (itypj.eq.ntyp1) cycle
13545 ! Uncomment following three lines for SC-p interactions
13546 !         xj=c(1,nres+j)-xi
13547 !         yj=c(2,nres+j)-yi
13548 !         zj=c(3,nres+j)-zi
13549 ! Uncomment following three lines for Ca-p interactions
13550           xj=c(1,j)-xi
13551           yj=c(2,j)-yi
13552           zj=c(3,j)-zi
13553           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13554
13555           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13556
13557           if (sss.gt.0.0d0) then
13558
13559             fac=rrij**expon2
13560             e1=fac*fac*aad(itypj,iteli)
13561             e2=fac*bad(itypj,iteli)
13562             if (iabs(j-i) .le. 2) then
13563               e1=scal14*e1
13564               e2=scal14*e2
13565               evdw2_14=evdw2_14+(e1+e2)*sss
13566             endif
13567             evdwij=e1+e2
13568             evdw2=evdw2+evdwij*sss
13569             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13570                 'evdw2',i,j,sss,evdwij
13571 !
13572 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13573 !
13574             fac=-(evdwij+e1)*rrij*sss
13575             ggg(1)=xj*fac
13576             ggg(2)=yj*fac
13577             ggg(3)=zj*fac
13578 ! Uncomment following three lines for SC-p interactions
13579 !           do k=1,3
13580 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13581 !           enddo
13582 ! Uncomment following line for SC-p interactions
13583 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13584             do k=1,3
13585               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13586               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13587             enddo
13588           endif
13589         enddo
13590
13591         enddo ! iint
13592       enddo ! i
13593       do i=1,nct
13594         do j=1,3
13595           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13596           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13597           gradx_scp(j,i)=expon*gradx_scp(j,i)
13598         enddo
13599       enddo
13600 !******************************************************************************
13601 !
13602 !                              N O T E !!!
13603 !
13604 ! To save time the factor EXPON has been extracted from ALL components
13605 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13606 ! use!
13607 !
13608 !******************************************************************************
13609       return
13610       end subroutine escp_short
13611 !-----------------------------------------------------------------------------
13612 ! energy_p_new-sep_barrier.F
13613 !-----------------------------------------------------------------------------
13614       subroutine sc_grad_scale(scalfac)
13615 !      implicit real*8 (a-h,o-z)
13616       use calc_data
13617 !      include 'DIMENSIONS'
13618 !      include 'COMMON.CHAIN'
13619 !      include 'COMMON.DERIV'
13620 !      include 'COMMON.CALC'
13621 !      include 'COMMON.IOUNITS'
13622       real(kind=8),dimension(3) :: dcosom1,dcosom2
13623       real(kind=8) :: scalfac
13624 !el local variables
13625 !      integer :: i,j,k,l
13626
13627       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13628       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13629       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13630            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13631 ! diagnostics only
13632 !      eom1=0.0d0
13633 !      eom2=0.0d0
13634 !      eom12=evdwij*eps1_om12
13635 ! end diagnostics
13636 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13637 !     &  " sigder",sigder
13638 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13639 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13640       do k=1,3
13641         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13642         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13643       enddo
13644       do k=1,3
13645         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13646          *sss_ele_cut
13647       enddo
13648 !      write (iout,*) "gg",(gg(k),k=1,3)
13649       do k=1,3
13650         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13651                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13652                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13653                  *sss_ele_cut
13654         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13655                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13656                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13657          *sss_ele_cut
13658 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13659 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13660 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13661 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13662       enddo
13663 !
13664 ! Calculate the components of the gradient in DC and X
13665 !
13666       do l=1,3
13667         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13668         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13669       enddo
13670       return
13671       end subroutine sc_grad_scale
13672 !-----------------------------------------------------------------------------
13673 ! energy_split-sep.F
13674 !-----------------------------------------------------------------------------
13675       subroutine etotal_long(energia)
13676 !
13677 ! Compute the long-range slow-varying contributions to the energy
13678 !
13679 !      implicit real*8 (a-h,o-z)
13680 !      include 'DIMENSIONS'
13681       use MD_data, only: totT,usampl,eq_time
13682 #ifndef ISNAN
13683       external proc_proc
13684 #ifdef WINPGI
13685 !MS$ATTRIBUTES C ::  proc_proc
13686 #endif
13687 #endif
13688 #ifdef MPI
13689       include "mpif.h"
13690       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13691 #endif
13692 !      include 'COMMON.SETUP'
13693 !      include 'COMMON.IOUNITS'
13694 !      include 'COMMON.FFIELD'
13695 !      include 'COMMON.DERIV'
13696 !      include 'COMMON.INTERACT'
13697 !      include 'COMMON.SBRIDGE'
13698 !      include 'COMMON.CHAIN'
13699 !      include 'COMMON.VAR'
13700 !      include 'COMMON.LOCAL'
13701 !      include 'COMMON.MD'
13702       real(kind=8),dimension(0:n_ene) :: energia
13703 !el local variables
13704       integer :: i,n_corr,n_corr1,ierror,ierr
13705       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13706                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13707                   ecorr,ecorr5,ecorr6,eturn6,time00
13708 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13709 !elwrite(iout,*)"in etotal long"
13710
13711       if (modecalc.eq.12.or.modecalc.eq.14) then
13712 #ifdef MPI
13713 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13714 #else
13715         call int_from_cart1(.false.)
13716 #endif
13717       endif
13718 !elwrite(iout,*)"in etotal long"
13719
13720 #ifdef MPI
13721 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13722 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13723       call flush(iout)
13724       if (nfgtasks.gt.1) then
13725         time00=MPI_Wtime()
13726 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13727         if (fg_rank.eq.0) then
13728           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13729 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13730 !          call flush(iout)
13731 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13732 ! FG slaves as WEIGHTS array.
13733           weights_(1)=wsc
13734           weights_(2)=wscp
13735           weights_(3)=welec
13736           weights_(4)=wcorr
13737           weights_(5)=wcorr5
13738           weights_(6)=wcorr6
13739           weights_(7)=wel_loc
13740           weights_(8)=wturn3
13741           weights_(9)=wturn4
13742           weights_(10)=wturn6
13743           weights_(11)=wang
13744           weights_(12)=wscloc
13745           weights_(13)=wtor
13746           weights_(14)=wtor_d
13747           weights_(15)=wstrain
13748           weights_(16)=wvdwpp
13749           weights_(17)=wbond
13750           weights_(18)=scal14
13751           weights_(21)=wsccor
13752 ! FG Master broadcasts the WEIGHTS_ array
13753           call MPI_Bcast(weights_(1),n_ene,&
13754               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13755         else
13756 ! FG slaves receive the WEIGHTS array
13757           call MPI_Bcast(weights(1),n_ene,&
13758               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13759           wsc=weights(1)
13760           wscp=weights(2)
13761           welec=weights(3)
13762           wcorr=weights(4)
13763           wcorr5=weights(5)
13764           wcorr6=weights(6)
13765           wel_loc=weights(7)
13766           wturn3=weights(8)
13767           wturn4=weights(9)
13768           wturn6=weights(10)
13769           wang=weights(11)
13770           wscloc=weights(12)
13771           wtor=weights(13)
13772           wtor_d=weights(14)
13773           wstrain=weights(15)
13774           wvdwpp=weights(16)
13775           wbond=weights(17)
13776           scal14=weights(18)
13777           wsccor=weights(21)
13778         endif
13779         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13780           king,FG_COMM,IERR)
13781          time_Bcast=time_Bcast+MPI_Wtime()-time00
13782          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13783 !        call chainbuild_cart
13784 !        call int_from_cart1(.false.)
13785       endif
13786 !      write (iout,*) 'Processor',myrank,
13787 !     &  ' calling etotal_short ipot=',ipot
13788 !      call flush(iout)
13789 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13790 #endif
13791 !d    print *,'nnt=',nnt,' nct=',nct
13792 !
13793 !elwrite(iout,*)"in etotal long"
13794 ! Compute the side-chain and electrostatic interaction energy
13795 !
13796       goto (101,102,103,104,105,106) ipot
13797 ! Lennard-Jones potential.
13798   101 call elj_long(evdw)
13799 !d    print '(a)','Exit ELJ'
13800       goto 107
13801 ! Lennard-Jones-Kihara potential (shifted).
13802   102 call eljk_long(evdw)
13803       goto 107
13804 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13805   103 call ebp_long(evdw)
13806       goto 107
13807 ! Gay-Berne potential (shifted LJ, angular dependence).
13808   104 call egb_long(evdw)
13809       goto 107
13810 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13811   105 call egbv_long(evdw)
13812       goto 107
13813 ! Soft-sphere potential
13814   106 call e_softsphere(evdw)
13815 !
13816 ! Calculate electrostatic (H-bonding) energy of the main chain.
13817 !
13818   107 continue
13819       call vec_and_deriv
13820       if (ipot.lt.6) then
13821 #ifdef SPLITELE
13822          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13823              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13824              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13825              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13826 #else
13827          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13828              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13829              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13830              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13831 #endif
13832            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13833          else
13834             ees=0
13835             evdw1=0
13836             eel_loc=0
13837             eello_turn3=0
13838             eello_turn4=0
13839          endif
13840       else
13841 !        write (iout,*) "Soft-spheer ELEC potential"
13842         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13843          eello_turn4)
13844       endif
13845 !
13846 ! Calculate excluded-volume interaction energy between peptide groups
13847 ! and side chains.
13848 !
13849       if (ipot.lt.6) then
13850        if(wscp.gt.0d0) then
13851         call escp_long(evdw2,evdw2_14)
13852        else
13853         evdw2=0
13854         evdw2_14=0
13855        endif
13856       else
13857         call escp_soft_sphere(evdw2,evdw2_14)
13858       endif
13859 !
13860 ! 12/1/95 Multi-body terms
13861 !
13862       n_corr=0
13863       n_corr1=0
13864       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13865           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13866          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13867 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13868 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13869       else
13870          ecorr=0.0d0
13871          ecorr5=0.0d0
13872          ecorr6=0.0d0
13873          eturn6=0.0d0
13874       endif
13875       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13876          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13877       endif
13878 !
13879 ! If performing constraint dynamics, call the constraint energy
13880 !  after the equilibration time
13881       if(usampl.and.totT.gt.eq_time) then
13882          call EconstrQ
13883          call Econstr_back
13884       else
13885          Uconst=0.0d0
13886          Uconst_back=0.0d0
13887       endif
13888 !
13889 ! Sum the energies
13890 !
13891       do i=1,n_ene
13892         energia(i)=0.0d0
13893       enddo
13894       energia(1)=evdw
13895 #ifdef SCP14
13896       energia(2)=evdw2-evdw2_14
13897       energia(18)=evdw2_14
13898 #else
13899       energia(2)=evdw2
13900       energia(18)=0.0d0
13901 #endif
13902 #ifdef SPLITELE
13903       energia(3)=ees
13904       energia(16)=evdw1
13905 #else
13906       energia(3)=ees+evdw1
13907       energia(16)=0.0d0
13908 #endif
13909       energia(4)=ecorr
13910       energia(5)=ecorr5
13911       energia(6)=ecorr6
13912       energia(7)=eel_loc
13913       energia(8)=eello_turn3
13914       energia(9)=eello_turn4
13915       energia(10)=eturn6
13916       energia(20)=Uconst+Uconst_back
13917       call sum_energy(energia,.true.)
13918 !      write (iout,*) "Exit ETOTAL_LONG"
13919       call flush(iout)
13920       return
13921       end subroutine etotal_long
13922 !-----------------------------------------------------------------------------
13923       subroutine etotal_short(energia)
13924 !
13925 ! Compute the short-range fast-varying contributions to the energy
13926 !
13927 !      implicit real*8 (a-h,o-z)
13928 !      include 'DIMENSIONS'
13929 #ifndef ISNAN
13930       external proc_proc
13931 #ifdef WINPGI
13932 !MS$ATTRIBUTES C ::  proc_proc
13933 #endif
13934 #endif
13935 #ifdef MPI
13936       include "mpif.h"
13937       integer :: ierror,ierr
13938       real(kind=8),dimension(n_ene) :: weights_
13939       real(kind=8) :: time00
13940 #endif
13941 !      include 'COMMON.SETUP'
13942 !      include 'COMMON.IOUNITS'
13943 !      include 'COMMON.FFIELD'
13944 !      include 'COMMON.DERIV'
13945 !      include 'COMMON.INTERACT'
13946 !      include 'COMMON.SBRIDGE'
13947 !      include 'COMMON.CHAIN'
13948 !      include 'COMMON.VAR'
13949 !      include 'COMMON.LOCAL'
13950       real(kind=8),dimension(0:n_ene) :: energia
13951 !el local variables
13952       integer :: i,nres6
13953       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13954       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13955       nres6=6*nres
13956
13957 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13958 !      call flush(iout)
13959       if (modecalc.eq.12.or.modecalc.eq.14) then
13960 #ifdef MPI
13961         if (fg_rank.eq.0) call int_from_cart1(.false.)
13962 #else
13963         call int_from_cart1(.false.)
13964 #endif
13965       endif
13966 #ifdef MPI
13967 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13968 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13969 !      call flush(iout)
13970       if (nfgtasks.gt.1) then
13971         time00=MPI_Wtime()
13972 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13973         if (fg_rank.eq.0) then
13974           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13975 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13976 !          call flush(iout)
13977 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13978 ! FG slaves as WEIGHTS array.
13979           weights_(1)=wsc
13980           weights_(2)=wscp
13981           weights_(3)=welec
13982           weights_(4)=wcorr
13983           weights_(5)=wcorr5
13984           weights_(6)=wcorr6
13985           weights_(7)=wel_loc
13986           weights_(8)=wturn3
13987           weights_(9)=wturn4
13988           weights_(10)=wturn6
13989           weights_(11)=wang
13990           weights_(12)=wscloc
13991           weights_(13)=wtor
13992           weights_(14)=wtor_d
13993           weights_(15)=wstrain
13994           weights_(16)=wvdwpp
13995           weights_(17)=wbond
13996           weights_(18)=scal14
13997           weights_(21)=wsccor
13998 ! FG Master broadcasts the WEIGHTS_ array
13999           call MPI_Bcast(weights_(1),n_ene,&
14000               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14001         else
14002 ! FG slaves receive the WEIGHTS array
14003           call MPI_Bcast(weights(1),n_ene,&
14004               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
14005           wsc=weights(1)
14006           wscp=weights(2)
14007           welec=weights(3)
14008           wcorr=weights(4)
14009           wcorr5=weights(5)
14010           wcorr6=weights(6)
14011           wel_loc=weights(7)
14012           wturn3=weights(8)
14013           wturn4=weights(9)
14014           wturn6=weights(10)
14015           wang=weights(11)
14016           wscloc=weights(12)
14017           wtor=weights(13)
14018           wtor_d=weights(14)
14019           wstrain=weights(15)
14020           wvdwpp=weights(16)
14021           wbond=weights(17)
14022           scal14=weights(18)
14023           wsccor=weights(21)
14024         endif
14025 !        write (iout,*),"Processor",myrank," BROADCAST weights"
14026         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
14027           king,FG_COMM,IERR)
14028 !        write (iout,*) "Processor",myrank," BROADCAST c"
14029         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
14030           king,FG_COMM,IERR)
14031 !        write (iout,*) "Processor",myrank," BROADCAST dc"
14032         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
14033           king,FG_COMM,IERR)
14034 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
14035         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
14036           king,FG_COMM,IERR)
14037 !        write (iout,*) "Processor",myrank," BROADCAST theta"
14038         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
14039           king,FG_COMM,IERR)
14040 !        write (iout,*) "Processor",myrank," BROADCAST phi"
14041         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
14042           king,FG_COMM,IERR)
14043 !        write (iout,*) "Processor",myrank," BROADCAST alph"
14044         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
14045           king,FG_COMM,IERR)
14046 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
14047         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
14048           king,FG_COMM,IERR)
14049 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
14050         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
14051           king,FG_COMM,IERR)
14052          time_Bcast=time_Bcast+MPI_Wtime()-time00
14053 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
14054       endif
14055 !      write (iout,*) 'Processor',myrank,
14056 !     &  ' calling etotal_short ipot=',ipot
14057 !      call flush(iout)
14058 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
14059 #endif
14060 !      call int_from_cart1(.false.)
14061 !
14062 ! Compute the side-chain and electrostatic interaction energy
14063 !
14064       goto (101,102,103,104,105,106) ipot
14065 ! Lennard-Jones potential.
14066   101 call elj_short(evdw)
14067 !d    print '(a)','Exit ELJ'
14068       goto 107
14069 ! Lennard-Jones-Kihara potential (shifted).
14070   102 call eljk_short(evdw)
14071       goto 107
14072 ! Berne-Pechukas potential (dilated LJ, angular dependence).
14073   103 call ebp_short(evdw)
14074       goto 107
14075 ! Gay-Berne potential (shifted LJ, angular dependence).
14076   104 call egb_short(evdw)
14077       goto 107
14078 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
14079   105 call egbv_short(evdw)
14080       goto 107
14081 ! Soft-sphere potential - already dealt with in the long-range part
14082   106 evdw=0.0d0
14083 !  106 call e_softsphere_short(evdw)
14084 !
14085 ! Calculate electrostatic (H-bonding) energy of the main chain.
14086 !
14087   107 continue
14088 !
14089 ! Calculate the short-range part of Evdwpp
14090 !
14091       call evdwpp_short(evdw1)
14092 !
14093 ! Calculate the short-range part of ESCp
14094 !
14095       if (ipot.lt.6) then
14096         call escp_short(evdw2,evdw2_14)
14097       endif
14098 !
14099 ! Calculate the bond-stretching energy
14100 !
14101       call ebond(estr)
14102 !
14103 ! Calculate the disulfide-bridge and other energy and the contributions
14104 ! from other distance constraints.
14105       call edis(ehpb)
14106 !
14107 ! Calculate the virtual-bond-angle energy.
14108 !
14109       call ebend(ebe)
14110 !
14111 ! Calculate the SC local energy.
14112 !
14113       call vec_and_deriv
14114       call esc(escloc)
14115 !
14116 ! Calculate the virtual-bond torsional energy.
14117 !
14118       call etor(etors,edihcnstr)
14119 !
14120 ! 6/23/01 Calculate double-torsional energy
14121 !
14122       call etor_d(etors_d)
14123 !
14124 ! 21/5/07 Calculate local sicdechain correlation energy
14125 !
14126       if (wsccor.gt.0.0d0) then
14127         call eback_sc_corr(esccor)
14128       else
14129         esccor=0.0d0
14130       endif
14131 !
14132 ! Put energy components into an array
14133 !
14134       do i=1,n_ene
14135         energia(i)=0.0d0
14136       enddo
14137       energia(1)=evdw
14138 #ifdef SCP14
14139       energia(2)=evdw2-evdw2_14
14140       energia(18)=evdw2_14
14141 #else
14142       energia(2)=evdw2
14143       energia(18)=0.0d0
14144 #endif
14145 #ifdef SPLITELE
14146       energia(16)=evdw1
14147 #else
14148       energia(3)=evdw1
14149 #endif
14150       energia(11)=ebe
14151       energia(12)=escloc
14152       energia(13)=etors
14153       energia(14)=etors_d
14154       energia(15)=ehpb
14155       energia(17)=estr
14156       energia(19)=edihcnstr
14157       energia(21)=esccor
14158 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14159       call flush(iout)
14160       call sum_energy(energia,.true.)
14161 !      write (iout,*) "Exit ETOTAL_SHORT"
14162       call flush(iout)
14163       return
14164       end subroutine etotal_short
14165 !-----------------------------------------------------------------------------
14166 ! gnmr1.f
14167 !-----------------------------------------------------------------------------
14168       real(kind=8) function gnmr1(y,ymin,ymax)
14169 !      implicit none
14170       real(kind=8) :: y,ymin,ymax
14171       real(kind=8) :: wykl=4.0d0
14172       if (y.lt.ymin) then
14173         gnmr1=(ymin-y)**wykl/wykl
14174       else if (y.gt.ymax) then
14175         gnmr1=(y-ymax)**wykl/wykl
14176       else
14177         gnmr1=0.0d0
14178       endif
14179       return
14180       end function gnmr1
14181 !-----------------------------------------------------------------------------
14182       real(kind=8) function gnmr1prim(y,ymin,ymax)
14183 !      implicit none
14184       real(kind=8) :: y,ymin,ymax
14185       real(kind=8) :: wykl=4.0d0
14186       if (y.lt.ymin) then
14187         gnmr1prim=-(ymin-y)**(wykl-1)
14188       else if (y.gt.ymax) then
14189         gnmr1prim=(y-ymax)**(wykl-1)
14190       else
14191         gnmr1prim=0.0d0
14192       endif
14193       return
14194       end function gnmr1prim
14195 !-----------------------------------------------------------------------------
14196       real(kind=8) function harmonic(y,ymax)
14197 !      implicit none
14198       real(kind=8) :: y,ymax
14199       real(kind=8) :: wykl=2.0d0
14200       harmonic=(y-ymax)**wykl
14201       return
14202       end function harmonic
14203 !-----------------------------------------------------------------------------
14204       real(kind=8) function harmonicprim(y,ymax)
14205       real(kind=8) :: y,ymin,ymax
14206       real(kind=8) :: wykl=2.0d0
14207       harmonicprim=(y-ymax)*wykl
14208       return
14209       end function harmonicprim
14210 !-----------------------------------------------------------------------------
14211 ! gradient_p.F
14212 !-----------------------------------------------------------------------------
14213       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14214
14215       use io_base, only:intout,briefout
14216 !      implicit real*8 (a-h,o-z)
14217 !      include 'DIMENSIONS'
14218 !      include 'COMMON.CHAIN'
14219 !      include 'COMMON.DERIV'
14220 !      include 'COMMON.VAR'
14221 !      include 'COMMON.INTERACT'
14222 !      include 'COMMON.FFIELD'
14223 !      include 'COMMON.MD'
14224 !      include 'COMMON.IOUNITS'
14225       real(kind=8),external :: ufparm
14226       integer :: uiparm(1)
14227       real(kind=8) :: urparm(1)
14228       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14229       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14230       integer :: n,nf,ind,ind1,i,k,j
14231 !
14232 ! This subroutine calculates total internal coordinate gradient.
14233 ! Depending on the number of function evaluations, either whole energy
14234 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14235 ! internal coordinates are reevaluated or only the cartesian-in-internal
14236 ! coordinate derivatives are evaluated. The subroutine was designed to work
14237 ! with SUMSL.
14238 !
14239 !
14240       icg=mod(nf,2)+1
14241
14242 !d      print *,'grad',nf,icg
14243       if (nf-nfl+1) 20,30,40
14244    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14245 !    write (iout,*) 'grad 20'
14246       if (nf.eq.0) return
14247       goto 40
14248    30 call var_to_geom(n,x)
14249       call chainbuild
14250 !    write (iout,*) 'grad 30'
14251 !
14252 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14253 !
14254    40 call cartder
14255 !     write (iout,*) 'grad 40'
14256 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14257 !
14258 ! Convert the Cartesian gradient into internal-coordinate gradient.
14259 !
14260       ind=0
14261       ind1=0
14262       do i=1,nres-2
14263         gthetai=0.0D0
14264         gphii=0.0D0
14265         do j=i+1,nres-1
14266           ind=ind+1
14267 !         ind=indmat(i,j)
14268 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14269           do k=1,3
14270             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14271           enddo
14272           do k=1,3
14273             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14274           enddo
14275         enddo
14276         do j=i+1,nres-1
14277           ind1=ind1+1
14278 !         ind1=indmat(i,j)
14279 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14280           do k=1,3
14281             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14282             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14283           enddo
14284         enddo
14285         if (i.gt.1) g(i-1)=gphii
14286         if (n.gt.nphi) g(nphi+i)=gthetai
14287       enddo
14288       if (n.le.nphi+ntheta) goto 10
14289       do i=2,nres-1
14290         if (itype(i).ne.10) then
14291           galphai=0.0D0
14292           gomegai=0.0D0
14293           do k=1,3
14294             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14295           enddo
14296           do k=1,3
14297             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14298           enddo
14299           g(ialph(i,1))=galphai
14300           g(ialph(i,1)+nside)=gomegai
14301         endif
14302       enddo
14303 !
14304 ! Add the components corresponding to local energy terms.
14305 !
14306    10 continue
14307       do i=1,nvar
14308 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14309         g(i)=g(i)+gloc(i,icg)
14310       enddo
14311 ! Uncomment following three lines for diagnostics.
14312 !d    call intout
14313 !elwrite(iout,*) "in gradient after calling intout"
14314 !d    call briefout(0,0.0d0)
14315 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14316       return
14317       end subroutine gradient
14318 !-----------------------------------------------------------------------------
14319       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14320
14321       use comm_chu
14322 !      implicit real*8 (a-h,o-z)
14323 !      include 'DIMENSIONS'
14324 !      include 'COMMON.DERIV'
14325 !      include 'COMMON.IOUNITS'
14326 !      include 'COMMON.GEO'
14327       integer :: n,nf
14328 !el      integer :: jjj
14329 !el      common /chuju/ jjj
14330       real(kind=8) :: energia(0:n_ene)
14331       integer :: uiparm(1)
14332       real(kind=8) :: urparm(1)
14333       real(kind=8) :: f
14334       real(kind=8),external :: ufparm
14335       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14336 !     if (jjj.gt.0) then
14337 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14338 !     endif
14339       nfl=nf
14340       icg=mod(nf,2)+1
14341 !d      print *,'func',nf,nfl,icg
14342       call var_to_geom(n,x)
14343       call zerograd
14344       call chainbuild
14345 !d    write (iout,*) 'ETOTAL called from FUNC'
14346       call etotal(energia)
14347       call sum_gradient
14348       f=energia(0)
14349 !     if (jjj.gt.0) then
14350 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14351 !       write (iout,*) 'f=',etot
14352 !       jjj=0
14353 !     endif
14354       return
14355       end subroutine func
14356 !-----------------------------------------------------------------------------
14357       subroutine cartgrad
14358 !      implicit real*8 (a-h,o-z)
14359 !      include 'DIMENSIONS'
14360       use energy_data
14361       use MD_data, only: totT,usampl,eq_time
14362 #ifdef MPI
14363       include 'mpif.h'
14364 #endif
14365 !      include 'COMMON.CHAIN'
14366 !      include 'COMMON.DERIV'
14367 !      include 'COMMON.VAR'
14368 !      include 'COMMON.INTERACT'
14369 !      include 'COMMON.FFIELD'
14370 !      include 'COMMON.MD'
14371 !      include 'COMMON.IOUNITS'
14372 !      include 'COMMON.TIME1'
14373 !
14374       integer :: i,j
14375
14376 ! This subrouting calculates total Cartesian coordinate gradient.
14377 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14378 !
14379 !el#define DEBUG
14380 #ifdef TIMING
14381       time00=MPI_Wtime()
14382 #endif
14383       icg=1
14384       call sum_gradient
14385 #ifdef TIMING
14386 #endif
14387 !el      write (iout,*) "After sum_gradient"
14388 #ifdef DEBUG
14389 !el      write (iout,*) "After sum_gradient"
14390       do i=1,nres-1
14391         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14392         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14393       enddo
14394 #endif
14395 ! If performing constraint dynamics, add the gradients of the constraint energy
14396       if(usampl.and.totT.gt.eq_time) then
14397          do i=1,nct
14398            do j=1,3
14399              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14400              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14401            enddo
14402          enddo
14403          do i=1,nres-3
14404            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14405          enddo
14406          do i=1,nres-2
14407            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14408          enddo
14409       endif
14410 !elwrite (iout,*) "After sum_gradient"
14411 #ifdef TIMING
14412       time01=MPI_Wtime()
14413 #endif
14414       call intcartderiv
14415 !elwrite (iout,*) "After sum_gradient"
14416 #ifdef TIMING
14417       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14418 #endif
14419 !     call checkintcartgrad
14420 !     write(iout,*) 'calling int_to_cart'
14421 #ifdef DEBUG
14422       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14423 #endif
14424       do i=1,nct
14425         do j=1,3
14426           gcart(j,i)=gradc(j,i,icg)
14427           gxcart(j,i)=gradx(j,i,icg)
14428         enddo
14429 #ifdef DEBUG
14430         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14431           (gxcart(j,i),j=1,3),gloc(i,icg)
14432 #endif
14433       enddo
14434 #ifdef TIMING
14435       time01=MPI_Wtime()
14436 #endif
14437       call int_to_cart
14438 #ifdef TIMING
14439       time_inttocart=time_inttocart+MPI_Wtime()-time01
14440 #endif
14441 #ifdef DEBUG
14442       write (iout,*) "gcart and gxcart after int_to_cart"
14443       do i=0,nres-1
14444         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14445             (gxcart(j,i),j=1,3)
14446       enddo
14447 #endif
14448 #ifdef CARGRAD
14449 #ifdef DEBUG
14450       write (iout,*) "CARGRAD"
14451 #endif
14452       do i=nres,1,-1
14453         do j=1,3
14454           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14455 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14456         enddo
14457 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14458 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14459       enddo
14460 ! Correction: dummy residues
14461         if (nnt.gt.1) then
14462           do j=1,3
14463 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14464             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14465           enddo
14466         endif
14467         if (nct.lt.nres) then
14468           do j=1,3
14469 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14470             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14471           enddo
14472         endif
14473 #endif
14474 #ifdef TIMING
14475       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14476 #endif
14477 !el#undef DEBUG
14478       return
14479       end subroutine cartgrad
14480 !-----------------------------------------------------------------------------
14481       subroutine zerograd
14482 !      implicit real*8 (a-h,o-z)
14483 !      include 'DIMENSIONS'
14484 !      include 'COMMON.DERIV'
14485 !      include 'COMMON.CHAIN'
14486 !      include 'COMMON.VAR'
14487 !      include 'COMMON.MD'
14488 !      include 'COMMON.SCCOR'
14489 !
14490 !el local variables
14491       integer :: i,j,intertyp
14492 ! Initialize Cartesian-coordinate gradient
14493 !
14494 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14495 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14496
14497 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14498 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14499 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14500 !      allocate(gradcorr_long(3,nres))
14501 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14502 !      allocate(gcorr6_turn_long(3,nres))
14503 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14504
14505 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14506
14507 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14508 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14509
14510 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14511 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14512
14513 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14514 !      allocate(gscloc(3,nres)) !(3,maxres)
14515 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14516
14517
14518
14519 !      common /deriv_scloc/
14520 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14521 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14522 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14523 !      common /mpgrad/
14524 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14525
14526
14527
14528 !          gradc(j,i,icg)=0.0d0
14529 !          gradx(j,i,icg)=0.0d0
14530
14531 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14532 !elwrite(iout,*) "icg",icg
14533       do i=1,nres
14534         do j=1,3
14535           gvdwx(j,i)=0.0D0
14536           gradx_scp(j,i)=0.0D0
14537           gvdwc(j,i)=0.0D0
14538           gvdwc_scp(j,i)=0.0D0
14539           gvdwc_scpp(j,i)=0.0d0
14540           gelc(j,i)=0.0D0
14541           gelc_long(j,i)=0.0D0
14542           gradb(j,i)=0.0d0
14543           gradbx(j,i)=0.0d0
14544           gvdwpp(j,i)=0.0d0
14545           gel_loc(j,i)=0.0d0
14546           gel_loc_long(j,i)=0.0d0
14547           ghpbc(j,i)=0.0D0
14548           ghpbx(j,i)=0.0D0
14549           gcorr3_turn(j,i)=0.0d0
14550           gcorr4_turn(j,i)=0.0d0
14551           gradcorr(j,i)=0.0d0
14552           gradcorr_long(j,i)=0.0d0
14553           gradcorr5_long(j,i)=0.0d0
14554           gradcorr6_long(j,i)=0.0d0
14555           gcorr6_turn_long(j,i)=0.0d0
14556           gradcorr5(j,i)=0.0d0
14557           gradcorr6(j,i)=0.0d0
14558           gcorr6_turn(j,i)=0.0d0
14559           gsccorc(j,i)=0.0d0
14560           gsccorx(j,i)=0.0d0
14561           gradc(j,i,icg)=0.0d0
14562           gradx(j,i,icg)=0.0d0
14563           gscloc(j,i)=0.0d0
14564           gsclocx(j,i)=0.0d0
14565           do intertyp=1,3
14566            gloc_sc(intertyp,i,icg)=0.0d0
14567           enddo
14568         enddo
14569       enddo
14570 !
14571 ! Initialize the gradient of local energy terms.
14572 !
14573 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14574 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14575 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14576 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14577 !      allocate(gel_loc_turn3(nres))
14578 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14579 !      allocate(gsccor_loc(nres))       !(maxres)
14580
14581       do i=1,4*nres
14582         gloc(i,icg)=0.0D0
14583       enddo
14584       do i=1,nres
14585         gel_loc_loc(i)=0.0d0
14586         gcorr_loc(i)=0.0d0
14587         g_corr5_loc(i)=0.0d0
14588         g_corr6_loc(i)=0.0d0
14589         gel_loc_turn3(i)=0.0d0
14590         gel_loc_turn4(i)=0.0d0
14591         gel_loc_turn6(i)=0.0d0
14592         gsccor_loc(i)=0.0d0
14593       enddo
14594 ! initialize gcart and gxcart
14595 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14596       do i=0,nres
14597         do j=1,3
14598           gcart(j,i)=0.0d0
14599           gxcart(j,i)=0.0d0
14600         enddo
14601       enddo
14602       return
14603       end subroutine zerograd
14604 !-----------------------------------------------------------------------------
14605       real(kind=8) function fdum()
14606       fdum=0.0D0
14607       return
14608       end function fdum
14609 !-----------------------------------------------------------------------------
14610 ! intcartderiv.F
14611 !-----------------------------------------------------------------------------
14612       subroutine intcartderiv
14613 !      implicit real*8 (a-h,o-z)
14614 !      include 'DIMENSIONS'
14615 #ifdef MPI
14616       include 'mpif.h'
14617 #endif
14618 !      include 'COMMON.SETUP'
14619 !      include 'COMMON.CHAIN'
14620 !      include 'COMMON.VAR'
14621 !      include 'COMMON.GEO'
14622 !      include 'COMMON.INTERACT'
14623 !      include 'COMMON.DERIV'
14624 !      include 'COMMON.IOUNITS'
14625 !      include 'COMMON.LOCAL'
14626 !      include 'COMMON.SCCOR'
14627       real(kind=8) :: pi4,pi34
14628       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14629       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14630                     dcosomega,dsinomega !(3,3,maxres)
14631       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14632
14633       integer :: i,j,k
14634       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14635                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14636                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14637                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14638       integer :: nres2
14639       nres2=2*nres
14640
14641 !el from module energy-------------
14642 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14643 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14644 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14645
14646 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14647 !el      allocate(dsintau(3,3,3,0:nres2))
14648 !el      allocate(dtauangle(3,3,3,0:nres2))
14649 !el      allocate(domicron(3,2,2,0:nres2))
14650 !el      allocate(dcosomicron(3,2,2,0:nres2))
14651
14652
14653
14654 #if defined(MPI) && defined(PARINTDER)
14655       if (nfgtasks.gt.1 .and. me.eq.king) &
14656         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14657 #endif
14658       pi4 = 0.5d0*pipol
14659       pi34 = 3*pi4
14660
14661 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14662 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14663
14664 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14665       do i=1,nres
14666         do j=1,3
14667           dtheta(j,1,i)=0.0d0
14668           dtheta(j,2,i)=0.0d0
14669           dphi(j,1,i)=0.0d0
14670           dphi(j,2,i)=0.0d0
14671           dphi(j,3,i)=0.0d0
14672         enddo
14673       enddo
14674 ! Derivatives of theta's
14675 #if defined(MPI) && defined(PARINTDER)
14676 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14677       do i=max0(ithet_start-1,3),ithet_end
14678 #else
14679       do i=3,nres
14680 #endif
14681         cost=dcos(theta(i))
14682         sint=sqrt(1-cost*cost)
14683         do j=1,3
14684           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14685           vbld(i-1)
14686           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14687           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14688           vbld(i)
14689           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14690         enddo
14691       enddo
14692 #if defined(MPI) && defined(PARINTDER)
14693 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14694       do i=max0(ithet_start-1,3),ithet_end
14695 #else
14696       do i=3,nres
14697 #endif
14698       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14699         cost1=dcos(omicron(1,i))
14700         sint1=sqrt(1-cost1*cost1)
14701         cost2=dcos(omicron(2,i))
14702         sint2=sqrt(1-cost2*cost2)
14703        do j=1,3
14704 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14705           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14706           cost1*dc_norm(j,i-2))/ &
14707           vbld(i-1)
14708           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14709           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14710           +cost1*(dc_norm(j,i-1+nres)))/ &
14711           vbld(i-1+nres)
14712           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14713 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14714 !C Looks messy but better than if in loop
14715           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14716           +cost2*dc_norm(j,i-1))/ &
14717           vbld(i)
14718           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14719           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14720            +cost2*(-dc_norm(j,i-1+nres)))/ &
14721           vbld(i-1+nres)
14722 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14723           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14724         enddo
14725        endif
14726       enddo
14727 !elwrite(iout,*) "after vbld write"
14728 ! Derivatives of phi:
14729 ! If phi is 0 or 180 degrees, then the formulas
14730 ! have to be derived by power series expansion of the
14731 ! conventional formulas around 0 and 180.
14732 #ifdef PARINTDER
14733       do i=iphi1_start,iphi1_end
14734 #else
14735       do i=4,nres
14736 #endif
14737 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14738 ! the conventional case
14739         sint=dsin(theta(i))
14740         sint1=dsin(theta(i-1))
14741         sing=dsin(phi(i))
14742         cost=dcos(theta(i))
14743         cost1=dcos(theta(i-1))
14744         cosg=dcos(phi(i))
14745         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14746         fac0=1.0d0/(sint1*sint)
14747         fac1=cost*fac0
14748         fac2=cost1*fac0
14749         fac3=cosg*cost1/(sint1*sint1)
14750         fac4=cosg*cost/(sint*sint)
14751 !    Obtaining the gamma derivatives from sine derivative
14752        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14753            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14754            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14755          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14756          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14757          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14758          do j=1,3
14759             ctgt=cost/sint
14760             ctgt1=cost1/sint1
14761             cosg_inv=1.0d0/cosg
14762             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14763             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14764               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14765             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14766             dsinphi(j,2,i)= &
14767               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14768               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14769             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14770             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14771               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14772 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14773             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14774             endif
14775 ! Bug fixed 3/24/05 (AL)
14776          enddo
14777 !   Obtaining the gamma derivatives from cosine derivative
14778         else
14779            do j=1,3
14780            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14781            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14782            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14783            dc_norm(j,i-3))/vbld(i-2)
14784            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14785            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14786            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14787            dcostheta(j,1,i)
14788            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14789            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14790            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14791            dc_norm(j,i-1))/vbld(i)
14792            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14793            endif
14794          enddo
14795         endif
14796       enddo
14797 !alculate derivative of Tauangle
14798 #ifdef PARINTDER
14799       do i=itau_start,itau_end
14800 #else
14801       do i=3,nres
14802 !elwrite(iout,*) " vecpr",i,nres
14803 #endif
14804        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14805 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14806 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14807 !c dtauangle(j,intertyp,dervityp,residue number)
14808 !c INTERTYP=1 SC...Ca...Ca..Ca
14809 ! the conventional case
14810         sint=dsin(theta(i))
14811         sint1=dsin(omicron(2,i-1))
14812         sing=dsin(tauangle(1,i))
14813         cost=dcos(theta(i))
14814         cost1=dcos(omicron(2,i-1))
14815         cosg=dcos(tauangle(1,i))
14816 !elwrite(iout,*) " vecpr5",i,nres
14817         do j=1,3
14818 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14819 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14820         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14821 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14822         enddo
14823         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14824         fac0=1.0d0/(sint1*sint)
14825         fac1=cost*fac0
14826         fac2=cost1*fac0
14827         fac3=cosg*cost1/(sint1*sint1)
14828         fac4=cosg*cost/(sint*sint)
14829 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14830 !    Obtaining the gamma derivatives from sine derivative
14831        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14832            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14833            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14834          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14835          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14836          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14837         do j=1,3
14838             ctgt=cost/sint
14839             ctgt1=cost1/sint1
14840             cosg_inv=1.0d0/cosg
14841             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14842        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14843        *vbld_inv(i-2+nres)
14844             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14845             dsintau(j,1,2,i)= &
14846               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14847               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14848 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14849             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14850 ! Bug fixed 3/24/05 (AL)
14851             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14852               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14853 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14854             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14855          enddo
14856 !   Obtaining the gamma derivatives from cosine derivative
14857         else
14858            do j=1,3
14859            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14860            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14861            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14862            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14863            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14864            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14865            dcostheta(j,1,i)
14866            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14867            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14868            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14869            dc_norm(j,i-1))/vbld(i)
14870            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14871 !         write (iout,*) "else",i
14872          enddo
14873         endif
14874 !        do k=1,3
14875 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14876 !        enddo
14877       enddo
14878 !C Second case Ca...Ca...Ca...SC
14879 #ifdef PARINTDER
14880       do i=itau_start,itau_end
14881 #else
14882       do i=4,nres
14883 #endif
14884        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14885           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14886 ! the conventional case
14887         sint=dsin(omicron(1,i))
14888         sint1=dsin(theta(i-1))
14889         sing=dsin(tauangle(2,i))
14890         cost=dcos(omicron(1,i))
14891         cost1=dcos(theta(i-1))
14892         cosg=dcos(tauangle(2,i))
14893 !        do j=1,3
14894 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14895 !        enddo
14896         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14897         fac0=1.0d0/(sint1*sint)
14898         fac1=cost*fac0
14899         fac2=cost1*fac0
14900         fac3=cosg*cost1/(sint1*sint1)
14901         fac4=cosg*cost/(sint*sint)
14902 !    Obtaining the gamma derivatives from sine derivative
14903        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14904            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14905            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14906          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14907          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14908          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14909         do j=1,3
14910             ctgt=cost/sint
14911             ctgt1=cost1/sint1
14912             cosg_inv=1.0d0/cosg
14913             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14914               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14915 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14916 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14917             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14918             dsintau(j,2,2,i)= &
14919               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14920               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14921 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14922 !     & sing*ctgt*domicron(j,1,2,i),
14923 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14924             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14925 ! Bug fixed 3/24/05 (AL)
14926             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14927              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14928 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14929             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14930          enddo
14931 !   Obtaining the gamma derivatives from cosine derivative
14932         else
14933            do j=1,3
14934            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14935            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14936            dc_norm(j,i-3))/vbld(i-2)
14937            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14938            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14939            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14940            dcosomicron(j,1,1,i)
14941            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14942            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14943            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14944            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14945            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14946 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14947          enddo
14948         endif
14949       enddo
14950
14951 !CC third case SC...Ca...Ca...SC
14952 #ifdef PARINTDER
14953
14954       do i=itau_start,itau_end
14955 #else
14956       do i=3,nres
14957 #endif
14958 ! the conventional case
14959       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14960       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14961         sint=dsin(omicron(1,i))
14962         sint1=dsin(omicron(2,i-1))
14963         sing=dsin(tauangle(3,i))
14964         cost=dcos(omicron(1,i))
14965         cost1=dcos(omicron(2,i-1))
14966         cosg=dcos(tauangle(3,i))
14967         do j=1,3
14968         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14969 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14970         enddo
14971         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14972         fac0=1.0d0/(sint1*sint)
14973         fac1=cost*fac0
14974         fac2=cost1*fac0
14975         fac3=cosg*cost1/(sint1*sint1)
14976         fac4=cosg*cost/(sint*sint)
14977 !    Obtaining the gamma derivatives from sine derivative
14978        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14979            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14980            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14981          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14982          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14983          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14984         do j=1,3
14985             ctgt=cost/sint
14986             ctgt1=cost1/sint1
14987             cosg_inv=1.0d0/cosg
14988             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14989               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14990               *vbld_inv(i-2+nres)
14991             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14992             dsintau(j,3,2,i)= &
14993               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14994               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14995             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14996 ! Bug fixed 3/24/05 (AL)
14997             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14998               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14999               *vbld_inv(i-1+nres)
15000 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
15001             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
15002          enddo
15003 !   Obtaining the gamma derivatives from cosine derivative
15004         else
15005            do j=1,3
15006            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
15007            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
15008            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
15009            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
15010            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
15011            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
15012            dcosomicron(j,1,1,i)
15013            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
15014            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
15015            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
15016            dc_norm(j,i-1+nres))/vbld(i-1+nres)
15017            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
15018 !          write(iout,*) "else",i
15019          enddo
15020         endif
15021       enddo
15022
15023 #ifdef CRYST_SC
15024 !   Derivatives of side-chain angles alpha and omega
15025 #if defined(MPI) && defined(PARINTDER)
15026         do i=ibond_start,ibond_end
15027 #else
15028         do i=2,nres-1
15029 #endif
15030           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
15031              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
15032              fac6=fac5/vbld(i)
15033              fac7=fac5*fac5
15034              fac8=fac5/vbld(i+1)
15035              fac9=fac5/vbld(i+nres)
15036              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
15037              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
15038              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
15039              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
15040              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
15041              sina=sqrt(1-cosa*cosa)
15042              sino=dsin(omeg(i))
15043 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
15044              do j=1,3
15045                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
15046                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
15047                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
15048                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
15049                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
15050                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
15051                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
15052                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
15053                 vbld(i+nres))
15054                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
15055             enddo
15056 ! obtaining the derivatives of omega from sines
15057             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
15058                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
15059                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
15060                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
15061                dsin(theta(i+1)))
15062                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
15063                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
15064                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
15065                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
15066                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
15067                coso_inv=1.0d0/dcos(omeg(i))
15068                do j=1,3
15069                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
15070                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
15071                  (sino*dc_norm(j,i-1))/vbld(i)
15072                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
15073                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
15074                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
15075                  -sino*dc_norm(j,i)/vbld(i+1)
15076                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
15077                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
15078                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
15079                  vbld(i+nres)
15080                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
15081               enddo
15082            else
15083 !   obtaining the derivatives of omega from cosines
15084              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
15085              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
15086              fac12=fac10*sina
15087              fac13=fac12*fac12
15088              fac14=sina*sina
15089              do j=1,3
15090                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
15091                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
15092                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
15093                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
15094                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
15095                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
15096                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
15097                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
15098                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
15099                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
15100                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
15101                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
15102                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
15103                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
15104                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
15105             enddo
15106           endif
15107          else
15108            do j=1,3
15109              do k=1,3
15110                dalpha(k,j,i)=0.0d0
15111                domega(k,j,i)=0.0d0
15112              enddo
15113            enddo
15114          endif
15115        enddo
15116 #endif
15117 #if defined(MPI) && defined(PARINTDER)
15118       if (nfgtasks.gt.1) then
15119 #ifdef DEBUG
15120 !d      write (iout,*) "Gather dtheta"
15121 !d      call flush(iout)
15122       write (iout,*) "dtheta before gather"
15123       do i=1,nres
15124         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15125       enddo
15126 #endif
15127       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15128         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15129         king,FG_COMM,IERROR)
15130 #ifdef DEBUG
15131 !d      write (iout,*) "Gather dphi"
15132 !d      call flush(iout)
15133       write (iout,*) "dphi before gather"
15134       do i=1,nres
15135         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15136       enddo
15137 #endif
15138       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15139         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15140         king,FG_COMM,IERROR)
15141 !d      write (iout,*) "Gather dalpha"
15142 !d      call flush(iout)
15143 #ifdef CRYST_SC
15144       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15145         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15146         king,FG_COMM,IERROR)
15147 !d      write (iout,*) "Gather domega"
15148 !d      call flush(iout)
15149       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15150         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15151         king,FG_COMM,IERROR)
15152 #endif
15153       endif
15154 #endif
15155 #ifdef DEBUG
15156       write (iout,*) "dtheta after gather"
15157       do i=1,nres
15158         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15159       enddo
15160       write (iout,*) "dphi after gather"
15161       do i=1,nres
15162         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15163       enddo
15164       write (iout,*) "dalpha after gather"
15165       do i=1,nres
15166         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15167       enddo
15168       write (iout,*) "domega after gather"
15169       do i=1,nres
15170         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15171       enddo
15172 #endif
15173       return
15174       end subroutine intcartderiv
15175 !-----------------------------------------------------------------------------
15176       subroutine checkintcartgrad
15177 !      implicit real*8 (a-h,o-z)
15178 !      include 'DIMENSIONS'
15179 #ifdef MPI
15180       include 'mpif.h'
15181 #endif
15182 !      include 'COMMON.CHAIN'
15183 !      include 'COMMON.VAR'
15184 !      include 'COMMON.GEO'
15185 !      include 'COMMON.INTERACT'
15186 !      include 'COMMON.DERIV'
15187 !      include 'COMMON.IOUNITS'
15188 !      include 'COMMON.SETUP'
15189       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15190       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15191       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15192       real(kind=8),dimension(3) :: dc_norm_s
15193       real(kind=8) :: aincr=1.0d-5
15194       integer :: i,j
15195       real(kind=8) :: dcji
15196       do i=1,nres
15197         phi_s(i)=phi(i)
15198         theta_s(i)=theta(i)
15199         alph_s(i)=alph(i)
15200         omeg_s(i)=omeg(i)
15201       enddo
15202 ! Check theta gradient
15203       write (iout,*) &
15204        "Analytical (upper) and numerical (lower) gradient of theta"
15205       write (iout,*)
15206       do i=3,nres
15207         do j=1,3
15208           dcji=dc(j,i-2)
15209           dc(j,i-2)=dcji+aincr
15210           call chainbuild_cart
15211           call int_from_cart1(.false.)
15212           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15213           dc(j,i-2)=dcji
15214           dcji=dc(j,i-1)
15215           dc(j,i-1)=dc(j,i-1)+aincr
15216           call chainbuild_cart
15217           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15218           dc(j,i-1)=dcji
15219         enddo
15220 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15221 !el          (dtheta(j,2,i),j=1,3)
15222 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15223 !el          (dthetanum(j,2,i),j=1,3)
15224 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15225 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15226 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15227 !el        write (iout,*)
15228       enddo
15229 ! Check gamma gradient
15230       write (iout,*) &
15231        "Analytical (upper) and numerical (lower) gradient of gamma"
15232       do i=4,nres
15233         do j=1,3
15234           dcji=dc(j,i-3)
15235           dc(j,i-3)=dcji+aincr
15236           call chainbuild_cart
15237           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15238           dc(j,i-3)=dcji
15239           dcji=dc(j,i-2)
15240           dc(j,i-2)=dcji+aincr
15241           call chainbuild_cart
15242           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15243           dc(j,i-2)=dcji
15244           dcji=dc(j,i-1)
15245           dc(j,i-1)=dc(j,i-1)+aincr
15246           call chainbuild_cart
15247           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15248           dc(j,i-1)=dcji
15249         enddo
15250 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15251 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15252 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15253 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15254 !el        write (iout,'(5x,3(3f10.5,5x))') &
15255 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15256 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15257 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15258 !el        write (iout,*)
15259       enddo
15260 ! Check alpha gradient
15261       write (iout,*) &
15262        "Analytical (upper) and numerical (lower) gradient of alpha"
15263       do i=2,nres-1
15264        if(itype(i).ne.10) then
15265             do j=1,3
15266               dcji=dc(j,i-1)
15267               dc(j,i-1)=dcji+aincr
15268               call chainbuild_cart
15269               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15270               /aincr
15271               dc(j,i-1)=dcji
15272               dcji=dc(j,i)
15273               dc(j,i)=dcji+aincr
15274               call chainbuild_cart
15275               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15276               /aincr
15277               dc(j,i)=dcji
15278               dcji=dc(j,i+nres)
15279               dc(j,i+nres)=dc(j,i+nres)+aincr
15280               call chainbuild_cart
15281               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15282               /aincr
15283              dc(j,i+nres)=dcji
15284             enddo
15285           endif
15286 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15287 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15288 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15289 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15290 !el        write (iout,'(5x,3(3f10.5,5x))') &
15291 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15292 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15293 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15294 !el        write (iout,*)
15295       enddo
15296 !     Check omega gradient
15297       write (iout,*) &
15298        "Analytical (upper) and numerical (lower) gradient of omega"
15299       do i=2,nres-1
15300        if(itype(i).ne.10) then
15301             do j=1,3
15302               dcji=dc(j,i-1)
15303               dc(j,i-1)=dcji+aincr
15304               call chainbuild_cart
15305               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15306               /aincr
15307               dc(j,i-1)=dcji
15308               dcji=dc(j,i)
15309               dc(j,i)=dcji+aincr
15310               call chainbuild_cart
15311               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15312               /aincr
15313               dc(j,i)=dcji
15314               dcji=dc(j,i+nres)
15315               dc(j,i+nres)=dc(j,i+nres)+aincr
15316               call chainbuild_cart
15317               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15318               /aincr
15319              dc(j,i+nres)=dcji
15320             enddo
15321           endif
15322 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15323 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15324 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15325 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15326 !el        write (iout,'(5x,3(3f10.5,5x))') &
15327 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15328 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15329 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15330 !el        write (iout,*)
15331       enddo
15332       return
15333       end subroutine checkintcartgrad
15334 !-----------------------------------------------------------------------------
15335 ! q_measure.F
15336 !-----------------------------------------------------------------------------
15337       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15338 !      implicit real*8 (a-h,o-z)
15339 !      include 'DIMENSIONS'
15340 !      include 'COMMON.IOUNITS'
15341 !      include 'COMMON.CHAIN'
15342 !      include 'COMMON.INTERACT'
15343 !      include 'COMMON.VAR'
15344       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15345       integer :: kkk,nsep=3
15346       real(kind=8) :: qm        !dist,
15347       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15348       logical :: lprn=.false.
15349       logical :: flag
15350 !      real(kind=8) :: sigm,x
15351
15352 !el      sigm(x)=0.25d0*x     ! local function
15353       qqmax=1.0d10
15354       do kkk=1,nperm
15355       qq = 0.0d0
15356       nl=0
15357        if(flag) then
15358         do il=seg1+nsep,seg2
15359           do jl=seg1,il-nsep
15360             nl=nl+1
15361             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15362                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15363                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15364             dij=dist(il,jl)
15365             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15366             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15367               nl=nl+1
15368               d0ijCM=dsqrt( &
15369                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15370                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15371                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15372               dijCM=dist(il+nres,jl+nres)
15373               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15374             endif
15375             qq = qq+qqij+qqijCM
15376           enddo
15377         enddo
15378         qq = qq/nl
15379       else
15380       do il=seg1,seg2
15381         if((seg3-il).lt.3) then
15382              secseg=il+3
15383         else
15384              secseg=seg3
15385         endif
15386           do jl=secseg,seg4
15387             nl=nl+1
15388             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15389                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15390                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15391             dij=dist(il,jl)
15392             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15393             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15394               nl=nl+1
15395               d0ijCM=dsqrt( &
15396                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15397                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15398                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15399               dijCM=dist(il+nres,jl+nres)
15400               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15401             endif
15402             qq = qq+qqij+qqijCM
15403           enddo
15404         enddo
15405       qq = qq/nl
15406       endif
15407       if (qqmax.le.qq) qqmax=qq
15408       enddo
15409       qwolynes=1.0d0-qqmax
15410       return
15411       end function qwolynes
15412 !-----------------------------------------------------------------------------
15413       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15414 !      implicit real*8 (a-h,o-z)
15415 !      include 'DIMENSIONS'
15416 !      include 'COMMON.IOUNITS'
15417 !      include 'COMMON.CHAIN'
15418 !      include 'COMMON.INTERACT'
15419 !      include 'COMMON.VAR'
15420 !      include 'COMMON.MD'
15421       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15422       integer :: nsep=3, kkk
15423 !el      real(kind=8) :: dist
15424       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15425       logical :: lprn=.false.
15426       logical :: flag
15427       real(kind=8) :: sim,dd0,fac,ddqij
15428 !el      sigm(x)=0.25d0*x            ! local function
15429       do kkk=1,nperm
15430       do i=0,nres
15431         do j=1,3
15432           dqwol(j,i)=0.0d0
15433           dxqwol(j,i)=0.0d0
15434         enddo
15435       enddo
15436       nl=0
15437        if(flag) then
15438         do il=seg1+nsep,seg2
15439           do jl=seg1,il-nsep
15440             nl=nl+1
15441             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15442                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15443                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15444             dij=dist(il,jl)
15445             sim = 1.0d0/sigm(d0ij)
15446             sim = sim*sim
15447             dd0 = dij-d0ij
15448             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15449             do k=1,3
15450               ddqij = (c(k,il)-c(k,jl))*fac
15451               dqwol(k,il)=dqwol(k,il)+ddqij
15452               dqwol(k,jl)=dqwol(k,jl)-ddqij
15453             enddo
15454
15455             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15456               nl=nl+1
15457               d0ijCM=dsqrt( &
15458                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15459                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15460                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15461               dijCM=dist(il+nres,jl+nres)
15462               sim = 1.0d0/sigm(d0ijCM)
15463               sim = sim*sim
15464               dd0=dijCM-d0ijCM
15465               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15466               do k=1,3
15467                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15468                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15469                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15470               enddo
15471             endif
15472           enddo
15473         enddo
15474        else
15475         do il=seg1,seg2
15476         if((seg3-il).lt.3) then
15477              secseg=il+3
15478         else
15479              secseg=seg3
15480         endif
15481           do jl=secseg,seg4
15482             nl=nl+1
15483             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15484                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15485                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15486             dij=dist(il,jl)
15487             sim = 1.0d0/sigm(d0ij)
15488             sim = sim*sim
15489             dd0 = dij-d0ij
15490             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15491             do k=1,3
15492               ddqij = (c(k,il)-c(k,jl))*fac
15493               dqwol(k,il)=dqwol(k,il)+ddqij
15494               dqwol(k,jl)=dqwol(k,jl)-ddqij
15495             enddo
15496             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15497               nl=nl+1
15498               d0ijCM=dsqrt( &
15499                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15500                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15501                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15502               dijCM=dist(il+nres,jl+nres)
15503               sim = 1.0d0/sigm(d0ijCM)
15504               sim=sim*sim
15505               dd0 = dijCM-d0ijCM
15506               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15507               do k=1,3
15508                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15509                dxqwol(k,il)=dxqwol(k,il)+ddqij
15510                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15511               enddo
15512             endif
15513           enddo
15514         enddo
15515       endif
15516       enddo
15517        do i=0,nres
15518          do j=1,3
15519            dqwol(j,i)=dqwol(j,i)/nl
15520            dxqwol(j,i)=dxqwol(j,i)/nl
15521          enddo
15522        enddo
15523       return
15524       end subroutine qwolynes_prim
15525 !-----------------------------------------------------------------------------
15526       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15527 !      implicit real*8 (a-h,o-z)
15528 !      include 'DIMENSIONS'
15529 !      include 'COMMON.IOUNITS'
15530 !      include 'COMMON.CHAIN'
15531 !      include 'COMMON.INTERACT'
15532 !      include 'COMMON.VAR'
15533       integer :: seg1,seg2,seg3,seg4
15534       logical :: flag
15535       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15536       real(kind=8),dimension(3,0:2*nres) :: cdummy
15537       real(kind=8) :: q1,q2
15538       real(kind=8) :: delta=1.0d-10
15539       integer :: i,j
15540
15541       do i=0,nres
15542         do j=1,3
15543           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15544           cdummy(j,i)=c(j,i)
15545           c(j,i)=c(j,i)+delta
15546           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15547           qwolan(j,i)=(q2-q1)/delta
15548           c(j,i)=cdummy(j,i)
15549         enddo
15550       enddo
15551       do i=0,nres
15552         do j=1,3
15553           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15554           cdummy(j,i+nres)=c(j,i+nres)
15555           c(j,i+nres)=c(j,i+nres)+delta
15556           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15557           qwolxan(j,i)=(q2-q1)/delta
15558           c(j,i+nres)=cdummy(j,i+nres)
15559         enddo
15560       enddo
15561 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15562 !      do i=0,nct
15563 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15564 !      enddo
15565 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15566 !      do i=0,nct
15567 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15568 !      enddo
15569       return
15570       end subroutine qwol_num
15571 !-----------------------------------------------------------------------------
15572       subroutine EconstrQ
15573 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15574 !      implicit real*8 (a-h,o-z)
15575 !      include 'DIMENSIONS'
15576 !      include 'COMMON.CONTROL'
15577 !      include 'COMMON.VAR'
15578 !      include 'COMMON.MD'
15579       use MD_data
15580 !#ifndef LANG0
15581 !      include 'COMMON.LANGEVIN'
15582 !#else
15583 !      include 'COMMON.LANGEVIN.lang0'
15584 !#endif
15585 !      include 'COMMON.CHAIN'
15586 !      include 'COMMON.DERIV'
15587 !      include 'COMMON.GEO'
15588 !      include 'COMMON.LOCAL'
15589 !      include 'COMMON.INTERACT'
15590 !      include 'COMMON.IOUNITS'
15591 !      include 'COMMON.NAMES'
15592 !      include 'COMMON.TIME1'
15593       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15594       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15595                    duconst,duxconst
15596       integer :: kstart,kend,lstart,lend,idummy
15597       real(kind=8) :: delta=1.0d-7
15598       integer :: i,j,k,ii
15599       do i=0,nres
15600          do j=1,3
15601             duconst(j,i)=0.0d0
15602             dudconst(j,i)=0.0d0
15603             duxconst(j,i)=0.0d0
15604             dudxconst(j,i)=0.0d0
15605          enddo
15606       enddo
15607       Uconst=0.0d0
15608       do i=1,nfrag
15609          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15610            idummy,idummy)
15611          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15612 ! Calculating the derivatives of Constraint energy with respect to Q
15613          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15614            qinfrag(i,iset))
15615 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15616 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15617 !         hmnum=(hm2-hm1)/delta
15618 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15619 !     &   qinfrag(i,iset))
15620 !         write(iout,*) "harmonicnum frag", hmnum
15621 ! Calculating the derivatives of Q with respect to cartesian coordinates
15622          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15623           idummy,idummy)
15624 !         write(iout,*) "dqwol "
15625 !         do ii=1,nres
15626 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15627 !         enddo
15628 !         write(iout,*) "dxqwol "
15629 !         do ii=1,nres
15630 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15631 !         enddo
15632 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15633 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15634 !     &  ,idummy,idummy)
15635 !  The gradients of Uconst in Cs
15636          do ii=0,nres
15637             do j=1,3
15638                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15639                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15640             enddo
15641          enddo
15642       enddo
15643       do i=1,npair
15644          kstart=ifrag(1,ipair(1,i,iset),iset)
15645          kend=ifrag(2,ipair(1,i,iset),iset)
15646          lstart=ifrag(1,ipair(2,i,iset),iset)
15647          lend=ifrag(2,ipair(2,i,iset),iset)
15648          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15649          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15650 !  Calculating dU/dQ
15651          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15652 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15653 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15654 !         hmnum=(hm2-hm1)/delta
15655 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15656 !     &   qinpair(i,iset))
15657 !         write(iout,*) "harmonicnum pair ", hmnum
15658 ! Calculating dQ/dXi
15659          call qwolynes_prim(kstart,kend,.false.,&
15660           lstart,lend)
15661 !         write(iout,*) "dqwol "
15662 !         do ii=1,nres
15663 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15664 !         enddo
15665 !         write(iout,*) "dxqwol "
15666 !         do ii=1,nres
15667 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15668 !        enddo
15669 ! Calculating numerical gradients
15670 !        call qwol_num(kstart,kend,.false.
15671 !     &  ,lstart,lend)
15672 ! The gradients of Uconst in Cs
15673          do ii=0,nres
15674             do j=1,3
15675                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15676                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15677             enddo
15678          enddo
15679       enddo
15680 !      write(iout,*) "Uconst inside subroutine ", Uconst
15681 ! Transforming the gradients from Cs to dCs for the backbone
15682       do i=0,nres
15683          do j=i+1,nres
15684            do k=1,3
15685              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15686            enddo
15687          enddo
15688       enddo
15689 !  Transforming the gradients from Cs to dCs for the side chains
15690       do i=1,nres
15691          do j=1,3
15692            dudxconst(j,i)=duxconst(j,i)
15693          enddo
15694       enddo
15695 !      write(iout,*) "dU/ddc backbone "
15696 !       do ii=0,nres
15697 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15698 !      enddo
15699 !      write(iout,*) "dU/ddX side chain "
15700 !      do ii=1,nres
15701 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15702 !      enddo
15703 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15704 !      call dEconstrQ_num
15705       return
15706       end subroutine EconstrQ
15707 !-----------------------------------------------------------------------------
15708       subroutine dEconstrQ_num
15709 ! Calculating numerical dUconst/ddc and dUconst/ddx
15710 !      implicit real*8 (a-h,o-z)
15711 !      include 'DIMENSIONS'
15712 !      include 'COMMON.CONTROL'
15713 !      include 'COMMON.VAR'
15714 !      include 'COMMON.MD'
15715       use MD_data
15716 !#ifndef LANG0
15717 !      include 'COMMON.LANGEVIN'
15718 !#else
15719 !      include 'COMMON.LANGEVIN.lang0'
15720 !#endif
15721 !      include 'COMMON.CHAIN'
15722 !      include 'COMMON.DERIV'
15723 !      include 'COMMON.GEO'
15724 !      include 'COMMON.LOCAL'
15725 !      include 'COMMON.INTERACT'
15726 !      include 'COMMON.IOUNITS'
15727 !      include 'COMMON.NAMES'
15728 !      include 'COMMON.TIME1'
15729       real(kind=8) :: uzap1,uzap2
15730       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15731       integer :: kstart,kend,lstart,lend,idummy
15732       real(kind=8) :: delta=1.0d-7
15733 !el local variables
15734       integer :: i,ii,j
15735 !     real(kind=8) ::
15736 !     For the backbone
15737       do i=0,nres-1
15738          do j=1,3
15739             dUcartan(j,i)=0.0d0
15740             cdummy(j,i)=dc(j,i)
15741             dc(j,i)=dc(j,i)+delta
15742             call chainbuild_cart
15743             uzap2=0.0d0
15744             do ii=1,nfrag
15745              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15746                 idummy,idummy)
15747                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15748                 qinfrag(ii,iset))
15749             enddo
15750             do ii=1,npair
15751                kstart=ifrag(1,ipair(1,ii,iset),iset)
15752                kend=ifrag(2,ipair(1,ii,iset),iset)
15753                lstart=ifrag(1,ipair(2,ii,iset),iset)
15754                lend=ifrag(2,ipair(2,ii,iset),iset)
15755                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15756                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15757                  qinpair(ii,iset))
15758             enddo
15759             dc(j,i)=cdummy(j,i)
15760             call chainbuild_cart
15761             uzap1=0.0d0
15762              do ii=1,nfrag
15763              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15764                 idummy,idummy)
15765                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15766                 qinfrag(ii,iset))
15767             enddo
15768             do ii=1,npair
15769                kstart=ifrag(1,ipair(1,ii,iset),iset)
15770                kend=ifrag(2,ipair(1,ii,iset),iset)
15771                lstart=ifrag(1,ipair(2,ii,iset),iset)
15772                lend=ifrag(2,ipair(2,ii,iset),iset)
15773                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15774                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15775                 qinpair(ii,iset))
15776             enddo
15777             ducartan(j,i)=(uzap2-uzap1)/(delta)
15778          enddo
15779       enddo
15780 ! Calculating numerical gradients for dU/ddx
15781       do i=0,nres-1
15782          duxcartan(j,i)=0.0d0
15783          do j=1,3
15784             cdummy(j,i)=dc(j,i+nres)
15785             dc(j,i+nres)=dc(j,i+nres)+delta
15786             call chainbuild_cart
15787             uzap2=0.0d0
15788             do ii=1,nfrag
15789              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15790                 idummy,idummy)
15791                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15792                 qinfrag(ii,iset))
15793             enddo
15794             do ii=1,npair
15795                kstart=ifrag(1,ipair(1,ii,iset),iset)
15796                kend=ifrag(2,ipair(1,ii,iset),iset)
15797                lstart=ifrag(1,ipair(2,ii,iset),iset)
15798                lend=ifrag(2,ipair(2,ii,iset),iset)
15799                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15800                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15801                 qinpair(ii,iset))
15802             enddo
15803             dc(j,i+nres)=cdummy(j,i)
15804             call chainbuild_cart
15805             uzap1=0.0d0
15806              do ii=1,nfrag
15807                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15808                 ifrag(2,ii,iset),.true.,idummy,idummy)
15809                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15810                 qinfrag(ii,iset))
15811             enddo
15812             do ii=1,npair
15813                kstart=ifrag(1,ipair(1,ii,iset),iset)
15814                kend=ifrag(2,ipair(1,ii,iset),iset)
15815                lstart=ifrag(1,ipair(2,ii,iset),iset)
15816                lend=ifrag(2,ipair(2,ii,iset),iset)
15817                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15818                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15819                 qinpair(ii,iset))
15820             enddo
15821             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15822          enddo
15823       enddo
15824       write(iout,*) "Numerical dUconst/ddc backbone "
15825       do ii=0,nres
15826         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15827       enddo
15828 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15829 !      do ii=1,nres
15830 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15831 !      enddo
15832       return
15833       end subroutine dEconstrQ_num
15834 !-----------------------------------------------------------------------------
15835 ! ssMD.F
15836 !-----------------------------------------------------------------------------
15837       subroutine check_energies
15838
15839 !      use random, only: ran_number
15840
15841 !      implicit none
15842 !     Includes
15843 !      include 'DIMENSIONS'
15844 !      include 'COMMON.CHAIN'
15845 !      include 'COMMON.VAR'
15846 !      include 'COMMON.IOUNITS'
15847 !      include 'COMMON.SBRIDGE'
15848 !      include 'COMMON.LOCAL'
15849 !      include 'COMMON.GEO'
15850
15851 !     External functions
15852 !EL      double precision ran_number
15853 !EL      external ran_number
15854
15855 !     Local variables
15856       integer :: i,j,k,l,lmax,p,pmax
15857       real(kind=8) :: rmin,rmax
15858       real(kind=8) :: eij
15859
15860       real(kind=8) :: d
15861       real(kind=8) :: wi,rij,tj,pj
15862 !      return
15863
15864       i=5
15865       j=14
15866
15867       d=dsc(1)
15868       rmin=2.0D0
15869       rmax=12.0D0
15870
15871       lmax=10000
15872       pmax=1
15873
15874       do k=1,3
15875         c(k,i)=0.0D0
15876         c(k,j)=0.0D0
15877         c(k,nres+i)=0.0D0
15878         c(k,nres+j)=0.0D0
15879       enddo
15880
15881       do l=1,lmax
15882
15883 !t        wi=ran_number(0.0D0,pi)
15884 !        wi=ran_number(0.0D0,pi/6.0D0)
15885 !        wi=0.0D0
15886 !t        tj=ran_number(0.0D0,pi)
15887 !t        pj=ran_number(0.0D0,pi)
15888 !        pj=ran_number(0.0D0,pi/6.0D0)
15889 !        pj=0.0D0
15890
15891         do p=1,pmax
15892 !t           rij=ran_number(rmin,rmax)
15893
15894            c(1,j)=d*sin(pj)*cos(tj)
15895            c(2,j)=d*sin(pj)*sin(tj)
15896            c(3,j)=d*cos(pj)
15897
15898            c(3,nres+i)=-rij
15899
15900            c(1,i)=d*sin(wi)
15901            c(3,i)=-rij-d*cos(wi)
15902
15903            do k=1,3
15904               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15905               dc_norm(k,nres+i)=dc(k,nres+i)/d
15906               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15907               dc_norm(k,nres+j)=dc(k,nres+j)/d
15908            enddo
15909
15910            call dyn_ssbond_ene(i,j,eij)
15911         enddo
15912       enddo
15913       call exit(1)
15914       return
15915       end subroutine check_energies
15916 !-----------------------------------------------------------------------------
15917       subroutine dyn_ssbond_ene(resi,resj,eij)
15918 !      implicit none
15919 !      Includes
15920       use calc_data
15921       use comm_sschecks
15922 !      include 'DIMENSIONS'
15923 !      include 'COMMON.SBRIDGE'
15924 !      include 'COMMON.CHAIN'
15925 !      include 'COMMON.DERIV'
15926 !      include 'COMMON.LOCAL'
15927 !      include 'COMMON.INTERACT'
15928 !      include 'COMMON.VAR'
15929 !      include 'COMMON.IOUNITS'
15930 !      include 'COMMON.CALC'
15931 #ifndef CLUST
15932 #ifndef WHAM
15933        use MD_data
15934 !      include 'COMMON.MD'
15935 !      use MD, only: totT,t_bath
15936 #endif
15937 #endif
15938 !     External functions
15939 !EL      double precision h_base
15940 !EL      external h_base
15941
15942 !     Input arguments
15943       integer :: resi,resj
15944
15945 !     Output arguments
15946       real(kind=8) :: eij
15947
15948 !     Local variables
15949       logical :: havebond
15950       integer itypi,itypj
15951       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15952       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15953       real(kind=8),dimension(3) :: dcosom1,dcosom2
15954       real(kind=8) :: ed
15955       real(kind=8) :: pom1,pom2
15956       real(kind=8) :: ljA,ljB,ljXs
15957       real(kind=8),dimension(1:3) :: d_ljB
15958       real(kind=8) :: ssA,ssB,ssC,ssXs
15959       real(kind=8) :: ssxm,ljxm,ssm,ljm
15960       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15961       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15962       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15963 !-------FIRST METHOD
15964       real(kind=8) :: xm
15965       real(kind=8),dimension(1:3) :: d_xm
15966 !-------END FIRST METHOD
15967 !-------SECOND METHOD
15968 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15969 !-------END SECOND METHOD
15970
15971 !-------TESTING CODE
15972 !el      logical :: checkstop,transgrad
15973 !el      common /sschecks/ checkstop,transgrad
15974
15975       integer :: icheck,nicheck,jcheck,njcheck
15976       real(kind=8),dimension(-1:1) :: echeck
15977       real(kind=8) :: deps,ssx0,ljx0
15978 !-------END TESTING CODE
15979
15980       eij=0.0d0
15981       i=resi
15982       j=resj
15983
15984 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15985 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15986
15987       itypi=itype(i)
15988       dxi=dc_norm(1,nres+i)
15989       dyi=dc_norm(2,nres+i)
15990       dzi=dc_norm(3,nres+i)
15991       dsci_inv=vbld_inv(i+nres)
15992
15993       itypj=itype(j)
15994       xj=c(1,nres+j)-c(1,nres+i)
15995       yj=c(2,nres+j)-c(2,nres+i)
15996       zj=c(3,nres+j)-c(3,nres+i)
15997       dxj=dc_norm(1,nres+j)
15998       dyj=dc_norm(2,nres+j)
15999       dzj=dc_norm(3,nres+j)
16000       dscj_inv=vbld_inv(j+nres)
16001
16002       chi1=chi(itypi,itypj)
16003       chi2=chi(itypj,itypi)
16004       chi12=chi1*chi2
16005       chip1=chip(itypi)
16006       chip2=chip(itypj)
16007       chip12=chip1*chip2
16008       alf1=alp(itypi)
16009       alf2=alp(itypj)
16010       alf12=0.5D0*(alf1+alf2)
16011
16012       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16013       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
16014 !     The following are set in sc_angular
16015 !      erij(1)=xj*rij
16016 !      erij(2)=yj*rij
16017 !      erij(3)=zj*rij
16018 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
16019 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
16020 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
16021       call sc_angular
16022       rij=1.0D0/rij  ! Reset this so it makes sense
16023
16024       sig0ij=sigma(itypi,itypj)
16025       sig=sig0ij*dsqrt(1.0D0/sigsq)
16026
16027       ljXs=sig-sig0ij
16028       ljA=eps1*eps2rt**2*eps3rt**2
16029       ljB=ljA*bb(itypi,itypj)
16030       ljA=ljA*aa(itypi,itypj)
16031       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16032
16033       ssXs=d0cm
16034       deltat1=1.0d0-om1
16035       deltat2=1.0d0+om2
16036       deltat12=om2-om1+2.0d0
16037       cosphi=om12-om1*om2
16038       ssA=akcm
16039       ssB=akct*deltat12
16040       ssC=ss_depth &
16041            +akth*(deltat1*deltat1+deltat2*deltat2) &
16042            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
16043       ssxm=ssXs-0.5D0*ssB/ssA
16044
16045 !-------TESTING CODE
16046 !$$$c     Some extra output
16047 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
16048 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16049 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
16050 !$$$      if (ssx0.gt.0.0d0) then
16051 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
16052 !$$$      else
16053 !$$$        ssx0=ssxm
16054 !$$$      endif
16055 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
16056 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
16057 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
16058 !$$$      return
16059 !-------END TESTING CODE
16060
16061 !-------TESTING CODE
16062 !     Stop and plot energy and derivative as a function of distance
16063       if (checkstop) then
16064         ssm=ssC-0.25D0*ssB*ssB/ssA
16065         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16066         if (ssm.lt.ljm .and. &
16067              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
16068           nicheck=1000
16069           njcheck=1
16070           deps=0.5d-7
16071         else
16072           checkstop=.false.
16073         endif
16074       endif
16075       if (.not.checkstop) then
16076         nicheck=0
16077         njcheck=-1
16078       endif
16079
16080       do icheck=0,nicheck
16081       do jcheck=-1,njcheck
16082       if (checkstop) rij=(ssxm-1.0d0)+ &
16083              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
16084 !-------END TESTING CODE
16085
16086       if (rij.gt.ljxm) then
16087         havebond=.false.
16088         ljd=rij-ljXs
16089         fac=(1.0D0/ljd)**expon
16090         e1=fac*fac*aa(itypi,itypj)
16091         e2=fac*bb(itypi,itypj)
16092         eij=eps1*eps2rt*eps3rt*(e1+e2)
16093         eps2der=eij*eps3rt
16094         eps3der=eij*eps2rt
16095         eij=eij*eps2rt*eps3rt
16096
16097         sigder=-sig/sigsq
16098         e1=e1*eps1*eps2rt**2*eps3rt**2
16099         ed=-expon*(e1+eij)/ljd
16100         sigder=ed*sigder
16101         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16102         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16103         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
16104              -2.0D0*alf12*eps3der+sigder*sigsq_om12
16105       else if (rij.lt.ssxm) then
16106         havebond=.true.
16107         ssd=rij-ssXs
16108         eij=ssA*ssd*ssd+ssB*ssd+ssC
16109
16110         ed=2*akcm*ssd+akct*deltat12
16111         pom1=akct*ssd
16112         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
16113         eom1=-2*akth*deltat1-pom1-om2*pom2
16114         eom2= 2*akth*deltat2+pom1-om1*pom2
16115         eom12=pom2
16116       else
16117         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16118
16119         d_ssxm(1)=0.5D0*akct/ssA
16120         d_ssxm(2)=-d_ssxm(1)
16121         d_ssxm(3)=0.0D0
16122
16123         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16124         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16125         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16126         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16127
16128 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16129         xm=0.5d0*(ssxm+ljxm)
16130         do k=1,3
16131           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16132         enddo
16133         if (rij.lt.xm) then
16134           havebond=.true.
16135           ssm=ssC-0.25D0*ssB*ssB/ssA
16136           d_ssm(1)=0.5D0*akct*ssB/ssA
16137           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16138           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16139           d_ssm(3)=omega
16140           f1=(rij-xm)/(ssxm-xm)
16141           f2=(rij-ssxm)/(xm-ssxm)
16142           h1=h_base(f1,hd1)
16143           h2=h_base(f2,hd2)
16144           eij=ssm*h1+Ht*h2
16145           delta_inv=1.0d0/(xm-ssxm)
16146           deltasq_inv=delta_inv*delta_inv
16147           fac=ssm*hd1-Ht*hd2
16148           fac1=deltasq_inv*fac*(xm-rij)
16149           fac2=deltasq_inv*fac*(rij-ssxm)
16150           ed=delta_inv*(Ht*hd2-ssm*hd1)
16151           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16152           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16153           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16154         else
16155           havebond=.false.
16156           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16157           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16158           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16159           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16160                alf12/eps3rt)
16161           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16162           f1=(rij-ljxm)/(xm-ljxm)
16163           f2=(rij-xm)/(ljxm-xm)
16164           h1=h_base(f1,hd1)
16165           h2=h_base(f2,hd2)
16166           eij=Ht*h1+ljm*h2
16167           delta_inv=1.0d0/(ljxm-xm)
16168           deltasq_inv=delta_inv*delta_inv
16169           fac=Ht*hd1-ljm*hd2
16170           fac1=deltasq_inv*fac*(ljxm-rij)
16171           fac2=deltasq_inv*fac*(rij-xm)
16172           ed=delta_inv*(ljm*hd2-Ht*hd1)
16173           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16174           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16175           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16176         endif
16177 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16178
16179 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16180 !$$$        ssd=rij-ssXs
16181 !$$$        ljd=rij-ljXs
16182 !$$$        fac1=rij-ljxm
16183 !$$$        fac2=rij-ssxm
16184 !$$$
16185 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16186 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16187 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16188 !$$$
16189 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16190 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16191 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16192 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16193 !$$$        d_ssm(3)=omega
16194 !$$$
16195 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16196 !$$$        do k=1,3
16197 !$$$          d_ljm(k)=ljm*d_ljB(k)
16198 !$$$        enddo
16199 !$$$        ljm=ljm*ljB
16200 !$$$
16201 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16202 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16203 !$$$        d_ss(2)=akct*ssd
16204 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16205 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16206 !$$$        d_ss(3)=omega
16207 !$$$
16208 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16209 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16210 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16211 !$$$        do k=1,3
16212 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16213 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16214 !$$$        enddo
16215 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16216 !$$$
16217 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16218 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16219 !$$$        h1=h_base(f1,hd1)
16220 !$$$        h2=h_base(f2,hd2)
16221 !$$$        eij=ss*h1+ljf*h2
16222 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16223 !$$$        deltasq_inv=delta_inv*delta_inv
16224 !$$$        fac=ljf*hd2-ss*hd1
16225 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16226 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16227 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16228 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16229 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16230 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16231 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16232 !$$$
16233 !$$$        havebond=.false.
16234 !$$$        if (ed.gt.0.0d0) havebond=.true.
16235 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16236
16237       endif
16238
16239       if (havebond) then
16240 !#ifndef CLUST
16241 !#ifndef WHAM
16242 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16243 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16244 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16245 !        endif
16246 !#endif
16247 !#endif
16248         dyn_ssbond_ij(i,j)=eij
16249       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16250         dyn_ssbond_ij(i,j)=1.0d300
16251 !#ifndef CLUST
16252 !#ifndef WHAM
16253 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16254 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16255 !#endif
16256 !#endif
16257       endif
16258
16259 !-------TESTING CODE
16260 !el      if (checkstop) then
16261         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16262              "CHECKSTOP",rij,eij,ed
16263         echeck(jcheck)=eij
16264 !el      endif
16265       enddo
16266       if (checkstop) then
16267         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16268       endif
16269       enddo
16270       if (checkstop) then
16271         transgrad=.true.
16272         checkstop=.false.
16273       endif
16274 !-------END TESTING CODE
16275
16276       do k=1,3
16277         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16278         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16279       enddo
16280       do k=1,3
16281         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16282       enddo
16283       do k=1,3
16284         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16285              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16286              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16287         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16288              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16289              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16290       enddo
16291 !grad      do k=i,j-1
16292 !grad        do l=1,3
16293 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16294 !grad        enddo
16295 !grad      enddo
16296
16297       do l=1,3
16298         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16299         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16300       enddo
16301
16302       return
16303       end subroutine dyn_ssbond_ene
16304 !-----------------------------------------------------------------------------
16305       real(kind=8) function h_base(x,deriv)
16306 !     A smooth function going 0->1 in range [0,1]
16307 !     It should NOT be called outside range [0,1], it will not work there.
16308       implicit none
16309
16310 !     Input arguments
16311       real(kind=8) :: x
16312
16313 !     Output arguments
16314       real(kind=8) :: deriv
16315
16316 !     Local variables
16317       real(kind=8) :: xsq
16318
16319
16320 !     Two parabolas put together.  First derivative zero at extrema
16321 !$$$      if (x.lt.0.5D0) then
16322 !$$$        h_base=2.0D0*x*x
16323 !$$$        deriv=4.0D0*x
16324 !$$$      else
16325 !$$$        deriv=1.0D0-x
16326 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16327 !$$$        deriv=4.0D0*deriv
16328 !$$$      endif
16329
16330 !     Third degree polynomial.  First derivative zero at extrema
16331       h_base=x*x*(3.0d0-2.0d0*x)
16332       deriv=6.0d0*x*(1.0d0-x)
16333
16334 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16335 !$$$      xsq=x*x
16336 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16337 !$$$      deriv=x-1.0d0
16338 !$$$      deriv=deriv*deriv
16339 !$$$      deriv=30.0d0*xsq*deriv
16340
16341       return
16342       end function h_base
16343 !-----------------------------------------------------------------------------
16344       subroutine dyn_set_nss
16345 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16346 !      implicit none
16347       use MD_data, only: totT,t_bath
16348 !     Includes
16349 !      include 'DIMENSIONS'
16350 #ifdef MPI
16351       include "mpif.h"
16352 #endif
16353 !      include 'COMMON.SBRIDGE'
16354 !      include 'COMMON.CHAIN'
16355 !      include 'COMMON.IOUNITS'
16356 !      include 'COMMON.SETUP'
16357 !      include 'COMMON.MD'
16358 !     Local variables
16359       real(kind=8) :: emin
16360       integer :: i,j,imin,ierr
16361       integer :: diff,allnss,newnss
16362       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16363                 newihpb,newjhpb
16364       logical :: found
16365       integer,dimension(0:nfgtasks) :: i_newnss
16366       integer,dimension(0:nfgtasks) :: displ
16367       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16368       integer :: g_newnss
16369
16370       allnss=0
16371       do i=1,nres-1
16372         do j=i+1,nres
16373           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16374             allnss=allnss+1
16375             allflag(allnss)=0
16376             allihpb(allnss)=i
16377             alljhpb(allnss)=j
16378           endif
16379         enddo
16380       enddo
16381
16382 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16383
16384  1    emin=1.0d300
16385       do i=1,allnss
16386         if (allflag(i).eq.0 .and. &
16387              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16388           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16389           imin=i
16390         endif
16391       enddo
16392       if (emin.lt.1.0d300) then
16393         allflag(imin)=1
16394         do i=1,allnss
16395           if (allflag(i).eq.0 .and. &
16396                (allihpb(i).eq.allihpb(imin) .or. &
16397                alljhpb(i).eq.allihpb(imin) .or. &
16398                allihpb(i).eq.alljhpb(imin) .or. &
16399                alljhpb(i).eq.alljhpb(imin))) then
16400             allflag(i)=-1
16401           endif
16402         enddo
16403         goto 1
16404       endif
16405
16406 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16407
16408       newnss=0
16409       do i=1,allnss
16410         if (allflag(i).eq.1) then
16411           newnss=newnss+1
16412           newihpb(newnss)=allihpb(i)
16413           newjhpb(newnss)=alljhpb(i)
16414         endif
16415       enddo
16416
16417 #ifdef MPI
16418       if (nfgtasks.gt.1)then
16419
16420         call MPI_Reduce(newnss,g_newnss,1,&
16421           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16422         call MPI_Gather(newnss,1,MPI_INTEGER,&
16423                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16424         displ(0)=0
16425         do i=1,nfgtasks-1,1
16426           displ(i)=i_newnss(i-1)+displ(i-1)
16427         enddo
16428         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16429                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16430                          king,FG_COMM,IERR)
16431         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16432                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16433                          king,FG_COMM,IERR)
16434         if(fg_rank.eq.0) then
16435 !         print *,'g_newnss',g_newnss
16436 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16437 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16438          newnss=g_newnss
16439          do i=1,newnss
16440           newihpb(i)=g_newihpb(i)
16441           newjhpb(i)=g_newjhpb(i)
16442          enddo
16443         endif
16444       endif
16445 #endif
16446
16447       diff=newnss-nss
16448
16449 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16450
16451       do i=1,nss
16452         found=.false.
16453         do j=1,newnss
16454           if (idssb(i).eq.newihpb(j) .and. &
16455                jdssb(i).eq.newjhpb(j)) found=.true.
16456         enddo
16457 #ifndef CLUST
16458 #ifndef WHAM
16459         if (.not.found.and.fg_rank.eq.0) &
16460             write(iout,'(a15,f12.2,f8.1,2i5)') &
16461              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16462 #endif
16463 #endif
16464       enddo
16465
16466       do i=1,newnss
16467         found=.false.
16468         do j=1,nss
16469           if (newihpb(i).eq.idssb(j) .and. &
16470                newjhpb(i).eq.jdssb(j)) found=.true.
16471         enddo
16472 #ifndef CLUST
16473 #ifndef WHAM
16474         if (.not.found.and.fg_rank.eq.0) &
16475             write(iout,'(a15,f12.2,f8.1,2i5)') &
16476              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16477 #endif
16478 #endif
16479       enddo
16480
16481       nss=newnss
16482       do i=1,nss
16483         idssb(i)=newihpb(i)
16484         jdssb(i)=newjhpb(i)
16485       enddo
16486
16487       return
16488       end subroutine dyn_set_nss
16489 !-----------------------------------------------------------------------------
16490 #ifdef WHAM
16491       subroutine read_ssHist
16492 !      implicit none
16493 !      Includes
16494 !      include 'DIMENSIONS'
16495 !      include "DIMENSIONS.FREE"
16496 !      include 'COMMON.FREE'
16497 !     Local variables
16498       integer :: i,j
16499       character(len=80) :: controlcard
16500
16501       do i=1,dyn_nssHist
16502         call card_concat(controlcard,.true.)
16503         read(controlcard,*) &
16504              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16505       enddo
16506
16507       return
16508       end subroutine read_ssHist
16509 #endif
16510 !-----------------------------------------------------------------------------
16511       integer function indmat(i,j)
16512 !el
16513 ! get the position of the jth ijth fragment of the chain coordinate system
16514 ! in the fromto array.
16515         integer :: i,j
16516
16517         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16518       return
16519       end function indmat
16520 !-----------------------------------------------------------------------------
16521       real(kind=8) function sigm(x)
16522 !el
16523        real(kind=8) :: x
16524         sigm=0.25d0*x
16525       return
16526       end function sigm
16527 !-----------------------------------------------------------------------------
16528 !-----------------------------------------------------------------------------
16529       subroutine alloc_ener_arrays
16530 !EL Allocation of arrays used by module energy
16531       use MD_data, only: mset
16532 !el local variables
16533       integer :: i,j
16534
16535       if(nres.lt.100) then
16536         maxconts=nres
16537       elseif(nres.lt.200) then
16538         maxconts=0.8*nres       ! Max. number of contacts per residue
16539       else
16540         maxconts=0.6*nres ! (maxconts=maxres/4)
16541       endif
16542       maxcont=12*nres   ! Max. number of SC contacts
16543       maxvar=6*nres     ! Max. number of variables
16544 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16545       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16546 !----------------------
16547 ! arrays in subroutine init_int_table
16548 !el#ifdef MPI
16549 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16550 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16551 !el#endif
16552       allocate(nint_gr(nres))
16553       allocate(nscp_gr(nres))
16554       allocate(ielstart(nres))
16555       allocate(ielend(nres))
16556 !(maxres)
16557       allocate(istart(nres,maxint_gr))
16558       allocate(iend(nres,maxint_gr))
16559 !(maxres,maxint_gr)
16560       allocate(iscpstart(nres,maxint_gr))
16561       allocate(iscpend(nres,maxint_gr))
16562 !(maxres,maxint_gr)
16563       allocate(ielstart_vdw(nres))
16564       allocate(ielend_vdw(nres))
16565 !(maxres)
16566
16567       allocate(lentyp(0:nfgtasks-1))
16568 !(0:maxprocs-1)
16569 !----------------------
16570 ! commom.contacts
16571 !      common /contacts/
16572       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16573       allocate(icont(2,maxcont))
16574 !(2,maxcont)
16575 !      common /contacts1/
16576       allocate(num_cont(0:nres+4))
16577 !(maxres)
16578       allocate(jcont(maxconts,nres))
16579 !(maxconts,maxres)
16580       allocate(facont(maxconts,nres))
16581 !(maxconts,maxres)
16582       allocate(gacont(3,maxconts,nres))
16583 !(3,maxconts,maxres)
16584 !      common /contacts_hb/
16585       allocate(gacontp_hb1(3,maxconts,nres))
16586       allocate(gacontp_hb2(3,maxconts,nres))
16587       allocate(gacontp_hb3(3,maxconts,nres))
16588       allocate(gacontm_hb1(3,maxconts,nres))
16589       allocate(gacontm_hb2(3,maxconts,nres))
16590       allocate(gacontm_hb3(3,maxconts,nres))
16591       allocate(gacont_hbr(3,maxconts,nres))
16592       allocate(grij_hb_cont(3,maxconts,nres))
16593 !(3,maxconts,maxres)
16594       allocate(facont_hb(maxconts,nres))
16595       allocate(ees0p(maxconts,nres))
16596       allocate(ees0m(maxconts,nres))
16597       allocate(d_cont(maxconts,nres))
16598 !(maxconts,maxres)
16599       allocate(num_cont_hb(nres))
16600 !(maxres)
16601       allocate(jcont_hb(maxconts,nres))
16602 !(maxconts,maxres)
16603 !      common /rotat/
16604       allocate(Ug(2,2,nres))
16605       allocate(Ugder(2,2,nres))
16606       allocate(Ug2(2,2,nres))
16607       allocate(Ug2der(2,2,nres))
16608 !(2,2,maxres)
16609       allocate(obrot(2,nres))
16610       allocate(obrot2(2,nres))
16611       allocate(obrot_der(2,nres))
16612       allocate(obrot2_der(2,nres))
16613 !(2,maxres)
16614 !      common /precomp1/
16615       allocate(mu(2,nres))
16616       allocate(muder(2,nres))
16617       allocate(Ub2(2,nres))
16618       Ub2(1,:)=0.0d0
16619       Ub2(2,:)=0.0d0
16620       allocate(Ub2der(2,nres))
16621       allocate(Ctobr(2,nres))
16622       allocate(Ctobrder(2,nres))
16623       allocate(Dtobr2(2,nres))
16624       allocate(Dtobr2der(2,nres))
16625 !(2,maxres)
16626       allocate(EUg(2,2,nres))
16627       allocate(EUgder(2,2,nres))
16628       allocate(CUg(2,2,nres))
16629       allocate(CUgder(2,2,nres))
16630       allocate(DUg(2,2,nres))
16631       allocate(Dugder(2,2,nres))
16632       allocate(DtUg2(2,2,nres))
16633       allocate(DtUg2der(2,2,nres))
16634 !(2,2,maxres)
16635 !      common /precomp2/
16636       allocate(Ug2Db1t(2,nres))
16637       allocate(Ug2Db1tder(2,nres))
16638       allocate(CUgb2(2,nres))
16639       allocate(CUgb2der(2,nres))
16640 !(2,maxres)
16641       allocate(EUgC(2,2,nres))
16642       allocate(EUgCder(2,2,nres))
16643       allocate(EUgD(2,2,nres))
16644       allocate(EUgDder(2,2,nres))
16645       allocate(DtUg2EUg(2,2,nres))
16646       allocate(Ug2DtEUg(2,2,nres))
16647 !(2,2,maxres)
16648       allocate(Ug2DtEUgder(2,2,2,nres))
16649       allocate(DtUg2EUgder(2,2,2,nres))
16650 !(2,2,2,maxres)
16651 !      common /rotat_old/
16652       allocate(costab(nres))
16653       allocate(sintab(nres))
16654       allocate(costab2(nres))
16655       allocate(sintab2(nres))
16656 !(maxres)
16657 !      common /dipmat/
16658       allocate(a_chuj(2,2,maxconts,nres))
16659 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16660       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16661 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16662 !      common /contdistrib/
16663       allocate(ncont_sent(nres))
16664       allocate(ncont_recv(nres))
16665
16666       allocate(iat_sent(nres))
16667 !(maxres)
16668       allocate(iint_sent(4,nres,nres))
16669       allocate(iint_sent_local(4,nres,nres))
16670 !(4,maxres,maxres)
16671       allocate(iturn3_sent(4,0:nres+4))
16672       allocate(iturn4_sent(4,0:nres+4))
16673       allocate(iturn3_sent_local(4,nres))
16674       allocate(iturn4_sent_local(4,nres))
16675 !(4,maxres)
16676       allocate(itask_cont_from(0:nfgtasks-1))
16677       allocate(itask_cont_to(0:nfgtasks-1))
16678 !(0:max_fg_procs-1)
16679
16680
16681
16682 !----------------------
16683 ! commom.deriv;
16684 !      common /derivat/
16685       allocate(dcdv(6,maxdim))
16686       allocate(dxdv(6,maxdim))
16687 !(6,maxdim)
16688       allocate(dxds(6,nres))
16689 !(6,maxres)
16690       allocate(gradx(3,nres,0:2))
16691       allocate(gradc(3,nres,0:2))
16692 !(3,maxres,2)
16693       allocate(gvdwx(3,nres))
16694       allocate(gvdwc(3,nres))
16695       allocate(gelc(3,nres))
16696       allocate(gelc_long(3,nres))
16697       allocate(gvdwpp(3,nres))
16698       allocate(gvdwc_scpp(3,nres))
16699       allocate(gradx_scp(3,nres))
16700       allocate(gvdwc_scp(3,nres))
16701       allocate(ghpbx(3,nres))
16702       allocate(ghpbc(3,nres))
16703       allocate(gradcorr(3,nres))
16704       allocate(gradcorr_long(3,nres))
16705       allocate(gradcorr5_long(3,nres))
16706       allocate(gradcorr6_long(3,nres))
16707       allocate(gcorr6_turn_long(3,nres))
16708       allocate(gradxorr(3,nres))
16709       allocate(gradcorr5(3,nres))
16710       allocate(gradcorr6(3,nres))
16711 !(3,maxres)
16712       allocate(gloc(0:maxvar,0:2))
16713       allocate(gloc_x(0:maxvar,2))
16714 !(maxvar,2)
16715       allocate(gel_loc(3,nres))
16716       allocate(gel_loc_long(3,nres))
16717       allocate(gcorr3_turn(3,nres))
16718       allocate(gcorr4_turn(3,nres))
16719       allocate(gcorr6_turn(3,nres))
16720       allocate(gradb(3,nres))
16721       allocate(gradbx(3,nres))
16722 !(3,maxres)
16723       allocate(gel_loc_loc(maxvar))
16724       allocate(gel_loc_turn3(maxvar))
16725       allocate(gel_loc_turn4(maxvar))
16726       allocate(gel_loc_turn6(maxvar))
16727       allocate(gcorr_loc(maxvar))
16728       allocate(g_corr5_loc(maxvar))
16729       allocate(g_corr6_loc(maxvar))
16730 !(maxvar)
16731       allocate(gsccorc(3,nres))
16732       allocate(gsccorx(3,nres))
16733 !(3,maxres)
16734       allocate(gsccor_loc(nres))
16735 !(maxres)
16736       allocate(dtheta(3,2,nres))
16737 !(3,2,maxres)
16738       allocate(gscloc(3,nres))
16739       allocate(gsclocx(3,nres))
16740 !(3,maxres)
16741       allocate(dphi(3,3,nres))
16742       allocate(dalpha(3,3,nres))
16743       allocate(domega(3,3,nres))
16744 !(3,3,maxres)
16745 !      common /deriv_scloc/
16746       allocate(dXX_C1tab(3,nres))
16747       allocate(dYY_C1tab(3,nres))
16748       allocate(dZZ_C1tab(3,nres))
16749       allocate(dXX_Ctab(3,nres))
16750       allocate(dYY_Ctab(3,nres))
16751       allocate(dZZ_Ctab(3,nres))
16752       allocate(dXX_XYZtab(3,nres))
16753       allocate(dYY_XYZtab(3,nres))
16754       allocate(dZZ_XYZtab(3,nres))
16755 !(3,maxres)
16756 !      common /mpgrad/
16757       allocate(jgrad_start(nres))
16758       allocate(jgrad_end(nres))
16759 !(maxres)
16760 !----------------------
16761
16762 !      common /indices/
16763       allocate(ibond_displ(0:nfgtasks-1))
16764       allocate(ibond_count(0:nfgtasks-1))
16765       allocate(ithet_displ(0:nfgtasks-1))
16766       allocate(ithet_count(0:nfgtasks-1))
16767       allocate(iphi_displ(0:nfgtasks-1))
16768       allocate(iphi_count(0:nfgtasks-1))
16769       allocate(iphi1_displ(0:nfgtasks-1))
16770       allocate(iphi1_count(0:nfgtasks-1))
16771       allocate(ivec_displ(0:nfgtasks-1))
16772       allocate(ivec_count(0:nfgtasks-1))
16773       allocate(iset_displ(0:nfgtasks-1))
16774       allocate(iset_count(0:nfgtasks-1))
16775       allocate(iint_count(0:nfgtasks-1))
16776       allocate(iint_displ(0:nfgtasks-1))
16777 !(0:max_fg_procs-1)
16778 !----------------------
16779 ! common.MD
16780 !      common /mdgrad/
16781       allocate(gcart(3,0:nres))
16782       allocate(gxcart(3,0:nres))
16783 !(3,0:MAXRES)
16784       allocate(gradcag(3,nres))
16785       allocate(gradxag(3,nres))
16786 !(3,MAXRES)
16787 !      common /back_constr/
16788 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16789       allocate(dutheta(nres))
16790       allocate(dugamma(nres))
16791 !(maxres)
16792       allocate(duscdiff(3,nres))
16793       allocate(duscdiffx(3,nres))
16794 !(3,maxres)
16795 !el i io:read_fragments
16796 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16797 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16798 !      common /qmeas/
16799 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16800 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16801       allocate(mset(0:nprocs))  !(maxprocs/20)
16802       mset(:)=0
16803 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16804 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16805       allocate(dUdconst(3,0:nres))
16806       allocate(dUdxconst(3,0:nres))
16807       allocate(dqwol(3,0:nres))
16808       allocate(dxqwol(3,0:nres))
16809 !(3,0:MAXRES)
16810 !----------------------
16811 ! common.sbridge
16812 !      common /sbridge/ in io_common: read_bridge
16813 !el    allocate((:),allocatable :: iss  !(maxss)
16814 !      common /links/  in io_common: read_bridge
16815 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16816 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16817 !      common /dyn_ssbond/
16818 ! and side-chain vectors in theta or phi.
16819       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16820 !(maxres,maxres)
16821 !      do i=1,nres
16822 !        do j=i+1,nres
16823       dyn_ssbond_ij(:,:)=1.0d300
16824 !        enddo
16825 !      enddo
16826
16827       if (nss.gt.0) then
16828         allocate(idssb(nss),jdssb(nss))
16829 !(maxdim)
16830       endif
16831       allocate(dyn_ss_mask(nres))
16832 !(maxres)
16833       dyn_ss_mask(:)=.false.
16834 !----------------------
16835 ! common.sccor
16836 ! Parameters of the SCCOR term
16837 !      common/sccor/
16838 !el in io_conf: parmread
16839 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16840 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16841 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16842 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16843 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16844 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16845 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16846 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16847 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16848 !----------------
16849       allocate(gloc_sc(3,0:2*nres,0:10))
16850 !(3,0:maxres2,10)maxres2=2*maxres
16851       allocate(dcostau(3,3,3,2*nres))
16852       allocate(dsintau(3,3,3,2*nres))
16853       allocate(dtauangle(3,3,3,2*nres))
16854       allocate(dcosomicron(3,3,3,2*nres))
16855       allocate(domicron(3,3,3,2*nres))
16856 !(3,3,3,maxres2)maxres2=2*maxres
16857 !----------------------
16858 ! common.var
16859 !      common /restr/
16860       allocate(varall(maxvar))
16861 !(maxvar)(maxvar=6*maxres)
16862       allocate(mask_theta(nres))
16863       allocate(mask_phi(nres))
16864       allocate(mask_side(nres))
16865 !(maxres)
16866 !----------------------
16867 ! common.vectors
16868 !      common /vectors/
16869       allocate(uy(3,nres))
16870       allocate(uz(3,nres))
16871 !(3,maxres)
16872       allocate(uygrad(3,3,2,nres))
16873       allocate(uzgrad(3,3,2,nres))
16874 !(3,3,2,maxres)
16875
16876       return
16877       end subroutine alloc_ener_arrays
16878 !-----------------------------------------------------------------------------
16879 !-----------------------------------------------------------------------------
16880       end module energy