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         num_conti=0
2695         call eelecij(i,i+2,ees,evdw1,eel_loc)
2696         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2697         num_cont_hb(i)=num_conti
2698       enddo
2699       do i=iturn4_start,iturn4_end
2700         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2701           .or. itype(i+3).eq.ntyp1 &
2702           .or. itype(i+4).eq.ntyp1) cycle
2703         dxi=dc(1,i)
2704         dyi=dc(2,i)
2705         dzi=dc(3,i)
2706         dx_normi=dc_norm(1,i)
2707         dy_normi=dc_norm(2,i)
2708         dz_normi=dc_norm(3,i)
2709         xmedi=c(1,i)+0.5d0*dxi
2710         ymedi=c(2,i)+0.5d0*dyi
2711         zmedi=c(3,i)+0.5d0*dzi
2712         num_conti=num_cont_hb(i)
2713         call eelecij(i,i+3,ees,evdw1,eel_loc)
2714         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2715          call eturn4(i,eello_turn4)
2716         num_cont_hb(i)=num_conti
2717       enddo   ! i
2718 !
2719 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2720 !
2721       do i=iatel_s,iatel_e
2722         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2723         dxi=dc(1,i)
2724         dyi=dc(2,i)
2725         dzi=dc(3,i)
2726         dx_normi=dc_norm(1,i)
2727         dy_normi=dc_norm(2,i)
2728         dz_normi=dc_norm(3,i)
2729         xmedi=c(1,i)+0.5d0*dxi
2730         ymedi=c(2,i)+0.5d0*dyi
2731         zmedi=c(3,i)+0.5d0*dzi
2732 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2733         num_conti=num_cont_hb(i)
2734         do j=ielstart(i),ielend(i)
2735 !          write (iout,*) i,j,itype(i),itype(j)
2736           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2737           call eelecij(i,j,ees,evdw1,eel_loc)
2738         enddo ! j
2739         num_cont_hb(i)=num_conti
2740       enddo   ! i
2741 !      write (iout,*) "Number of loop steps in EELEC:",ind
2742 !d      do i=1,nres
2743 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2744 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2745 !d      enddo
2746 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2747 !cc      eel_loc=eel_loc+eello_turn3
2748 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2749       return
2750       end subroutine eelec
2751 !-----------------------------------------------------------------------------
2752       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2753
2754       use comm_locel
2755 !      implicit real*8 (a-h,o-z)
2756 !      include 'DIMENSIONS'
2757 #ifdef MPI
2758       include "mpif.h"
2759 #endif
2760 !      include 'COMMON.CONTROL'
2761 !      include 'COMMON.IOUNITS'
2762 !      include 'COMMON.GEO'
2763 !      include 'COMMON.VAR'
2764 !      include 'COMMON.LOCAL'
2765 !      include 'COMMON.CHAIN'
2766 !      include 'COMMON.DERIV'
2767 !      include 'COMMON.INTERACT'
2768 !      include 'COMMON.CONTACTS'
2769 !      include 'COMMON.TORSION'
2770 !      include 'COMMON.VECTORS'
2771 !      include 'COMMON.FFIELD'
2772 !      include 'COMMON.TIME1'
2773       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2774       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2775       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2776 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2777       real(kind=8),dimension(4) :: muij
2778 !el      integer :: num_conti,j1,j2
2779 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2780 !el        dz_normi,xmedi,ymedi,zmedi
2781
2782 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2783 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2784 !el          num_conti,j1,j2
2785
2786 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2787 #ifdef MOMENT
2788       real(kind=8) :: scal_el=1.0d0
2789 #else
2790       real(kind=8) :: scal_el=0.5d0
2791 #endif
2792 ! 12/13/98
2793 ! 13-go grudnia roku pamietnego...
2794       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2795                                              0.0d0,1.0d0,0.0d0,&
2796                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2797 !      integer :: maxconts=nres/4
2798 !el local variables
2799       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
2800       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
2801       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
2802       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
2803                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
2804                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
2805                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
2806                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
2807                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
2808                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
2809                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
2810 !      maxconts=nres/4
2811 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
2812 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
2813
2814 !          time00=MPI_Wtime()
2815 !d      write (iout,*) "eelecij",i,j
2816 !          ind=ind+1
2817           iteli=itel(i)
2818           itelj=itel(j)
2819           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2820           aaa=app(iteli,itelj)
2821           bbb=bpp(iteli,itelj)
2822           ael6i=ael6(iteli,itelj)
2823           ael3i=ael3(iteli,itelj)
2824           dxj=dc(1,j)
2825           dyj=dc(2,j)
2826           dzj=dc(3,j)
2827           dx_normj=dc_norm(1,j)
2828           dy_normj=dc_norm(2,j)
2829           dz_normj=dc_norm(3,j)
2830           xj=c(1,j)+0.5D0*dxj-xmedi
2831           yj=c(2,j)+0.5D0*dyj-ymedi
2832           zj=c(3,j)+0.5D0*dzj-zmedi
2833           rij=xj*xj+yj*yj+zj*zj
2834           rrmij=1.0D0/rij
2835           rij=dsqrt(rij)
2836           rmij=1.0D0/rij
2837           r3ij=rrmij*rmij
2838           r6ij=r3ij*r3ij
2839           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2840           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2841           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2842           fac=cosa-3.0D0*cosb*cosg
2843           ev1=aaa*r6ij*r6ij
2844 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2845           if (j.eq.i+2) ev1=scal_el*ev1
2846           ev2=bbb*r6ij
2847           fac3=ael6i*r6ij
2848           fac4=ael3i*r3ij
2849           evdwij=ev1+ev2
2850           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2851           el2=fac4*fac
2852           eesij=el1+el2
2853 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
2854           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2855           ees=ees+eesij
2856           evdw1=evdw1+evdwij
2857 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2858 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2859 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2860 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
2861
2862           if (energy_dec) then
2863 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
2864 !                  'evdw1',i,j,evdwij,&
2865 !                  iteli,itelj,aaa,evdw1
2866               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2867               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2868           endif
2869 !
2870 ! Calculate contributions to the Cartesian gradient.
2871 !
2872 #ifdef SPLITELE
2873           facvdw=-6*rrmij*(ev1+evdwij)
2874           facel=-3*rrmij*(el1+eesij)
2875           fac1=fac
2876           erij(1)=xj*rmij
2877           erij(2)=yj*rmij
2878           erij(3)=zj*rmij
2879 !
2880 ! Radial derivatives. First process both termini of the fragment (i,j)
2881 !
2882           ggg(1)=facel*xj
2883           ggg(2)=facel*yj
2884           ggg(3)=facel*zj
2885 !          do k=1,3
2886 !            ghalf=0.5D0*ggg(k)
2887 !            gelc(k,i)=gelc(k,i)+ghalf
2888 !            gelc(k,j)=gelc(k,j)+ghalf
2889 !          enddo
2890 ! 9/28/08 AL Gradient compotents will be summed only at the end
2891           do k=1,3
2892             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2893             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2894           enddo
2895 !
2896 ! Loop over residues i+1 thru j-1.
2897 !
2898 !grad          do k=i+1,j-1
2899 !grad            do l=1,3
2900 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2901 !grad            enddo
2902 !grad          enddo
2903           ggg(1)=facvdw*xj
2904           ggg(2)=facvdw*yj
2905           ggg(3)=facvdw*zj
2906 !          do k=1,3
2907 !            ghalf=0.5D0*ggg(k)
2908 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2909 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2910 !          enddo
2911 ! 9/28/08 AL Gradient compotents will be summed only at the end
2912           do k=1,3
2913             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2914             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2915           enddo
2916 !
2917 ! Loop over residues i+1 thru j-1.
2918 !
2919 !grad          do k=i+1,j-1
2920 !grad            do l=1,3
2921 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2922 !grad            enddo
2923 !grad          enddo
2924 #else
2925           facvdw=ev1+evdwij
2926           facel=el1+eesij
2927           fac1=fac
2928           fac=-3*rrmij*(facvdw+facvdw+facel)
2929           erij(1)=xj*rmij
2930           erij(2)=yj*rmij
2931           erij(3)=zj*rmij
2932 !
2933 ! Radial derivatives. First process both termini of the fragment (i,j)
2934 !
2935           ggg(1)=fac*xj
2936           ggg(2)=fac*yj
2937           ggg(3)=fac*zj
2938 !          do k=1,3
2939 !            ghalf=0.5D0*ggg(k)
2940 !            gelc(k,i)=gelc(k,i)+ghalf
2941 !            gelc(k,j)=gelc(k,j)+ghalf
2942 !          enddo
2943 ! 9/28/08 AL Gradient compotents will be summed only at the end
2944           do k=1,3
2945             gelc_long(k,j)=gelc(k,j)+ggg(k)
2946             gelc_long(k,i)=gelc(k,i)-ggg(k)
2947           enddo
2948 !
2949 ! Loop over residues i+1 thru j-1.
2950 !
2951 !grad          do k=i+1,j-1
2952 !grad            do l=1,3
2953 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2954 !grad            enddo
2955 !grad          enddo
2956 ! 9/28/08 AL Gradient compotents will be summed only at the end
2957           ggg(1)=facvdw*xj
2958           ggg(2)=facvdw*yj
2959           ggg(3)=facvdw*zj
2960           do k=1,3
2961             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2962             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2963           enddo
2964 #endif
2965 !
2966 ! Angular part
2967 !
2968           ecosa=2.0D0*fac3*fac1+fac4
2969           fac4=-3.0D0*fac4
2970           fac3=-6.0D0*fac3
2971           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2972           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2973           do k=1,3
2974             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2975             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2976           enddo
2977 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2978 !d   &          (dcosg(k),k=1,3)
2979           do k=1,3
2980             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2981           enddo
2982 !          do k=1,3
2983 !            ghalf=0.5D0*ggg(k)
2984 !            gelc(k,i)=gelc(k,i)+ghalf
2985 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2986 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2987 !            gelc(k,j)=gelc(k,j)+ghalf
2988 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2989 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2990 !          enddo
2991 !grad          do k=i+1,j-1
2992 !grad            do l=1,3
2993 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2994 !grad            enddo
2995 !grad          enddo
2996           do k=1,3
2997             gelc(k,i)=gelc(k,i) &
2998                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
2999                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3000             gelc(k,j)=gelc(k,j) &
3001                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3002                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3003             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3004             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3005           enddo
3006           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3007               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3008               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3009 !
3010 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3011 !   energy of a peptide unit is assumed in the form of a second-order
3012 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3013 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3014 !   are computed for EVERY pair of non-contiguous peptide groups.
3015 !
3016           if (j.lt.nres-1) then
3017             j1=j+1
3018             j2=j-1
3019           else
3020             j1=j-1
3021             j2=j-2
3022           endif
3023           kkk=0
3024           do k=1,2
3025             do l=1,2
3026               kkk=kkk+1
3027               muij(kkk)=mu(k,i)*mu(l,j)
3028             enddo
3029           enddo
3030 !d         write (iout,*) 'EELEC: i',i,' j',j
3031 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3032 !d          write(iout,*) 'muij',muij
3033           ury=scalar(uy(1,i),erij)
3034           urz=scalar(uz(1,i),erij)
3035           vry=scalar(uy(1,j),erij)
3036           vrz=scalar(uz(1,j),erij)
3037           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3038           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3039           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3040           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3041           fac=dsqrt(-ael6i)*r3ij
3042           a22=a22*fac
3043           a23=a23*fac
3044           a32=a32*fac
3045           a33=a33*fac
3046 !d          write (iout,'(4i5,4f10.5)')
3047 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3048 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3049 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3050 !d     &      uy(:,j),uz(:,j)
3051 !d          write (iout,'(4f10.5)')
3052 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3053 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3054 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3055 !d           write (iout,'(9f10.5/)')
3056 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3057 ! Derivatives of the elements of A in virtual-bond vectors
3058           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3059           do k=1,3
3060             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3061             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3062             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3063             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3064             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3065             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3066             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3067             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3068             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3069             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3070             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3071             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3072           enddo
3073 ! Compute radial contributions to the gradient
3074           facr=-3.0d0*rrmij
3075           a22der=a22*facr
3076           a23der=a23*facr
3077           a32der=a32*facr
3078           a33der=a33*facr
3079           agg(1,1)=a22der*xj
3080           agg(2,1)=a22der*yj
3081           agg(3,1)=a22der*zj
3082           agg(1,2)=a23der*xj
3083           agg(2,2)=a23der*yj
3084           agg(3,2)=a23der*zj
3085           agg(1,3)=a32der*xj
3086           agg(2,3)=a32der*yj
3087           agg(3,3)=a32der*zj
3088           agg(1,4)=a33der*xj
3089           agg(2,4)=a33der*yj
3090           agg(3,4)=a33der*zj
3091 ! Add the contributions coming from er
3092           fac3=-3.0d0*fac
3093           do k=1,3
3094             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3095             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3096             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3097             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3098           enddo
3099           do k=1,3
3100 ! Derivatives in DC(i)
3101 !grad            ghalf1=0.5d0*agg(k,1)
3102 !grad            ghalf2=0.5d0*agg(k,2)
3103 !grad            ghalf3=0.5d0*agg(k,3)
3104 !grad            ghalf4=0.5d0*agg(k,4)
3105             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3106             -3.0d0*uryg(k,2)*vry)!+ghalf1
3107             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3108             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3109             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3110             -3.0d0*urzg(k,2)*vry)!+ghalf3
3111             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3112             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3113 ! Derivatives in DC(i+1)
3114             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3115             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3116             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3117             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3118             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3119             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3120             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3121             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3122 ! Derivatives in DC(j)
3123             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3124             -3.0d0*vryg(k,2)*ury)!+ghalf1
3125             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3126             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3127             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3128             -3.0d0*vryg(k,2)*urz)!+ghalf3
3129             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3130             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3131 ! Derivatives in DC(j+1) or DC(nres-1)
3132             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3133             -3.0d0*vryg(k,3)*ury)
3134             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3135             -3.0d0*vrzg(k,3)*ury)
3136             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3137             -3.0d0*vryg(k,3)*urz)
3138             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3139             -3.0d0*vrzg(k,3)*urz)
3140 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3141 !grad              do l=1,4
3142 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3143 !grad              enddo
3144 !grad            endif
3145           enddo
3146           acipa(1,1)=a22
3147           acipa(1,2)=a23
3148           acipa(2,1)=a32
3149           acipa(2,2)=a33
3150           a22=-a22
3151           a23=-a23
3152           do l=1,2
3153             do k=1,3
3154               agg(k,l)=-agg(k,l)
3155               aggi(k,l)=-aggi(k,l)
3156               aggi1(k,l)=-aggi1(k,l)
3157               aggj(k,l)=-aggj(k,l)
3158               aggj1(k,l)=-aggj1(k,l)
3159             enddo
3160           enddo
3161           if (j.lt.nres-1) then
3162             a22=-a22
3163             a32=-a32
3164             do l=1,3,2
3165               do k=1,3
3166                 agg(k,l)=-agg(k,l)
3167                 aggi(k,l)=-aggi(k,l)
3168                 aggi1(k,l)=-aggi1(k,l)
3169                 aggj(k,l)=-aggj(k,l)
3170                 aggj1(k,l)=-aggj1(k,l)
3171               enddo
3172             enddo
3173           else
3174             a22=-a22
3175             a23=-a23
3176             a32=-a32
3177             a33=-a33
3178             do l=1,4
3179               do k=1,3
3180                 agg(k,l)=-agg(k,l)
3181                 aggi(k,l)=-aggi(k,l)
3182                 aggi1(k,l)=-aggi1(k,l)
3183                 aggj(k,l)=-aggj(k,l)
3184                 aggj1(k,l)=-aggj1(k,l)
3185               enddo
3186             enddo
3187           endif
3188           ENDIF ! WCORR
3189           IF (wel_loc.gt.0.0d0) THEN
3190 ! Contribution to the local-electrostatic energy coming from the i-j pair
3191           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3192            +a33*muij(4)
3193 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3194
3195           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3196                   'eelloc',i,j,eel_loc_ij
3197 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3198 !          if (energy_dec) write (iout,*) "muij",muij
3199 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3200
3201           eel_loc=eel_loc+eel_loc_ij
3202 ! Partial derivatives in virtual-bond dihedral angles gamma
3203           if (i.gt.1) &
3204           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3205                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3206                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3207           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3208                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3209                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3210 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3211           do l=1,3
3212             ggg(l)=agg(l,1)*muij(1)+ &
3213                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3214             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3215             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3216 !grad            ghalf=0.5d0*ggg(l)
3217 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3218 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3219           enddo
3220 !grad          do k=i+1,j2
3221 !grad            do l=1,3
3222 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3223 !grad            enddo
3224 !grad          enddo
3225 ! Remaining derivatives of eello
3226           do l=1,3
3227             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
3228                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3229             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
3230                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3231             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
3232                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3233             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
3234                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3235           enddo
3236           ENDIF
3237 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3238 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3239           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3240              .and. num_conti.le.maxconts) then
3241 !            write (iout,*) i,j," entered corr"
3242 !
3243 ! Calculate the contact function. The ith column of the array JCONT will
3244 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3245 ! greater than I). The arrays FACONT and GACONT will contain the values of
3246 ! the contact function and its derivative.
3247 !           r0ij=1.02D0*rpp(iteli,itelj)
3248 !           r0ij=1.11D0*rpp(iteli,itelj)
3249             r0ij=2.20D0*rpp(iteli,itelj)
3250 !           r0ij=1.55D0*rpp(iteli,itelj)
3251             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3252 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3253             if (fcont.gt.0.0D0) then
3254               num_conti=num_conti+1
3255               if (num_conti.gt.maxconts) then
3256 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3257 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3258                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3259                                ' will skip next contacts for this conf.', num_conti
3260               else
3261                 jcont_hb(num_conti,i)=j
3262 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3263 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3264                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3265                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3266 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3267 !  terms.
3268                 d_cont(num_conti,i)=rij
3269 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3270 !     --- Electrostatic-interaction matrix ---
3271                 a_chuj(1,1,num_conti,i)=a22
3272                 a_chuj(1,2,num_conti,i)=a23
3273                 a_chuj(2,1,num_conti,i)=a32
3274                 a_chuj(2,2,num_conti,i)=a33
3275 !     --- Gradient of rij
3276                 do kkk=1,3
3277                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3278                 enddo
3279                 kkll=0
3280                 do k=1,2
3281                   do l=1,2
3282                     kkll=kkll+1
3283                     do m=1,3
3284                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3285                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3286                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3287                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3288                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3289                     enddo
3290                   enddo
3291                 enddo
3292                 ENDIF
3293                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3294 ! Calculate contact energies
3295                 cosa4=4.0D0*cosa
3296                 wij=cosa-3.0D0*cosb*cosg
3297                 cosbg1=cosb+cosg
3298                 cosbg2=cosb-cosg
3299 !               fac3=dsqrt(-ael6i)/r0ij**3
3300                 fac3=dsqrt(-ael6i)*r3ij
3301 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3302                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3303                 if (ees0tmp.gt.0) then
3304                   ees0pij=dsqrt(ees0tmp)
3305                 else
3306                   ees0pij=0
3307                 endif
3308 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3309                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3310                 if (ees0tmp.gt.0) then
3311                   ees0mij=dsqrt(ees0tmp)
3312                 else
3313                   ees0mij=0
3314                 endif
3315 !               ees0mij=0.0D0
3316                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3317                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3318 ! Diagnostics. Comment out or remove after debugging!
3319 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3320 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3321 !               ees0m(num_conti,i)=0.0D0
3322 ! End diagnostics.
3323 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3324 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3325 ! Angular derivatives of the contact function
3326                 ees0pij1=fac3/ees0pij
3327                 ees0mij1=fac3/ees0mij
3328                 fac3p=-3.0D0*fac3*rrmij
3329                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3330                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3331 !               ees0mij1=0.0D0
3332                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3333                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3334                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3335                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3336                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3337                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3338                 ecosap=ecosa1+ecosa2
3339                 ecosbp=ecosb1+ecosb2
3340                 ecosgp=ecosg1+ecosg2
3341                 ecosam=ecosa1-ecosa2
3342                 ecosbm=ecosb1-ecosb2
3343                 ecosgm=ecosg1-ecosg2
3344 ! Diagnostics
3345 !               ecosap=ecosa1
3346 !               ecosbp=ecosb1
3347 !               ecosgp=ecosg1
3348 !               ecosam=0.0D0
3349 !               ecosbm=0.0D0
3350 !               ecosgm=0.0D0
3351 ! End diagnostics
3352                 facont_hb(num_conti,i)=fcont
3353                 fprimcont=fprimcont/rij
3354 !d              facont_hb(num_conti,i)=1.0D0
3355 ! Following line is for diagnostics.
3356 !d              fprimcont=0.0D0
3357                 do k=1,3
3358                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3359                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3360                 enddo
3361                 do k=1,3
3362                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3363                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3364                 enddo
3365                 gggp(1)=gggp(1)+ees0pijp*xj
3366                 gggp(2)=gggp(2)+ees0pijp*yj
3367                 gggp(3)=gggp(3)+ees0pijp*zj
3368                 gggm(1)=gggm(1)+ees0mijp*xj
3369                 gggm(2)=gggm(2)+ees0mijp*yj
3370                 gggm(3)=gggm(3)+ees0mijp*zj
3371 ! Derivatives due to the contact function
3372                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3373                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3374                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3375                 do k=1,3
3376 !
3377 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3378 !          following the change of gradient-summation algorithm.
3379 !
3380 !grad                  ghalfp=0.5D0*gggp(k)
3381 !grad                  ghalfm=0.5D0*gggm(k)
3382                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3383                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3384                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3385                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3386                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3387                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3388                   gacontp_hb3(k,num_conti,i)=gggp(k)
3389                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3390                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3391                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3392                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3393                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3394                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3395                   gacontm_hb3(k,num_conti,i)=gggm(k)
3396                 enddo
3397 ! Diagnostics. Comment out or remove after debugging!
3398 !diag           do k=1,3
3399 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3400 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3401 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3402 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3403 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3404 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3405 !diag           enddo
3406               ENDIF ! wcorr
3407               endif  ! num_conti.le.maxconts
3408             endif  ! fcont.gt.0
3409           endif    ! j.gt.i+1
3410           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3411             do k=1,4
3412               do l=1,3
3413                 ghalf=0.5d0*agg(l,k)
3414                 aggi(l,k)=aggi(l,k)+ghalf
3415                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3416                 aggj(l,k)=aggj(l,k)+ghalf
3417               enddo
3418             enddo
3419             if (j.eq.nres-1 .and. i.lt.j-2) then
3420               do k=1,4
3421                 do l=1,3
3422                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3423                 enddo
3424               enddo
3425             endif
3426           endif
3427 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3428       return
3429       end subroutine eelecij
3430 !-----------------------------------------------------------------------------
3431       subroutine eturn3(i,eello_turn3)
3432 ! Third- and fourth-order contributions from turns
3433
3434       use comm_locel
3435 !      implicit real*8 (a-h,o-z)
3436 !      include 'DIMENSIONS'
3437 !      include 'COMMON.IOUNITS'
3438 !      include 'COMMON.GEO'
3439 !      include 'COMMON.VAR'
3440 !      include 'COMMON.LOCAL'
3441 !      include 'COMMON.CHAIN'
3442 !      include 'COMMON.DERIV'
3443 !      include 'COMMON.INTERACT'
3444 !      include 'COMMON.CONTACTS'
3445 !      include 'COMMON.TORSION'
3446 !      include 'COMMON.VECTORS'
3447 !      include 'COMMON.FFIELD'
3448 !      include 'COMMON.CONTROL'
3449       real(kind=8),dimension(3) :: ggg
3450       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3451         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3452       real(kind=8),dimension(2) :: auxvec,auxvec1
3453 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3454       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3455 !el      integer :: num_conti,j1,j2
3456 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3457 !el        dz_normi,xmedi,ymedi,zmedi
3458
3459 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3460 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3461 !el         num_conti,j1,j2
3462 !el local variables
3463       integer :: i,j,l
3464       real(kind=8) :: eello_turn3
3465
3466       j=i+2
3467 !      write (iout,*) "eturn3",i,j,j1,j2
3468       a_temp(1,1)=a22
3469       a_temp(1,2)=a23
3470       a_temp(2,1)=a32
3471       a_temp(2,2)=a33
3472 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3473 !
3474 !               Third-order contributions
3475 !
3476 !                 (i+2)o----(i+3)
3477 !                      | |
3478 !                      | |
3479 !                 (i+1)o----i
3480 !
3481 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3482 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
3483         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3484         call transpose2(auxmat(1,1),auxmat1(1,1))
3485         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3486         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3487         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3488                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3489 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
3490 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3491 !d     &    ' eello_turn3_num',4*eello_turn3_num
3492 ! Derivatives in gamma(i)
3493         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3494         call transpose2(auxmat2(1,1),auxmat3(1,1))
3495         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3496         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3497 ! Derivatives in gamma(i+1)
3498         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3499         call transpose2(auxmat2(1,1),auxmat3(1,1))
3500         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3501         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
3502           +0.5d0*(pizda(1,1)+pizda(2,2))
3503 ! Cartesian derivatives
3504         do l=1,3
3505 !            ghalf1=0.5d0*agg(l,1)
3506 !            ghalf2=0.5d0*agg(l,2)
3507 !            ghalf3=0.5d0*agg(l,3)
3508 !            ghalf4=0.5d0*agg(l,4)
3509           a_temp(1,1)=aggi(l,1)!+ghalf1
3510           a_temp(1,2)=aggi(l,2)!+ghalf2
3511           a_temp(2,1)=aggi(l,3)!+ghalf3
3512           a_temp(2,2)=aggi(l,4)!+ghalf4
3513           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3514           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
3515             +0.5d0*(pizda(1,1)+pizda(2,2))
3516           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3517           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3518           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3519           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3520           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3521           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
3522             +0.5d0*(pizda(1,1)+pizda(2,2))
3523           a_temp(1,1)=aggj(l,1)!+ghalf1
3524           a_temp(1,2)=aggj(l,2)!+ghalf2
3525           a_temp(2,1)=aggj(l,3)!+ghalf3
3526           a_temp(2,2)=aggj(l,4)!+ghalf4
3527           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3528           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
3529             +0.5d0*(pizda(1,1)+pizda(2,2))
3530           a_temp(1,1)=aggj1(l,1)
3531           a_temp(1,2)=aggj1(l,2)
3532           a_temp(2,1)=aggj1(l,3)
3533           a_temp(2,2)=aggj1(l,4)
3534           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3535           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
3536             +0.5d0*(pizda(1,1)+pizda(2,2))
3537         enddo
3538       return
3539       end subroutine eturn3
3540 !-----------------------------------------------------------------------------
3541       subroutine eturn4(i,eello_turn4)
3542 ! Third- and fourth-order contributions from turns
3543
3544       use comm_locel
3545 !      implicit real*8 (a-h,o-z)
3546 !      include 'DIMENSIONS'
3547 !      include 'COMMON.IOUNITS'
3548 !      include 'COMMON.GEO'
3549 !      include 'COMMON.VAR'
3550 !      include 'COMMON.LOCAL'
3551 !      include 'COMMON.CHAIN'
3552 !      include 'COMMON.DERIV'
3553 !      include 'COMMON.INTERACT'
3554 !      include 'COMMON.CONTACTS'
3555 !      include 'COMMON.TORSION'
3556 !      include 'COMMON.VECTORS'
3557 !      include 'COMMON.FFIELD'
3558 !      include 'COMMON.CONTROL'
3559       real(kind=8),dimension(3) :: ggg
3560       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3561         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3562       real(kind=8),dimension(2) :: auxvec,auxvec1
3563 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3564       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
3565 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3566 !el        dz_normi,xmedi,ymedi,zmedi
3567 !el      integer :: num_conti,j1,j2
3568 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3569 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3570 !el          num_conti,j1,j2
3571 !el local variables
3572       integer :: i,j,iti1,iti2,iti3,l
3573       real(kind=8) :: eello_turn4,s1,s2,s3
3574
3575       j=i+3
3576 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3577 !
3578 !               Fourth-order contributions
3579 !
3580 !                 (i+3)o----(i+4)
3581 !                     /  |
3582 !               (i+2)o   |
3583 !                     \  |
3584 !                 (i+1)o----i
3585 !
3586 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3587 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
3588 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3589         a_temp(1,1)=a22
3590         a_temp(1,2)=a23
3591         a_temp(2,1)=a32
3592         a_temp(2,2)=a33
3593         iti1=itortyp(itype(i+1))
3594         iti2=itortyp(itype(i+2))
3595         iti3=itortyp(itype(i+3))
3596 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3597         call transpose2(EUg(1,1,i+1),e1t(1,1))
3598         call transpose2(Eug(1,1,i+2),e2t(1,1))
3599         call transpose2(Eug(1,1,i+3),e3t(1,1))
3600         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3601         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3602         s1=scalar2(b1(1,iti2),auxvec(1))
3603         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3604         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3605         s2=scalar2(b1(1,iti1),auxvec(1))
3606         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3607         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3608         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3609         eello_turn4=eello_turn4-(s1+s2+s3)
3610         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3611            'eturn4',i,j,-(s1+s2+s3)
3612 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3613 !d     &    ' eello_turn4_num',8*eello_turn4_num
3614 ! Derivatives in gamma(i)
3615         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3616         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3617         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3618         s1=scalar2(b1(1,iti2),auxvec(1))
3619         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3620         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3621         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3622 ! Derivatives in gamma(i+1)
3623         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3624         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3625         s2=scalar2(b1(1,iti1),auxvec(1))
3626         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3627         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3628         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3629         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3630 ! Derivatives in gamma(i+2)
3631         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3632         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3633         s1=scalar2(b1(1,iti2),auxvec(1))
3634         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3635         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3636         s2=scalar2(b1(1,iti1),auxvec(1))
3637         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3638         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3639         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3640         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3641 ! Cartesian derivatives
3642 ! Derivatives of this turn contributions in DC(i+2)
3643         if (j.lt.nres-1) then
3644           do l=1,3
3645             a_temp(1,1)=agg(l,1)
3646             a_temp(1,2)=agg(l,2)
3647             a_temp(2,1)=agg(l,3)
3648             a_temp(2,2)=agg(l,4)
3649             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3650             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3651             s1=scalar2(b1(1,iti2),auxvec(1))
3652             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3653             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3654             s2=scalar2(b1(1,iti1),auxvec(1))
3655             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3656             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3657             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3658             ggg(l)=-(s1+s2+s3)
3659             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3660           enddo
3661         endif
3662 ! Remaining derivatives of this turn contribution
3663         do l=1,3
3664           a_temp(1,1)=aggi(l,1)
3665           a_temp(1,2)=aggi(l,2)
3666           a_temp(2,1)=aggi(l,3)
3667           a_temp(2,2)=aggi(l,4)
3668           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3669           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3670           s1=scalar2(b1(1,iti2),auxvec(1))
3671           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3672           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3673           s2=scalar2(b1(1,iti1),auxvec(1))
3674           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3675           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3676           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3677           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3678           a_temp(1,1)=aggi1(l,1)
3679           a_temp(1,2)=aggi1(l,2)
3680           a_temp(2,1)=aggi1(l,3)
3681           a_temp(2,2)=aggi1(l,4)
3682           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3683           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3684           s1=scalar2(b1(1,iti2),auxvec(1))
3685           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3686           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3687           s2=scalar2(b1(1,iti1),auxvec(1))
3688           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3689           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3690           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3691           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3692           a_temp(1,1)=aggj(l,1)
3693           a_temp(1,2)=aggj(l,2)
3694           a_temp(2,1)=aggj(l,3)
3695           a_temp(2,2)=aggj(l,4)
3696           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3697           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3698           s1=scalar2(b1(1,iti2),auxvec(1))
3699           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3700           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3701           s2=scalar2(b1(1,iti1),auxvec(1))
3702           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3703           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3704           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3705           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3706           a_temp(1,1)=aggj1(l,1)
3707           a_temp(1,2)=aggj1(l,2)
3708           a_temp(2,1)=aggj1(l,3)
3709           a_temp(2,2)=aggj1(l,4)
3710           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3711           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3712           s1=scalar2(b1(1,iti2),auxvec(1))
3713           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3714           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3715           s2=scalar2(b1(1,iti1),auxvec(1))
3716           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3717           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3718           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3719 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3720           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3721         enddo
3722       return
3723       end subroutine eturn4
3724 !-----------------------------------------------------------------------------
3725       subroutine unormderiv(u,ugrad,unorm,ungrad)
3726 ! This subroutine computes the derivatives of a normalized vector u, given
3727 ! the derivatives computed without normalization conditions, ugrad. Returns
3728 ! ungrad.
3729 !      implicit none
3730       real(kind=8),dimension(3) :: u,vec
3731       real(kind=8),dimension(3,3) ::ugrad,ungrad
3732       real(kind=8) :: unorm     !,scalar
3733       integer :: i,j
3734 !      write (2,*) 'ugrad',ugrad
3735 !      write (2,*) 'u',u
3736       do i=1,3
3737         vec(i)=scalar(ugrad(1,i),u(1))
3738       enddo
3739 !      write (2,*) 'vec',vec
3740       do i=1,3
3741         do j=1,3
3742           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3743         enddo
3744       enddo
3745 !      write (2,*) 'ungrad',ungrad
3746       return
3747       end subroutine unormderiv
3748 !-----------------------------------------------------------------------------
3749       subroutine escp_soft_sphere(evdw2,evdw2_14)
3750 !
3751 ! This subroutine calculates the excluded-volume interaction energy between
3752 ! peptide-group centers and side chains and its gradient in virtual-bond and
3753 ! side-chain vectors.
3754 !
3755 !      implicit real*8 (a-h,o-z)
3756 !      include 'DIMENSIONS'
3757 !      include 'COMMON.GEO'
3758 !      include 'COMMON.VAR'
3759 !      include 'COMMON.LOCAL'
3760 !      include 'COMMON.CHAIN'
3761 !      include 'COMMON.DERIV'
3762 !      include 'COMMON.INTERACT'
3763 !      include 'COMMON.FFIELD'
3764 !      include 'COMMON.IOUNITS'
3765 !      include 'COMMON.CONTROL'
3766       real(kind=8),dimension(3) :: ggg
3767 !el local variables
3768       integer :: i,iint,j,k,iteli,itypj
3769       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
3770                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
3771
3772       evdw2=0.0D0
3773       evdw2_14=0.0d0
3774       r0_scp=4.5d0
3775 !d    print '(a)','Enter ESCP'
3776 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3777       do i=iatscp_s,iatscp_e
3778         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3779         iteli=itel(i)
3780         xi=0.5D0*(c(1,i)+c(1,i+1))
3781         yi=0.5D0*(c(2,i)+c(2,i+1))
3782         zi=0.5D0*(c(3,i)+c(3,i+1))
3783
3784         do iint=1,nscp_gr(i)
3785
3786         do j=iscpstart(i,iint),iscpend(i,iint)
3787           if (itype(j).eq.ntyp1) cycle
3788           itypj=iabs(itype(j))
3789 ! Uncomment following three lines for SC-p interactions
3790 !         xj=c(1,nres+j)-xi
3791 !         yj=c(2,nres+j)-yi
3792 !         zj=c(3,nres+j)-zi
3793 ! Uncomment following three lines for Ca-p interactions
3794           xj=c(1,j)-xi
3795           yj=c(2,j)-yi
3796           zj=c(3,j)-zi
3797           rij=xj*xj+yj*yj+zj*zj
3798           r0ij=r0_scp
3799           r0ijsq=r0ij*r0ij
3800           if (rij.lt.r0ijsq) then
3801             evdwij=0.25d0*(rij-r0ijsq)**2
3802             fac=rij-r0ijsq
3803           else
3804             evdwij=0.0d0
3805             fac=0.0d0
3806           endif
3807           evdw2=evdw2+evdwij
3808 !
3809 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3810 !
3811           ggg(1)=xj*fac
3812           ggg(2)=yj*fac
3813           ggg(3)=zj*fac
3814 !grad          if (j.lt.i) then
3815 !d          write (iout,*) 'j<i'
3816 ! Uncomment following three lines for SC-p interactions
3817 !           do k=1,3
3818 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3819 !           enddo
3820 !grad          else
3821 !d          write (iout,*) 'j>i'
3822 !grad            do k=1,3
3823 !grad              ggg(k)=-ggg(k)
3824 ! Uncomment following line for SC-p interactions
3825 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3826 !grad            enddo
3827 !grad          endif
3828 !grad          do k=1,3
3829 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3830 !grad          enddo
3831 !grad          kstart=min0(i+1,j)
3832 !grad          kend=max0(i-1,j-1)
3833 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3834 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3835 !grad          do k=kstart,kend
3836 !grad            do l=1,3
3837 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3838 !grad            enddo
3839 !grad          enddo
3840           do k=1,3
3841             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3842             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3843           enddo
3844         enddo
3845
3846         enddo ! iint
3847       enddo ! i
3848       return
3849       end subroutine escp_soft_sphere
3850 !-----------------------------------------------------------------------------
3851       subroutine escp(evdw2,evdw2_14)
3852 !
3853 ! This subroutine calculates the excluded-volume interaction energy between
3854 ! peptide-group centers and side chains and its gradient in virtual-bond and
3855 ! side-chain vectors.
3856 !
3857 !      implicit real*8 (a-h,o-z)
3858 !      include 'DIMENSIONS'
3859 !      include 'COMMON.GEO'
3860 !      include 'COMMON.VAR'
3861 !      include 'COMMON.LOCAL'
3862 !      include 'COMMON.CHAIN'
3863 !      include 'COMMON.DERIV'
3864 !      include 'COMMON.INTERACT'
3865 !      include 'COMMON.FFIELD'
3866 !      include 'COMMON.IOUNITS'
3867 !      include 'COMMON.CONTROL'
3868       real(kind=8),dimension(3) :: ggg
3869 !el local variables
3870       integer :: i,iint,j,k,iteli,itypj
3871       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
3872                    e1,e2,evdwij
3873
3874       evdw2=0.0D0
3875       evdw2_14=0.0d0
3876 !d    print '(a)','Enter ESCP'
3877 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3878       do i=iatscp_s,iatscp_e
3879         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3880         iteli=itel(i)
3881         xi=0.5D0*(c(1,i)+c(1,i+1))
3882         yi=0.5D0*(c(2,i)+c(2,i+1))
3883         zi=0.5D0*(c(3,i)+c(3,i+1))
3884
3885         do iint=1,nscp_gr(i)
3886
3887         do j=iscpstart(i,iint),iscpend(i,iint)
3888           itypj=iabs(itype(j))
3889           if (itypj.eq.ntyp1) cycle
3890 ! Uncomment following three lines for SC-p interactions
3891 !         xj=c(1,nres+j)-xi
3892 !         yj=c(2,nres+j)-yi
3893 !         zj=c(3,nres+j)-zi
3894 ! Uncomment following three lines for Ca-p interactions
3895           xj=c(1,j)-xi
3896           yj=c(2,j)-yi
3897           zj=c(3,j)-zi
3898           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3899           fac=rrij**expon2
3900           e1=fac*fac*aad(itypj,iteli)
3901           e2=fac*bad(itypj,iteli)
3902           if (iabs(j-i) .le. 2) then
3903             e1=scal14*e1
3904             e2=scal14*e2
3905             evdw2_14=evdw2_14+e1+e2
3906           endif
3907           evdwij=e1+e2
3908           evdw2=evdw2+evdwij
3909 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
3910 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
3911           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3912              'evdw2',i,j,evdwij
3913 !
3914 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
3915 !
3916           fac=-(evdwij+e1)*rrij
3917           ggg(1)=xj*fac
3918           ggg(2)=yj*fac
3919           ggg(3)=zj*fac
3920 !grad          if (j.lt.i) then
3921 !d          write (iout,*) 'j<i'
3922 ! Uncomment following three lines for SC-p interactions
3923 !           do k=1,3
3924 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3925 !           enddo
3926 !grad          else
3927 !d          write (iout,*) 'j>i'
3928 !grad            do k=1,3
3929 !grad              ggg(k)=-ggg(k)
3930 ! Uncomment following line for SC-p interactions
3931 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3932 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3933 !grad            enddo
3934 !grad          endif
3935 !grad          do k=1,3
3936 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 !grad          enddo
3938 !grad          kstart=min0(i+1,j)
3939 !grad          kend=max0(i-1,j-1)
3940 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 !grad          do k=kstart,kend
3943 !grad            do l=1,3
3944 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 !grad            enddo
3946 !grad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       do i=1,nct
3956         do j=1,3
3957           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3958           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3959           gradx_scp(j,i)=expon*gradx_scp(j,i)
3960         enddo
3961       enddo
3962 !******************************************************************************
3963 !
3964 !                              N O T E !!!
3965 !
3966 ! To save time the factor EXPON has been extracted from ALL components
3967 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
3968 ! use!
3969 !
3970 !******************************************************************************
3971       return
3972       end subroutine escp
3973 !-----------------------------------------------------------------------------
3974       subroutine edis(ehpb)
3975 !
3976 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3977 !
3978 !      implicit real*8 (a-h,o-z)
3979 !      include 'DIMENSIONS'
3980 !      include 'COMMON.SBRIDGE'
3981 !      include 'COMMON.CHAIN'
3982 !      include 'COMMON.DERIV'
3983 !      include 'COMMON.VAR'
3984 !      include 'COMMON.INTERACT'
3985 !      include 'COMMON.IOUNITS'
3986       real(kind=8),dimension(3) :: ggg
3987 !el local variables
3988       integer :: i,j,ii,jj,iii,jjj,k
3989       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
3990
3991       ehpb=0.0D0
3992 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3993 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
3994       if (link_end.eq.0) return
3995       do i=link_start,link_end
3996 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3997 ! CA-CA distance used in regularization of structure.
3998         ii=ihpb(i)
3999         jj=jhpb(i)
4000 ! iii and jjj point to the residues for which the distance is assigned.
4001         if (ii.gt.nres) then
4002           iii=ii-nres
4003           jjj=jj-nres
4004         else
4005           iii=ii
4006           jjj=jj
4007         endif
4008 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4009 !     &    dhpb(i),dhpb1(i),forcon(i)
4010 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4011 !    distance and angle dependent SS bond potential.
4012 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4013 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4014         if (.not.dyn_ss .and. i.le.nss) then
4015 ! 15/02/13 CC dynamic SSbond - additional check
4016          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4017         iabs(itype(jjj)).eq.1) then
4018           call ssbond_ene(iii,jjj,eij)
4019           ehpb=ehpb+2*eij
4020 !d          write (iout,*) "eij",eij
4021          endif
4022         else
4023 ! Calculate the distance between the two points and its difference from the
4024 ! target distance.
4025         dd=dist(ii,jj)
4026         rdis=dd-dhpb(i)
4027 ! Get the force constant corresponding to this distance.
4028         waga=forcon(i)
4029 ! Calculate the contribution to energy.
4030         ehpb=ehpb+waga*rdis*rdis
4031 !
4032 ! Evaluate gradient.
4033 !
4034         fac=waga*rdis/dd
4035 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4036 !d   &   ' waga=',waga,' fac=',fac
4037         do j=1,3
4038           ggg(j)=fac*(c(j,jj)-c(j,ii))
4039         enddo
4040 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4041 ! If this is a SC-SC distance, we need to calculate the contributions to the
4042 ! Cartesian gradient in the SC vectors (ghpbx).
4043         if (iii.lt.ii) then
4044           do j=1,3
4045             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4046             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4047           enddo
4048         endif
4049 !grad        do j=iii,jjj-1
4050 !grad          do k=1,3
4051 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4052 !grad          enddo
4053 !grad        enddo
4054         do k=1,3
4055           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4056           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4057         enddo
4058         endif
4059       enddo
4060       ehpb=0.5D0*ehpb
4061       return
4062       end subroutine edis
4063 !-----------------------------------------------------------------------------
4064       subroutine ssbond_ene(i,j,eij)
4065 !
4066 ! Calculate the distance and angle dependent SS-bond potential energy
4067 ! using a free-energy function derived based on RHF/6-31G** ab initio
4068 ! calculations of diethyl disulfide.
4069 !
4070 ! A. Liwo and U. Kozlowska, 11/24/03
4071 !
4072 !      implicit real*8 (a-h,o-z)
4073 !      include 'DIMENSIONS'
4074 !      include 'COMMON.SBRIDGE'
4075 !      include 'COMMON.CHAIN'
4076 !      include 'COMMON.DERIV'
4077 !      include 'COMMON.LOCAL'
4078 !      include 'COMMON.INTERACT'
4079 !      include 'COMMON.VAR'
4080 !      include 'COMMON.IOUNITS'
4081       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4082 !el local variables
4083       integer :: i,j,itypi,itypj,k
4084       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4085                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4086                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4087                    cosphi,ggk
4088
4089       itypi=iabs(itype(i))
4090       xi=c(1,nres+i)
4091       yi=c(2,nres+i)
4092       zi=c(3,nres+i)
4093       dxi=dc_norm(1,nres+i)
4094       dyi=dc_norm(2,nres+i)
4095       dzi=dc_norm(3,nres+i)
4096 !      dsci_inv=dsc_inv(itypi)
4097       dsci_inv=vbld_inv(nres+i)
4098       itypj=iabs(itype(j))
4099 !      dscj_inv=dsc_inv(itypj)
4100       dscj_inv=vbld_inv(nres+j)
4101       xj=c(1,nres+j)-xi
4102       yj=c(2,nres+j)-yi
4103       zj=c(3,nres+j)-zi
4104       dxj=dc_norm(1,nres+j)
4105       dyj=dc_norm(2,nres+j)
4106       dzj=dc_norm(3,nres+j)
4107       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4108       rij=dsqrt(rrij)
4109       erij(1)=xj*rij
4110       erij(2)=yj*rij
4111       erij(3)=zj*rij
4112       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4113       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4114       om12=dxi*dxj+dyi*dyj+dzi*dzj
4115       do k=1,3
4116         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4117         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4118       enddo
4119       rij=1.0d0/rij
4120       deltad=rij-d0cm
4121       deltat1=1.0d0-om1
4122       deltat2=1.0d0+om2
4123       deltat12=om2-om1+2.0d0
4124       cosphi=om12-om1*om2
4125       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4126         +akct*deltad*deltat12 &
4127         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4128 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4129 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4130 !     &  " deltat12",deltat12," eij",eij
4131       ed=2*akcm*deltad+akct*deltat12
4132       pom1=akct*deltad
4133       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4134       eom1=-2*akth*deltat1-pom1-om2*pom2
4135       eom2= 2*akth*deltat2+pom1-om1*pom2
4136       eom12=pom2
4137       do k=1,3
4138         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4139         ghpbx(k,i)=ghpbx(k,i)-ggk &
4140                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4141                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4142         ghpbx(k,j)=ghpbx(k,j)+ggk &
4143                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4144                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4145         ghpbc(k,i)=ghpbc(k,i)-ggk
4146         ghpbc(k,j)=ghpbc(k,j)+ggk
4147       enddo
4148 !
4149 ! Calculate the components of the gradient in DC and X
4150 !
4151 !grad      do k=i,j-1
4152 !grad        do l=1,3
4153 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4154 !grad        enddo
4155 !grad      enddo
4156       return
4157       end subroutine ssbond_ene
4158 !-----------------------------------------------------------------------------
4159       subroutine ebond(estr)
4160 !
4161 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4162 !
4163 !      implicit real*8 (a-h,o-z)
4164 !      include 'DIMENSIONS'
4165 !      include 'COMMON.LOCAL'
4166 !      include 'COMMON.GEO'
4167 !      include 'COMMON.INTERACT'
4168 !      include 'COMMON.DERIV'
4169 !      include 'COMMON.VAR'
4170 !      include 'COMMON.CHAIN'
4171 !      include 'COMMON.IOUNITS'
4172 !      include 'COMMON.NAMES'
4173 !      include 'COMMON.FFIELD'
4174 !      include 'COMMON.CONTROL'
4175 !      include 'COMMON.SETUP'
4176       real(kind=8),dimension(3) :: u,ud
4177 !el local variables
4178       integer :: i,j,iti,nbi,k
4179       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4180                    uprod1,uprod2
4181
4182       estr=0.0d0
4183       estr1=0.0d0
4184 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4185 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4186
4187       do i=ibondp_start,ibondp_end
4188         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4189         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4190 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4191 !C          do j=1,3
4192 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4193 !C            *dc(j,i-1)/vbld(i)
4194 !C          enddo
4195 !C          if (energy_dec) write(iout,*) &
4196 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4197         diff = vbld(i)-vbldpDUM
4198         else
4199         diff = vbld(i)-vbldp0
4200         endif
4201         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4202            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4203         estr=estr+diff*diff
4204         do j=1,3
4205           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4206         enddo
4207 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4208 !        endif
4209       enddo
4210       estr=0.5d0*AKP*estr+estr1
4211 !
4212 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4213 !
4214       do i=ibond_start,ibond_end
4215         iti=iabs(itype(i))
4216         if (iti.ne.10 .and. iti.ne.ntyp1) then
4217           nbi=nbondterm(iti)
4218           if (nbi.eq.1) then
4219             diff=vbld(i+nres)-vbldsc0(1,iti)
4220             if (energy_dec) write (iout,*) &
4221             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
4222             AKSC(1,iti),AKSC(1,iti)*diff*diff
4223             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4224             do j=1,3
4225               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4226             enddo
4227           else
4228             do j=1,nbi
4229               diff=vbld(i+nres)-vbldsc0(j,iti)
4230               ud(j)=aksc(j,iti)*diff
4231               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4232             enddo
4233             uprod=u(1)
4234             do j=2,nbi
4235               uprod=uprod*u(j)
4236             enddo
4237             usum=0.0d0
4238             usumsqder=0.0d0
4239             do j=1,nbi
4240               uprod1=1.0d0
4241               uprod2=1.0d0
4242               do k=1,nbi
4243                 if (k.ne.j) then
4244                   uprod1=uprod1*u(k)
4245                   uprod2=uprod2*u(k)*u(k)
4246                 endif
4247               enddo
4248               usum=usum+uprod1
4249               usumsqder=usumsqder+ud(j)*uprod2
4250             enddo
4251             estr=estr+uprod/usum
4252             do j=1,3
4253              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4254             enddo
4255           endif
4256         endif
4257       enddo
4258       return
4259       end subroutine ebond
4260 #ifdef CRYST_THETA
4261 !-----------------------------------------------------------------------------
4262       subroutine ebend(etheta)
4263 !
4264 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4265 ! angles gamma and its derivatives in consecutive thetas and gammas.
4266 !
4267       use comm_calcthet
4268 !      implicit real*8 (a-h,o-z)
4269 !      include 'DIMENSIONS'
4270 !      include 'COMMON.LOCAL'
4271 !      include 'COMMON.GEO'
4272 !      include 'COMMON.INTERACT'
4273 !      include 'COMMON.DERIV'
4274 !      include 'COMMON.VAR'
4275 !      include 'COMMON.CHAIN'
4276 !      include 'COMMON.IOUNITS'
4277 !      include 'COMMON.NAMES'
4278 !      include 'COMMON.FFIELD'
4279 !      include 'COMMON.CONTROL'
4280 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4281 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4282 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4283 !el      integer :: it
4284 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4285 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4286 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4287 !el local variables
4288       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
4289        ichir21,ichir22
4290       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
4291        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
4292        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
4293       real(kind=8),dimension(2) :: y,z
4294
4295       delta=0.02d0*pi
4296 !      time11=dexp(-2*time)
4297 !      time12=1.0d0
4298       etheta=0.0D0
4299 !     write (*,'(a,i2)') 'EBEND ICG=',icg
4300       do i=ithet_start,ithet_end
4301         if (itype(i-1).eq.ntyp1) cycle
4302 ! Zero the energy function and its derivative at 0 or pi.
4303         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4304         it=itype(i-1)
4305         ichir1=isign(1,itype(i-2))
4306         ichir2=isign(1,itype(i))
4307          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4308          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4309          if (itype(i-1).eq.10) then
4310           itype1=isign(10,itype(i-2))
4311           ichir11=isign(1,itype(i-2))
4312           ichir12=isign(1,itype(i-2))
4313           itype2=isign(10,itype(i))
4314           ichir21=isign(1,itype(i))
4315           ichir22=isign(1,itype(i))
4316          endif
4317
4318         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4319 #ifdef OSF
4320           phii=phi(i)
4321           if (phii.ne.phii) phii=150.0
4322 #else
4323           phii=phi(i)
4324 #endif
4325           y(1)=dcos(phii)
4326           y(2)=dsin(phii)
4327         else
4328           y(1)=0.0D0
4329           y(2)=0.0D0
4330         endif
4331         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4332 #ifdef OSF
4333           phii1=phi(i+1)
4334           if (phii1.ne.phii1) phii1=150.0
4335           phii1=pinorm(phii1)
4336           z(1)=cos(phii1)
4337 #else
4338           phii1=phi(i+1)
4339           z(1)=dcos(phii1)
4340 #endif
4341           z(2)=dsin(phii1)
4342         else
4343           z(1)=0.0D0
4344           z(2)=0.0D0
4345         endif
4346 ! Calculate the "mean" value of theta from the part of the distribution
4347 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4348 ! In following comments this theta will be referred to as t_c.
4349         thet_pred_mean=0.0d0
4350         do k=1,2
4351             athetk=athet(k,it,ichir1,ichir2)
4352             bthetk=bthet(k,it,ichir1,ichir2)
4353           if (it.eq.10) then
4354              athetk=athet(k,itype1,ichir11,ichir12)
4355              bthetk=bthet(k,itype2,ichir21,ichir22)
4356           endif
4357          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4358         enddo
4359         dthett=thet_pred_mean*ssd
4360         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4361 ! Derivatives of the "mean" values in gamma1 and gamma2.
4362         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
4363                +athet(2,it,ichir1,ichir2)*y(1))*ss
4364         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
4365                +bthet(2,it,ichir1,ichir2)*z(1))*ss
4366          if (it.eq.10) then
4367         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
4368              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
4369         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
4370                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4371          endif
4372         if (theta(i).gt.pi-delta) then
4373           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
4374                E_tc0)
4375           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4376           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4377           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
4378               E_theta)
4379           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
4380               E_tc)
4381         else if (theta(i).lt.delta) then
4382           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4383           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4384           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
4385               E_theta)
4386           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4387           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
4388               E_tc)
4389         else
4390           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
4391               E_theta,E_tc)
4392         endif
4393         etheta=etheta+ethetai
4394         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4395             'ebend',i,ethetai
4396         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4397         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4398         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4399       enddo
4400 ! Ufff.... We've done all this!!!
4401       return
4402       end subroutine ebend
4403 !-----------------------------------------------------------------------------
4404       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
4405
4406       use comm_calcthet
4407 !      implicit real*8 (a-h,o-z)
4408 !      include 'DIMENSIONS'
4409 !      include 'COMMON.LOCAL'
4410 !      include 'COMMON.IOUNITS'
4411 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
4412 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4413 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
4414       integer :: i,j,k
4415       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
4416 !el      integer :: it
4417 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
4418 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
4419 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4420 !el local variables
4421       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
4422        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4423
4424 ! Calculate the contributions to both Gaussian lobes.
4425 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4426 ! The "polynomial part" of the "standard deviation" of this part of
4427 ! the distribution.
4428         sig=polthet(3,it)
4429         do j=2,0,-1
4430           sig=sig*thet_pred_mean+polthet(j,it)
4431         enddo
4432 ! Derivative of the "interior part" of the "standard deviation of the"
4433 ! gamma-dependent Gaussian lobe in t_c.
4434         sigtc=3*polthet(3,it)
4435         do j=2,1,-1
4436           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4437         enddo
4438         sigtc=sig*sigtc
4439 ! Set the parameters of both Gaussian lobes of the distribution.
4440 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4441         fac=sig*sig+sigc0(it)
4442         sigcsq=fac+fac
4443         sigc=1.0D0/sigcsq
4444 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4445         sigsqtc=-4.0D0*sigcsq*sigtc
4446 !       print *,i,sig,sigtc,sigsqtc
4447 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
4448         sigtc=-sigtc/(fac*fac)
4449 ! Following variable is sigma(t_c)**(-2)
4450         sigcsq=sigcsq*sigcsq
4451         sig0i=sig0(it)
4452         sig0inv=1.0D0/sig0i**2
4453         delthec=thetai-thet_pred_mean
4454         delthe0=thetai-theta0i
4455         term1=-0.5D0*sigcsq*delthec*delthec
4456         term2=-0.5D0*sig0inv*delthe0*delthe0
4457 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4458 ! NaNs in taking the logarithm. We extract the largest exponent which is added
4459 ! to the energy (this being the log of the distribution) at the end of energy
4460 ! term evaluation for this virtual-bond angle.
4461         if (term1.gt.term2) then
4462           termm=term1
4463           term2=dexp(term2-termm)
4464           term1=1.0d0
4465         else
4466           termm=term2
4467           term1=dexp(term1-termm)
4468           term2=1.0d0
4469         endif
4470 ! The ratio between the gamma-independent and gamma-dependent lobes of
4471 ! the distribution is a Gaussian function of thet_pred_mean too.
4472         diffak=gthet(2,it)-thet_pred_mean
4473         ratak=diffak/gthet(3,it)**2
4474         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4475 ! Let's differentiate it in thet_pred_mean NOW.
4476         aktc=ak*ratak
4477 ! Now put together the distribution terms to make complete distribution.
4478         termexp=term1+ak*term2
4479         termpre=sigc+ak*sig0i
4480 ! Contribution of the bending energy from this theta is just the -log of
4481 ! the sum of the contributions from the two lobes and the pre-exponential
4482 ! factor. Simple enough, isn't it?
4483         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4484 ! NOW the derivatives!!!
4485 ! 6/6/97 Take into account the deformation.
4486         E_theta=(delthec*sigcsq*term1 &
4487              +ak*delthe0*sig0inv*term2)/termexp
4488         E_tc=((sigtc+aktc*sig0i)/termpre &
4489             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
4490              aktc*term2)/termexp)
4491       return
4492       end subroutine theteng
4493 #else
4494 !-----------------------------------------------------------------------------
4495       subroutine ebend(etheta)
4496 !
4497 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4498 ! angles gamma and its derivatives in consecutive thetas and gammas.
4499 ! ab initio-derived potentials from
4500 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4501 !
4502 !      implicit real*8 (a-h,o-z)
4503 !      include 'DIMENSIONS'
4504 !      include 'COMMON.LOCAL'
4505 !      include 'COMMON.GEO'
4506 !      include 'COMMON.INTERACT'
4507 !      include 'COMMON.DERIV'
4508 !      include 'COMMON.VAR'
4509 !      include 'COMMON.CHAIN'
4510 !      include 'COMMON.IOUNITS'
4511 !      include 'COMMON.NAMES'
4512 !      include 'COMMON.FFIELD'
4513 !      include 'COMMON.CONTROL'
4514       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
4515       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
4516       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
4517       logical :: lprn=.false., lprn1=.false.
4518 !el local variables
4519       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
4520       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
4521       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
4522
4523       etheta=0.0D0
4524       do i=ithet_start,ithet_end
4525         if (itype(i-1).eq.ntyp1) cycle
4526         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
4527         if (iabs(itype(i+1)).eq.20) iblock=2
4528         if (iabs(itype(i+1)).ne.20) iblock=1
4529         dethetai=0.0d0
4530         dephii=0.0d0
4531         dephii1=0.0d0
4532         theti2=0.5d0*theta(i)
4533         ityp2=ithetyp((itype(i-1)))
4534         do k=1,nntheterm
4535           coskt(k)=dcos(k*theti2)
4536           sinkt(k)=dsin(k*theti2)
4537         enddo
4538         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4539 #ifdef OSF
4540           phii=phi(i)
4541           if (phii.ne.phii) phii=150.0
4542 #else
4543           phii=phi(i)
4544 #endif
4545           ityp1=ithetyp((itype(i-2)))
4546 ! propagation of chirality for glycine type
4547           do k=1,nsingle
4548             cosph1(k)=dcos(k*phii)
4549             sinph1(k)=dsin(k*phii)
4550           enddo
4551         else
4552           phii=0.0d0
4553           ityp1=ithetyp(itype(i-2))
4554           do k=1,nsingle
4555             cosph1(k)=0.0d0
4556             sinph1(k)=0.0d0
4557           enddo
4558         endif
4559         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4560 #ifdef OSF
4561           phii1=phi(i+1)
4562           if (phii1.ne.phii1) phii1=150.0
4563           phii1=pinorm(phii1)
4564 #else
4565           phii1=phi(i+1)
4566 #endif
4567           ityp3=ithetyp((itype(i)))
4568           do k=1,nsingle
4569             cosph2(k)=dcos(k*phii1)
4570             sinph2(k)=dsin(k*phii1)
4571           enddo
4572         else
4573           phii1=0.0d0
4574           ityp3=ithetyp(itype(i))
4575           do k=1,nsingle
4576             cosph2(k)=0.0d0
4577             sinph2(k)=0.0d0
4578           enddo
4579         endif
4580         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4581         do k=1,ndouble
4582           do l=1,k-1
4583             ccl=cosph1(l)*cosph2(k-l)
4584             ssl=sinph1(l)*sinph2(k-l)
4585             scl=sinph1(l)*cosph2(k-l)
4586             csl=cosph1(l)*sinph2(k-l)
4587             cosph1ph2(l,k)=ccl-ssl
4588             cosph1ph2(k,l)=ccl+ssl
4589             sinph1ph2(l,k)=scl+csl
4590             sinph1ph2(k,l)=scl-csl
4591           enddo
4592         enddo
4593         if (lprn) then
4594         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
4595           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4596         write (iout,*) "coskt and sinkt"
4597         do k=1,nntheterm
4598           write (iout,*) k,coskt(k),sinkt(k)
4599         enddo
4600         endif
4601         do k=1,ntheterm
4602           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4603           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
4604             *coskt(k)
4605           if (lprn) &
4606           write (iout,*) "k",k,&
4607            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
4608            " ethetai",ethetai
4609         enddo
4610         if (lprn) then
4611         write (iout,*) "cosph and sinph"
4612         do k=1,nsingle
4613           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4614         enddo
4615         write (iout,*) "cosph1ph2 and sinph2ph2"
4616         do k=2,ndouble
4617           do l=1,k-1
4618             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
4619                sinph1ph2(l,k),sinph1ph2(k,l)
4620           enddo
4621         enddo
4622         write(iout,*) "ethetai",ethetai
4623         endif
4624         do m=1,ntheterm2
4625           do k=1,nsingle
4626             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
4627                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
4628                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
4629                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4630             ethetai=ethetai+sinkt(m)*aux
4631             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4632             dephii=dephii+k*sinkt(m)* &
4633                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
4634                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4635             dephii1=dephii1+k*sinkt(m)* &
4636                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
4637                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4638             if (lprn) &
4639             write (iout,*) "m",m," k",k," bbthet", &
4640                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
4641                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
4642                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
4643                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4644           enddo
4645         enddo
4646         if (lprn) &
4647         write(iout,*) "ethetai",ethetai
4648         do m=1,ntheterm3
4649           do k=2,ndouble
4650             do l=1,k-1
4651               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4652                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
4653                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4654                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4655               ethetai=ethetai+sinkt(m)*aux
4656               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4657               dephii=dephii+l*sinkt(m)* &
4658                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
4659                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4660                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
4661                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4662               dephii1=dephii1+(k-l)*sinkt(m)* &
4663                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
4664                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
4665                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
4666                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4667               if (lprn) then
4668               write (iout,*) "m",m," k",k," l",l," ffthet",&
4669                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4670                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
4671                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
4672                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
4673                   " ethetai",ethetai
4674               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
4675                   cosph1ph2(k,l)*sinkt(m),&
4676                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4677               endif
4678             enddo
4679           enddo
4680         enddo
4681 10      continue
4682 !        lprn1=.true.
4683         if (lprn1) &
4684           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
4685          i,theta(i)*rad2deg,phii*rad2deg,&
4686          phii1*rad2deg,ethetai
4687 !        lprn1=.false.
4688         etheta=etheta+ethetai
4689         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4690                                     'ebend',i,ethetai
4691         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4692         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4693         gloc(nphi+i-2,icg)=wang*dethetai
4694       enddo
4695       return
4696       end subroutine ebend
4697 #endif
4698 #ifdef CRYST_SC
4699 !-----------------------------------------------------------------------------
4700       subroutine esc(escloc)
4701 ! Calculate the local energy of a side chain and its derivatives in the
4702 ! corresponding virtual-bond valence angles THETA and the spherical angles
4703 ! ALPHA and OMEGA.
4704 !
4705       use comm_sccalc
4706 !      implicit real*8 (a-h,o-z)
4707 !      include 'DIMENSIONS'
4708 !      include 'COMMON.GEO'
4709 !      include 'COMMON.LOCAL'
4710 !      include 'COMMON.VAR'
4711 !      include 'COMMON.INTERACT'
4712 !      include 'COMMON.DERIV'
4713 !      include 'COMMON.CHAIN'
4714 !      include 'COMMON.IOUNITS'
4715 !      include 'COMMON.NAMES'
4716 !      include 'COMMON.FFIELD'
4717 !      include 'COMMON.CONTROL'
4718       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
4719          ddersc0,ddummy,xtemp,temp
4720 !el      real(kind=8) :: time11,time12,time112,theti
4721       real(kind=8) :: escloc,delta
4722 !el      integer :: it,nlobit
4723 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4724 !el local variables
4725       integer :: i,k
4726       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
4727        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
4728       delta=0.02d0*pi
4729       escloc=0.0D0
4730 !     write (iout,'(a)') 'ESC'
4731       do i=loc_start,loc_end
4732         it=itype(i)
4733         if (it.eq.ntyp1) cycle
4734         if (it.eq.10) goto 1
4735         nlobit=nlob(iabs(it))
4736 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
4737 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4738         theti=theta(i+1)-pipol
4739         x(1)=dtan(theti)
4740         x(2)=alph(i)
4741         x(3)=omeg(i)
4742
4743         if (x(2).gt.pi-delta) then
4744           xtemp(1)=x(1)
4745           xtemp(2)=pi-delta
4746           xtemp(3)=x(3)
4747           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4748           xtemp(2)=pi
4749           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4750           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
4751               escloci,dersc(2))
4752           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4753               ddersc0(1),dersc(1))
4754           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
4755               ddersc0(3),dersc(3))
4756           xtemp(2)=pi-delta
4757           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4758           xtemp(2)=pi
4759           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4760           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
4761                   dersc0(2),esclocbi,dersc02)
4762           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
4763                   dersc12,dersc01)
4764           call splinthet(x(2),0.5d0*delta,ss,ssd)
4765           dersc0(1)=dersc01
4766           dersc0(2)=dersc02
4767           dersc0(3)=0.0d0
4768           do k=1,3
4769             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4770           enddo
4771           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4772 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4773 !    &             esclocbi,ss,ssd
4774           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4775 !         escloci=esclocbi
4776 !         write (iout,*) escloci
4777         else if (x(2).lt.delta) then
4778           xtemp(1)=x(1)
4779           xtemp(2)=delta
4780           xtemp(3)=x(3)
4781           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4782           xtemp(2)=0.0d0
4783           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4784           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
4785               escloci,dersc(2))
4786           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4787               ddersc0(1),dersc(1))
4788           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
4789               ddersc0(3),dersc(3))
4790           xtemp(2)=delta
4791           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4792           xtemp(2)=0.0d0
4793           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4794           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
4795                   dersc0(2),esclocbi,dersc02)
4796           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
4797                   dersc12,dersc01)
4798           dersc0(1)=dersc01
4799           dersc0(2)=dersc02
4800           dersc0(3)=0.0d0
4801           call splinthet(x(2),0.5d0*delta,ss,ssd)
4802           do k=1,3
4803             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4804           enddo
4805           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4806 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4807 !    &             esclocbi,ss,ssd
4808           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4809 !         write (iout,*) escloci
4810         else
4811           call enesc(x,escloci,dersc,ddummy,.false.)
4812         endif
4813
4814         escloc=escloc+escloci
4815         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
4816            'escloc',i,escloci
4817 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4818
4819         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
4820          wscloc*dersc(1)
4821         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4822         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4823     1   continue
4824       enddo
4825       return
4826       end subroutine esc
4827 !-----------------------------------------------------------------------------
4828       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4829
4830       use comm_sccalc
4831 !      implicit real*8 (a-h,o-z)
4832 !      include 'DIMENSIONS'
4833 !      include 'COMMON.GEO'
4834 !      include 'COMMON.LOCAL'
4835 !      include 'COMMON.IOUNITS'
4836 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4837       real(kind=8),dimension(3) :: x,z,dersc,ddersc
4838       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
4839       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
4840       real(kind=8) :: escloci
4841       logical :: mixed
4842 !el local variables
4843       integer :: j,iii,l,k !el,it,nlobit
4844       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
4845 !el       time11,time12,time112
4846 !       write (iout,*) 'it=',it,' nlobit=',nlobit
4847         escloc_i=0.0D0
4848         do j=1,3
4849           dersc(j)=0.0D0
4850           if (mixed) ddersc(j)=0.0d0
4851         enddo
4852         x3=x(3)
4853
4854 ! Because of periodicity of the dependence of the SC energy in omega we have
4855 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4856 ! To avoid underflows, first compute & store the exponents.
4857
4858         do iii=-1,1
4859
4860           x(3)=x3+iii*dwapi
4861
4862           do j=1,nlobit
4863             do k=1,3
4864               z(k)=x(k)-censc(k,j,it)
4865             enddo
4866             do k=1,3
4867               Axk=0.0D0
4868               do l=1,3
4869                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4870               enddo
4871               Ax(k,j,iii)=Axk
4872             enddo
4873             expfac=0.0D0
4874             do k=1,3
4875               expfac=expfac+Ax(k,j,iii)*z(k)
4876             enddo
4877             contr(j,iii)=expfac
4878           enddo ! j
4879
4880         enddo ! iii
4881
4882         x(3)=x3
4883 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4884 ! subsequent NaNs and INFs in energy calculation.
4885 ! Find the largest exponent
4886         emin=contr(1,-1)
4887         do iii=-1,1
4888           do j=1,nlobit
4889             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4890           enddo
4891         enddo
4892         emin=0.5D0*emin
4893 !d      print *,'it=',it,' emin=',emin
4894
4895 ! Compute the contribution to SC energy and derivatives
4896         do iii=-1,1
4897
4898           do j=1,nlobit
4899 #ifdef OSF
4900             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
4901             if(adexp.ne.adexp) adexp=1.0
4902             expfac=dexp(adexp)
4903 #else
4904             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4905 #endif
4906 !d          print *,'j=',j,' expfac=',expfac
4907             escloc_i=escloc_i+expfac
4908             do k=1,3
4909               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4910             enddo
4911             if (mixed) then
4912               do k=1,3,2
4913                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
4914                   +gaussc(k,2,j,it))*expfac
4915               enddo
4916             endif
4917           enddo
4918
4919         enddo ! iii
4920
4921         dersc(1)=dersc(1)/cos(theti)**2
4922         ddersc(1)=ddersc(1)/cos(theti)**2
4923         ddersc(3)=ddersc(3)
4924
4925         escloci=-(dlog(escloc_i)-emin)
4926         do j=1,3
4927           dersc(j)=dersc(j)/escloc_i
4928         enddo
4929         if (mixed) then
4930           do j=1,3,2
4931             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4932           enddo
4933         endif
4934       return
4935       end subroutine enesc
4936 !-----------------------------------------------------------------------------
4937       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4938
4939       use comm_sccalc
4940 !      implicit real*8 (a-h,o-z)
4941 !      include 'DIMENSIONS'
4942 !      include 'COMMON.GEO'
4943 !      include 'COMMON.LOCAL'
4944 !      include 'COMMON.IOUNITS'
4945 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
4946       real(kind=8),dimension(3) :: x,z,dersc
4947       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
4948       real(kind=8),dimension(nlobit) :: contr !(maxlob)
4949       real(kind=8) :: escloci,dersc12,emin
4950       logical :: mixed
4951 !el local varables
4952       integer :: j,k,l !el,it,nlobit
4953       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
4954
4955       escloc_i=0.0D0
4956
4957       do j=1,3
4958         dersc(j)=0.0D0
4959       enddo
4960
4961       do j=1,nlobit
4962         do k=1,2
4963           z(k)=x(k)-censc(k,j,it)
4964         enddo
4965         z(3)=dwapi
4966         do k=1,3
4967           Axk=0.0D0
4968           do l=1,3
4969             Axk=Axk+gaussc(l,k,j,it)*z(l)
4970           enddo
4971           Ax(k,j)=Axk
4972         enddo
4973         expfac=0.0D0
4974         do k=1,3
4975           expfac=expfac+Ax(k,j)*z(k)
4976         enddo
4977         contr(j)=expfac
4978       enddo ! j
4979
4980 ! As in the case of ebend, we want to avoid underflows in exponentiation and
4981 ! subsequent NaNs and INFs in energy calculation.
4982 ! Find the largest exponent
4983       emin=contr(1)
4984       do j=1,nlobit
4985         if (emin.gt.contr(j)) emin=contr(j)
4986       enddo
4987       emin=0.5D0*emin
4988
4989 ! Compute the contribution to SC energy and derivatives
4990
4991       dersc12=0.0d0
4992       do j=1,nlobit
4993         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4994         escloc_i=escloc_i+expfac
4995         do k=1,2
4996           dersc(k)=dersc(k)+Ax(k,j)*expfac
4997         enddo
4998         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
4999                   +gaussc(1,2,j,it))*expfac
5000         dersc(3)=0.0d0
5001       enddo
5002
5003       dersc(1)=dersc(1)/cos(theti)**2
5004       dersc12=dersc12/cos(theti)**2
5005       escloci=-(dlog(escloc_i)-emin)
5006       do j=1,2
5007         dersc(j)=dersc(j)/escloc_i
5008       enddo
5009       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5010       return
5011       end subroutine enesc_bound
5012 #else
5013 !-----------------------------------------------------------------------------
5014       subroutine esc(escloc)
5015 ! Calculate the local energy of a side chain and its derivatives in the
5016 ! corresponding virtual-bond valence angles THETA and the spherical angles
5017 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5018 ! added by Urszula Kozlowska. 07/11/2007
5019 !
5020       use comm_sccalc
5021 !      implicit real*8 (a-h,o-z)
5022 !      include 'DIMENSIONS'
5023 !      include 'COMMON.GEO'
5024 !      include 'COMMON.LOCAL'
5025 !      include 'COMMON.VAR'
5026 !      include 'COMMON.SCROT'
5027 !      include 'COMMON.INTERACT'
5028 !      include 'COMMON.DERIV'
5029 !      include 'COMMON.CHAIN'
5030 !      include 'COMMON.IOUNITS'
5031 !      include 'COMMON.NAMES'
5032 !      include 'COMMON.FFIELD'
5033 !      include 'COMMON.CONTROL'
5034 !      include 'COMMON.VECTORS'
5035       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5036       real(kind=8),dimension(65) :: x
5037       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5038          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5039       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5040       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5041          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5042 !el local variables
5043       integer :: i,j,k !el,it,nlobit
5044       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5045 !el      real(kind=8) :: time11,time12,time112,theti
5046 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5047       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5048                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5049                    sumene1x,sumene2x,sumene3x,sumene4x,&
5050                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5051                    cosfac2xx,sinfac2yy
5052 #ifdef DEBUG
5053       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5054                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5055                    de_dt_num
5056 #endif
5057 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5058
5059       delta=0.02d0*pi
5060       escloc=0.0D0
5061       do i=loc_start,loc_end
5062         if (itype(i).eq.ntyp1) cycle
5063         costtab(i+1) =dcos(theta(i+1))
5064         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5065         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5066         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5067         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5068         cosfac=dsqrt(cosfac2)
5069         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5070         sinfac=dsqrt(sinfac2)
5071         it=iabs(itype(i))
5072         if (it.eq.10) goto 1
5073 !
5074 !  Compute the axes of tghe local cartesian coordinates system; store in
5075 !   x_prime, y_prime and z_prime
5076 !
5077         do j=1,3
5078           x_prime(j) = 0.00
5079           y_prime(j) = 0.00
5080           z_prime(j) = 0.00
5081         enddo
5082 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5083 !     &   dc_norm(3,i+nres)
5084         do j = 1,3
5085           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5086           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5087         enddo
5088         do j = 1,3
5089           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5090         enddo
5091 !       write (2,*) "i",i
5092 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5093 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5094 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5095 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5096 !      & " xy",scalar(x_prime(1),y_prime(1)),
5097 !      & " xz",scalar(x_prime(1),z_prime(1)),
5098 !      & " yy",scalar(y_prime(1),y_prime(1)),
5099 !      & " yz",scalar(y_prime(1),z_prime(1)),
5100 !      & " zz",scalar(z_prime(1),z_prime(1))
5101 !
5102 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5103 ! to local coordinate system. Store in xx, yy, zz.
5104 !
5105         xx=0.0d0
5106         yy=0.0d0
5107         zz=0.0d0
5108         do j = 1,3
5109           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5110           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5111           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5112         enddo
5113
5114         xxtab(i)=xx
5115         yytab(i)=yy
5116         zztab(i)=zz
5117 !
5118 ! Compute the energy of the ith side cbain
5119 !
5120 !        write (2,*) "xx",xx," yy",yy," zz",zz
5121         it=iabs(itype(i))
5122         do j = 1,65
5123           x(j) = sc_parmin(j,it)
5124         enddo
5125 #ifdef CHECK_COORD
5126 !c diagnostics - remove later
5127         xx1 = dcos(alph(2))
5128         yy1 = dsin(alph(2))*dcos(omeg(2))
5129         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5130         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5131           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5132           xx1,yy1,zz1
5133 !,"  --- ", xx_w,yy_w,zz_w
5134 ! end diagnostics
5135 #endif
5136         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5137          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5138          + x(10)*yy*zz
5139         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5140          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5141          + x(20)*yy*zz
5142         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5143          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5144          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5145          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5146          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5147          +x(40)*xx*yy*zz
5148         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5149          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5150          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5151          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5152          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5153          +x(60)*xx*yy*zz
5154         dsc_i   = 0.743d0+x(61)
5155         dp2_i   = 1.9d0+x(62)
5156         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5157                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5158         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5159                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5160         s1=(1+x(63))/(0.1d0 + dscp1)
5161         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5162         s2=(1+x(65))/(0.1d0 + dscp2)
5163         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5164         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5165       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5166 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5167 !     &   sumene4,
5168 !     &   dscp1,dscp2,sumene
5169 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5170         escloc = escloc + sumene
5171 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5172 !     & ,zz,xx,yy
5173 !#define DEBUG
5174 #ifdef DEBUG
5175 !
5176 ! This section to check the numerical derivatives of the energy of ith side
5177 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5178 ! #define DEBUG in the code to turn it on.
5179 !
5180         write (2,*) "sumene               =",sumene
5181         aincr=1.0d-7
5182         xxsave=xx
5183         xx=xx+aincr
5184         write (2,*) xx,yy,zz
5185         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5186         de_dxx_num=(sumenep-sumene)/aincr
5187         xx=xxsave
5188         write (2,*) "xx+ sumene from enesc=",sumenep
5189         yysave=yy
5190         yy=yy+aincr
5191         write (2,*) xx,yy,zz
5192         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5193         de_dyy_num=(sumenep-sumene)/aincr
5194         yy=yysave
5195         write (2,*) "yy+ sumene from enesc=",sumenep
5196         zzsave=zz
5197         zz=zz+aincr
5198         write (2,*) xx,yy,zz
5199         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5200         de_dzz_num=(sumenep-sumene)/aincr
5201         zz=zzsave
5202         write (2,*) "zz+ sumene from enesc=",sumenep
5203         costsave=cost2tab(i+1)
5204         sintsave=sint2tab(i+1)
5205         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5206         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5207         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5208         de_dt_num=(sumenep-sumene)/aincr
5209         write (2,*) " t+ sumene from enesc=",sumenep
5210         cost2tab(i+1)=costsave
5211         sint2tab(i+1)=sintsave
5212 ! End of diagnostics section.
5213 #endif
5214 !
5215 ! Compute the gradient of esc
5216 !
5217 !        zz=zz*dsign(1.0,dfloat(itype(i)))
5218         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5219         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5220         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5221         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5222         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5223         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5224         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5225         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5226         pom1=(sumene3*sint2tab(i+1)+sumene1) &
5227            *(pom_s1/dscp1+pom_s16*dscp1**4)
5228         pom2=(sumene4*cost2tab(i+1)+sumene2) &
5229            *(pom_s2/dscp2+pom_s26*dscp2**4)
5230         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5231         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
5232         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
5233         +x(40)*yy*zz
5234         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5235         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
5236         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
5237         +x(60)*yy*zz
5238         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
5239               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
5240               +(pom1+pom2)*pom_dx
5241 #ifdef DEBUG
5242         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5243 #endif
5244 !
5245         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5246         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
5247         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
5248         +x(40)*xx*zz
5249         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5250         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
5251         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
5252         +x(59)*zz**2 +x(60)*xx*zz
5253         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
5254               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
5255               +(pom1-pom2)*pom_dy
5256 #ifdef DEBUG
5257         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5258 #endif
5259 !
5260         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
5261         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
5262         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
5263         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
5264         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
5265         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
5266         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
5267         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5268 #ifdef DEBUG
5269         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5270 #endif
5271 !
5272         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
5273         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
5274         +pom1*pom_dt1+pom2*pom_dt2
5275 #ifdef DEBUG
5276         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5277 #endif
5278 !
5279 !
5280        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5281        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5282        cosfac2xx=cosfac2*xx
5283        sinfac2yy=sinfac2*yy
5284        do k = 1,3
5285          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
5286             vbld_inv(i+1)
5287          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
5288             vbld_inv(i)
5289          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5290          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5291 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5292 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5293 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5294 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5295          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5296          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5297          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5298          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5299          dZZ_Ci1(k)=0.0d0
5300          dZZ_Ci(k)=0.0d0
5301          do j=1,3
5302            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
5303            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5304            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
5305            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5306          enddo
5307
5308          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5309          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5310          dZZ_XYZ(k)=vbld_inv(i+nres)* &
5311          (z_prime(k)-zz*dC_norm(k,i+nres))
5312 !
5313          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5314          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5315        enddo
5316
5317        do k=1,3
5318          dXX_Ctab(k,i)=dXX_Ci(k)
5319          dXX_C1tab(k,i)=dXX_Ci1(k)
5320          dYY_Ctab(k,i)=dYY_Ci(k)
5321          dYY_C1tab(k,i)=dYY_Ci1(k)
5322          dZZ_Ctab(k,i)=dZZ_Ci(k)
5323          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5324          dXX_XYZtab(k,i)=dXX_XYZ(k)
5325          dYY_XYZtab(k,i)=dYY_XYZ(k)
5326          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5327        enddo
5328
5329        do k = 1,3
5330 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5331 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5332 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5333 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5334 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5335 !     &    dt_dci(k)
5336 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5337 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5338          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
5339           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5340          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
5341           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5342          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
5343           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5344        enddo
5345 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5346 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5347
5348 ! to check gradient call subroutine check_grad
5349
5350     1 continue
5351       enddo
5352       return
5353       end subroutine esc
5354 !-----------------------------------------------------------------------------
5355       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
5356 !      implicit none
5357       real(kind=8),dimension(65) :: x
5358       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
5359         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5360
5361       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5362         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5363         + x(10)*yy*zz
5364       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5365         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5366         + x(20)*yy*zz
5367       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5368         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5369         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5370         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5371         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5372         +x(40)*xx*yy*zz
5373       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5374         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5375         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5376         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5377         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5378         +x(60)*xx*yy*zz
5379       dsc_i   = 0.743d0+x(61)
5380       dp2_i   = 1.9d0+x(62)
5381       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5382                 *(xx*cost2+yy*sint2))
5383       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5384                 *(xx*cost2-yy*sint2))
5385       s1=(1+x(63))/(0.1d0 + dscp1)
5386       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5387       s2=(1+x(65))/(0.1d0 + dscp2)
5388       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5389       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
5390        + (sumene4*cost2 +sumene2)*(s2+s2_6)
5391       enesc=sumene
5392       return
5393       end function enesc
5394 #endif
5395 !-----------------------------------------------------------------------------
5396       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5397 !
5398 ! This procedure calculates two-body contact function g(rij) and its derivative:
5399 !
5400 !           eps0ij                                     !       x < -1
5401 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5402 !            0                                         !       x > 1
5403 !
5404 ! where x=(rij-r0ij)/delta
5405 !
5406 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5407 !
5408 !      implicit none
5409       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
5410       real(kind=8) :: x,x2,x4,delta
5411 !     delta=0.02D0*r0ij
5412 !      delta=0.2D0*r0ij
5413       x=(rij-r0ij)/delta
5414       if (x.lt.-1.0D0) then
5415         fcont=eps0ij
5416         fprimcont=0.0D0
5417       else if (x.le.1.0D0) then
5418         x2=x*x
5419         x4=x2*x2
5420         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5421         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5422       else
5423         fcont=0.0D0
5424         fprimcont=0.0D0
5425       endif
5426       return
5427       end subroutine gcont
5428 !-----------------------------------------------------------------------------
5429       subroutine splinthet(theti,delta,ss,ssder)
5430 !      implicit real*8 (a-h,o-z)
5431 !      include 'DIMENSIONS'
5432 !      include 'COMMON.VAR'
5433 !      include 'COMMON.GEO'
5434       real(kind=8) :: theti,delta,ss,ssder
5435       real(kind=8) :: thetup,thetlow
5436       thetup=pi-delta
5437       thetlow=delta
5438       if (theti.gt.pipol) then
5439         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5440       else
5441         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5442         ssder=-ssder
5443       endif
5444       return
5445       end subroutine splinthet
5446 !-----------------------------------------------------------------------------
5447       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5448 !      implicit none
5449       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
5450       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5451       a1=fprim0*delta/(f1-f0)
5452       a2=3.0d0-2.0d0*a1
5453       a3=a1-2.0d0
5454       ksi=(x-x0)/delta
5455       ksi2=ksi*ksi
5456       ksi3=ksi2*ksi
5457       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5458       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5459       return
5460       end subroutine spline1
5461 !-----------------------------------------------------------------------------
5462       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5463 !      implicit none
5464       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
5465       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
5466       ksi=(x-x0)/delta
5467       ksi2=ksi*ksi
5468       ksi3=ksi2*ksi
5469       a1=fprim0x*delta
5470       a2=3*(f1x-f0x)-2*fprim0x*delta
5471       a3=fprim0x*delta-2*(f1x-f0x)
5472       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5473       return
5474       end subroutine spline2
5475 !-----------------------------------------------------------------------------
5476 #ifdef CRYST_TOR
5477 !-----------------------------------------------------------------------------
5478       subroutine etor(etors,edihcnstr)
5479 !      implicit real*8 (a-h,o-z)
5480 !      include 'DIMENSIONS'
5481 !      include 'COMMON.VAR'
5482 !      include 'COMMON.GEO'
5483 !      include 'COMMON.LOCAL'
5484 !      include 'COMMON.TORSION'
5485 !      include 'COMMON.INTERACT'
5486 !      include 'COMMON.DERIV'
5487 !      include 'COMMON.CHAIN'
5488 !      include 'COMMON.NAMES'
5489 !      include 'COMMON.IOUNITS'
5490 !      include 'COMMON.FFIELD'
5491 !      include 'COMMON.TORCNSTR'
5492 !      include 'COMMON.CONTROL'
5493       real(kind=8) :: etors,edihcnstr
5494       logical :: lprn
5495 !el local variables
5496       integer :: i,j,
5497       real(kind=8) :: phii,fac,etors_ii
5498
5499 ! Set lprn=.true. for debugging
5500       lprn=.false.
5501 !      lprn=.true.
5502       etors=0.0D0
5503       do i=iphi_start,iphi_end
5504       etors_ii=0.0D0
5505         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
5506             .or. itype(i).eq.ntyp1) cycle
5507         itori=itortyp(itype(i-2))
5508         itori1=itortyp(itype(i-1))
5509         phii=phi(i)
5510         gloci=0.0D0
5511 ! Proline-Proline pair is a special case...
5512         if (itori.eq.3 .and. itori1.eq.3) then
5513           if (phii.gt.-dwapi3) then
5514             cosphi=dcos(3*phii)
5515             fac=1.0D0/(1.0D0-cosphi)
5516             etorsi=v1(1,3,3)*fac
5517             etorsi=etorsi+etorsi
5518             etors=etors+etorsi-v1(1,3,3)
5519             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5520             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5521           endif
5522           do j=1,3
5523             v1ij=v1(j+1,itori,itori1)
5524             v2ij=v2(j+1,itori,itori1)
5525             cosphi=dcos(j*phii)
5526             sinphi=dsin(j*phii)
5527             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5528             if (energy_dec) etors_ii=etors_ii+ &
5529                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5530             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5531           enddo
5532         else
5533           do j=1,nterm_old
5534             v1ij=v1(j,itori,itori1)
5535             v2ij=v2(j,itori,itori1)
5536             cosphi=dcos(j*phii)
5537             sinphi=dsin(j*phii)
5538             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5539             if (energy_dec) etors_ii=etors_ii+ &
5540                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5541             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5542           enddo
5543         endif
5544         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5545              'etor',i,etors_ii
5546         if (lprn) &
5547         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5548         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5549         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5550         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5551 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5552       enddo
5553 ! 6/20/98 - dihedral angle constraints
5554       edihcnstr=0.0d0
5555       do i=1,ndih_constr
5556         itori=idih_constr(i)
5557         phii=phi(itori)
5558         difi=phii-phi0(i)
5559         if (difi.gt.drange(i)) then
5560           difi=difi-drange(i)
5561           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5562           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5563         else if (difi.lt.-drange(i)) then
5564           difi=difi+drange(i)
5565           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5566           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5567         endif
5568 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5569 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5570       enddo
5571 !      write (iout,*) 'edihcnstr',edihcnstr
5572       return
5573       end subroutine etor
5574 !-----------------------------------------------------------------------------
5575       subroutine etor_d(etors_d)
5576       real(kind=8) :: etors_d
5577       etors_d=0.0d0
5578       return
5579       end subroutine etor_d
5580 #else
5581 !-----------------------------------------------------------------------------
5582       subroutine etor(etors,edihcnstr)
5583 !      implicit real*8 (a-h,o-z)
5584 !      include 'DIMENSIONS'
5585 !      include 'COMMON.VAR'
5586 !      include 'COMMON.GEO'
5587 !      include 'COMMON.LOCAL'
5588 !      include 'COMMON.TORSION'
5589 !      include 'COMMON.INTERACT'
5590 !      include 'COMMON.DERIV'
5591 !      include 'COMMON.CHAIN'
5592 !      include 'COMMON.NAMES'
5593 !      include 'COMMON.IOUNITS'
5594 !      include 'COMMON.FFIELD'
5595 !      include 'COMMON.TORCNSTR'
5596 !      include 'COMMON.CONTROL'
5597       real(kind=8) :: etors,edihcnstr
5598       logical :: lprn
5599 !el local variables
5600       integer :: i,j,iblock,itori,itori1
5601       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
5602                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
5603 ! Set lprn=.true. for debugging
5604       lprn=.false.
5605 !     lprn=.true.
5606       etors=0.0D0
5607       do i=iphi_start,iphi_end
5608         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5609              .or. itype(i-3).eq.ntyp1 &
5610              .or. itype(i).eq.ntyp1) cycle
5611         etors_ii=0.0D0
5612          if (iabs(itype(i)).eq.20) then
5613          iblock=2
5614          else
5615          iblock=1
5616          endif
5617         itori=itortyp(itype(i-2))
5618         itori1=itortyp(itype(i-1))
5619         phii=phi(i)
5620         gloci=0.0D0
5621 ! Regular cosine and sine terms
5622         do j=1,nterm(itori,itori1,iblock)
5623           v1ij=v1(j,itori,itori1,iblock)
5624           v2ij=v2(j,itori,itori1,iblock)
5625           cosphi=dcos(j*phii)
5626           sinphi=dsin(j*phii)
5627           etors=etors+v1ij*cosphi+v2ij*sinphi
5628           if (energy_dec) etors_ii=etors_ii+ &
5629                      v1ij*cosphi+v2ij*sinphi
5630           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5631         enddo
5632 ! Lorentz terms
5633 !                         v1
5634 !  E = SUM ----------------------------------- - v1
5635 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5636 !
5637         cosphi=dcos(0.5d0*phii)
5638         sinphi=dsin(0.5d0*phii)
5639         do j=1,nlor(itori,itori1,iblock)
5640           vl1ij=vlor1(j,itori,itori1)
5641           vl2ij=vlor2(j,itori,itori1)
5642           vl3ij=vlor3(j,itori,itori1)
5643           pom=vl2ij*cosphi+vl3ij*sinphi
5644           pom1=1.0d0/(pom*pom+1.0d0)
5645           etors=etors+vl1ij*pom1
5646           if (energy_dec) etors_ii=etors_ii+ &
5647                      vl1ij*pom1
5648           pom=-pom*pom1*pom1
5649           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5650         enddo
5651 ! Subtract the constant term
5652         etors=etors-v0(itori,itori1,iblock)
5653           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5654                'etor',i,etors_ii-v0(itori,itori1,iblock)
5655         if (lprn) &
5656         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5657         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
5658         (v1(j,itori,itori1,iblock),j=1,6),&
5659         (v2(j,itori,itori1,iblock),j=1,6)
5660         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5661 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5662       enddo
5663 ! 6/20/98 - dihedral angle constraints
5664       edihcnstr=0.0d0
5665 !      do i=1,ndih_constr
5666       do i=idihconstr_start,idihconstr_end
5667         itori=idih_constr(i)
5668         phii=phi(itori)
5669         difi=pinorm(phii-phi0(i))
5670         if (difi.gt.drange(i)) then
5671           difi=difi-drange(i)
5672           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5673           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5674         else if (difi.lt.-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
5679           difi=0.0
5680         endif
5681 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5682 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
5683 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5684       enddo
5685 !d       write (iout,*) 'edihcnstr',edihcnstr
5686       return
5687       end subroutine etor
5688 !-----------------------------------------------------------------------------
5689       subroutine etor_d(etors_d)
5690 ! 6/23/01 Compute double torsional energy
5691 !      implicit real*8 (a-h,o-z)
5692 !      include 'DIMENSIONS'
5693 !      include 'COMMON.VAR'
5694 !      include 'COMMON.GEO'
5695 !      include 'COMMON.LOCAL'
5696 !      include 'COMMON.TORSION'
5697 !      include 'COMMON.INTERACT'
5698 !      include 'COMMON.DERIV'
5699 !      include 'COMMON.CHAIN'
5700 !      include 'COMMON.NAMES'
5701 !      include 'COMMON.IOUNITS'
5702 !      include 'COMMON.FFIELD'
5703 !      include 'COMMON.TORCNSTR'
5704       real(kind=8) :: etors_d,etors_d_ii
5705       logical :: lprn
5706 !el local variables
5707       integer :: i,j,k,l,itori,itori1,itori2,iblock
5708       real(kind=8) :: phii,phii1,gloci1,gloci2,&
5709                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
5710                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
5711                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
5712 ! Set lprn=.true. for debugging
5713       lprn=.false.
5714 !     lprn=.true.
5715       etors_d=0.0D0
5716 !      write(iout,*) "a tu??"
5717       do i=iphid_start,iphid_end
5718         etors_d_ii=0.0D0
5719         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
5720             .or. itype(i-3).eq.ntyp1 &
5721             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5722         itori=itortyp(itype(i-2))
5723         itori1=itortyp(itype(i-1))
5724         itori2=itortyp(itype(i))
5725         phii=phi(i)
5726         phii1=phi(i+1)
5727         gloci1=0.0D0
5728         gloci2=0.0D0
5729         iblock=1
5730         if (iabs(itype(i+1)).eq.20) iblock=2
5731
5732 ! Regular cosine and sine terms
5733         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5734           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5735           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5736           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5737           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5738           cosphi1=dcos(j*phii)
5739           sinphi1=dsin(j*phii)
5740           cosphi2=dcos(j*phii1)
5741           sinphi2=dsin(j*phii1)
5742           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
5743            v2cij*cosphi2+v2sij*sinphi2
5744           if (energy_dec) etors_d_ii=etors_d_ii+ &
5745            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5746           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5747           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5748         enddo
5749         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5750           do l=1,k-1
5751             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5752             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5753             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5754             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5755             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5756             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5757             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5758             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5759             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5760               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5761             if (energy_dec) etors_d_ii=etors_d_ii+ &
5762               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
5763               v1sdij*sinphi1p2+v2sdij*sinphi1m2
5764             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
5765               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5766             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
5767               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5768           enddo
5769         enddo
5770         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5771                             'etor_d',i,etors_d_ii
5772         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5773         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5774       enddo
5775       return
5776       end subroutine etor_d
5777 #endif
5778 !-----------------------------------------------------------------------------
5779       subroutine eback_sc_corr(esccor)
5780 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
5781 !        conformational states; temporarily implemented as differences
5782 !        between UNRES torsional potentials (dependent on three types of
5783 !        residues) and the torsional potentials dependent on all 20 types
5784 !        of residues computed from AM1  energy surfaces of terminally-blocked
5785 !        amino-acid residues.
5786 !      implicit real*8 (a-h,o-z)
5787 !      include 'DIMENSIONS'
5788 !      include 'COMMON.VAR'
5789 !      include 'COMMON.GEO'
5790 !      include 'COMMON.LOCAL'
5791 !      include 'COMMON.TORSION'
5792 !      include 'COMMON.SCCOR'
5793 !      include 'COMMON.INTERACT'
5794 !      include 'COMMON.DERIV'
5795 !      include 'COMMON.CHAIN'
5796 !      include 'COMMON.NAMES'
5797 !      include 'COMMON.IOUNITS'
5798 !      include 'COMMON.FFIELD'
5799 !      include 'COMMON.CONTROL'
5800       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
5801                    cosphi,sinphi
5802       logical :: lprn
5803       integer :: i,interty,j,isccori,isccori1,intertyp
5804 ! Set lprn=.true. for debugging
5805       lprn=.false.
5806 !      lprn=.true.
5807 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5808       esccor=0.0D0
5809       do i=itau_start,itau_end
5810         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5811         esccor_ii=0.0D0
5812         isccori=isccortyp(itype(i-2))
5813         isccori1=isccortyp(itype(i-1))
5814
5815 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5816         phii=phi(i)
5817         do intertyp=1,3 !intertyp
5818          esccor_ii=0.0D0
5819 !c Added 09 May 2012 (Adasko)
5820 !c  Intertyp means interaction type of backbone mainchain correlation:
5821 !   1 = SC...Ca...Ca...Ca
5822 !   2 = Ca...Ca...Ca...SC
5823 !   3 = SC...Ca...Ca...SCi
5824         gloci=0.0D0
5825         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
5826             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
5827             (itype(i-1).eq.ntyp1))) &
5828           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
5829            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
5830            .or.(itype(i).eq.ntyp1))) &
5831           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
5832             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
5833             (itype(i-3).eq.ntyp1)))) cycle
5834         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5835         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
5836        cycle
5837        do j=1,nterm_sccor(isccori,isccori1)
5838           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5839           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5840           cosphi=dcos(j*tauangle(intertyp,i))
5841           sinphi=dsin(j*tauangle(intertyp,i))
5842           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5843           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5844           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5845         enddo
5846         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
5847                                 'esccor',i,intertyp,esccor_ii
5848 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5849         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5850         if (lprn) &
5851         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
5852         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
5853         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
5854         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5855         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5856        enddo !intertyp
5857       enddo
5858
5859       return
5860       end subroutine eback_sc_corr
5861 !-----------------------------------------------------------------------------
5862       subroutine multibody(ecorr)
5863 ! This subroutine calculates multi-body contributions to energy following
5864 ! the idea of Skolnick et al. If side chains I and J make a contact and
5865 ! at the same time side chains I+1 and J+1 make a contact, an extra
5866 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5867 !      implicit real*8 (a-h,o-z)
5868 !      include 'DIMENSIONS'
5869 !      include 'COMMON.IOUNITS'
5870 !      include 'COMMON.DERIV'
5871 !      include 'COMMON.INTERACT'
5872 !      include 'COMMON.CONTACTS'
5873       real(kind=8),dimension(3) :: gx,gx1
5874       logical :: lprn
5875       real(kind=8) :: ecorr
5876       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
5877 ! Set lprn=.true. for debugging
5878       lprn=.false.
5879
5880       if (lprn) then
5881         write (iout,'(a)') 'Contact function values:'
5882         do i=nnt,nct-2
5883           write (iout,'(i2,20(1x,i2,f10.5))') &
5884               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5885         enddo
5886       endif
5887       ecorr=0.0D0
5888
5889 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
5890 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
5891       do i=nnt,nct
5892         do j=1,3
5893           gradcorr(j,i)=0.0D0
5894           gradxorr(j,i)=0.0D0
5895         enddo
5896       enddo
5897       do i=nnt,nct-2
5898
5899         DO ISHIFT = 3,4
5900
5901         i1=i+ishift
5902         num_conti=num_cont(i)
5903         num_conti1=num_cont(i1)
5904         do jj=1,num_conti
5905           j=jcont(jj,i)
5906           do kk=1,num_conti1
5907             j1=jcont(kk,i1)
5908             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5909 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5910 !d   &                   ' ishift=',ishift
5911 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5912 ! The system gains extra energy.
5913               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5914             endif   ! j1==j+-ishift
5915           enddo     ! kk
5916         enddo       ! jj
5917
5918         ENDDO ! ISHIFT
5919
5920       enddo         ! i
5921       return
5922       end subroutine multibody
5923 !-----------------------------------------------------------------------------
5924       real(kind=8) function esccorr(i,j,k,l,jj,kk)
5925 !      implicit real*8 (a-h,o-z)
5926 !      include 'DIMENSIONS'
5927 !      include 'COMMON.IOUNITS'
5928 !      include 'COMMON.DERIV'
5929 !      include 'COMMON.INTERACT'
5930 !      include 'COMMON.CONTACTS'
5931       real(kind=8),dimension(3) :: gx,gx1
5932       logical :: lprn
5933       integer :: i,j,k,l,jj,kk,m,ll
5934       real(kind=8) :: eij,ekl
5935       lprn=.false.
5936       eij=facont(jj,i)
5937       ekl=facont(kk,k)
5938 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5939 ! Calculate the multi-body contribution to energy.
5940 ! Calculate multi-body contributions to the gradient.
5941 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5942 !d   & k,l,(gacont(m,kk,k),m=1,3)
5943       do m=1,3
5944         gx(m) =ekl*gacont(m,jj,i)
5945         gx1(m)=eij*gacont(m,kk,k)
5946         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5947         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5948         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5949         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5950       enddo
5951       do m=i,j-1
5952         do ll=1,3
5953           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5954         enddo
5955       enddo
5956       do m=k,l-1
5957         do ll=1,3
5958           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5959         enddo
5960       enddo
5961       esccorr=-eij*ekl
5962       return
5963       end function esccorr
5964 !-----------------------------------------------------------------------------
5965       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5966 ! This subroutine calculates multi-body contributions to hydrogen-bonding
5967 !      implicit real*8 (a-h,o-z)
5968 !      include 'DIMENSIONS'
5969 !      include 'COMMON.IOUNITS'
5970 #ifdef MPI
5971       include "mpif.h"
5972 !      integer :: maxconts !max_cont=maxconts  =nres/4
5973       integer,parameter :: max_dim=26
5974       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5975       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
5976 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
5977 !el      common /przechowalnia/ zapas
5978       integer :: status(MPI_STATUS_SIZE)
5979       integer,dimension((nres/4)*2) :: req !maxconts*2
5980       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
5981 #endif
5982 !      include 'COMMON.SETUP'
5983 !      include 'COMMON.FFIELD'
5984 !      include 'COMMON.DERIV'
5985 !      include 'COMMON.INTERACT'
5986 !      include 'COMMON.CONTACTS'
5987 !      include 'COMMON.CONTROL'
5988 !      include 'COMMON.LOCAL'
5989       real(kind=8),dimension(3) :: gx,gx1
5990       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
5991       logical :: lprn,ldone
5992 !el local variables
5993       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
5994               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
5995
5996 ! Set lprn=.true. for debugging
5997       lprn=.false.
5998 #ifdef MPI
5999 !      maxconts=nres/4
6000       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6001       n_corr=0
6002       n_corr1=0
6003       if (nfgtasks.le.1) goto 30
6004       if (lprn) then
6005         write (iout,'(a)') 'Contact function values before RECEIVE:'
6006         do i=nnt,nct-2
6007           write (iout,'(2i3,50(1x,i2,f5.2))') &
6008           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6009           j=1,num_cont_hb(i))
6010         enddo
6011       endif
6012       call flush(iout)
6013       do i=1,ntask_cont_from
6014         ncont_recv(i)=0
6015       enddo
6016       do i=1,ntask_cont_to
6017         ncont_sent(i)=0
6018       enddo
6019 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6020 !     & ntask_cont_to
6021 ! Make the list of contacts to send to send to other procesors
6022 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6023 !      call flush(iout)
6024       do i=iturn3_start,iturn3_end
6025 !        write (iout,*) "make contact list turn3",i," num_cont",
6026 !     &    num_cont_hb(i)
6027         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6028       enddo
6029       do i=iturn4_start,iturn4_end
6030 !        write (iout,*) "make contact list turn4",i," num_cont",
6031 !     &   num_cont_hb(i)
6032         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6033       enddo
6034       do ii=1,nat_sent
6035         i=iat_sent(ii)
6036 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6037 !     &    num_cont_hb(i)
6038         do j=1,num_cont_hb(i)
6039         do k=1,4
6040           jjc=jcont_hb(j,i)
6041           iproc=iint_sent_local(k,jjc,ii)
6042 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6043           if (iproc.gt.0) then
6044             ncont_sent(iproc)=ncont_sent(iproc)+1
6045             nn=ncont_sent(iproc)
6046             zapas(1,nn,iproc)=i
6047             zapas(2,nn,iproc)=jjc
6048             zapas(3,nn,iproc)=facont_hb(j,i)
6049             zapas(4,nn,iproc)=ees0p(j,i)
6050             zapas(5,nn,iproc)=ees0m(j,i)
6051             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6052             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6053             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6054             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6055             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6056             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6057             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6058             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6059             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6060             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6061             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6062             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6063             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6064             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6065             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6066             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6067             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6068             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6069             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6070             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6071             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6072           endif
6073         enddo
6074         enddo
6075       enddo
6076       if (lprn) then
6077       write (iout,*) &
6078         "Numbers of contacts to be sent to other processors",&
6079         (ncont_sent(i),i=1,ntask_cont_to)
6080       write (iout,*) "Contacts sent"
6081       do ii=1,ntask_cont_to
6082         nn=ncont_sent(ii)
6083         iproc=itask_cont_to(ii)
6084         write (iout,*) nn," contacts to processor",iproc,&
6085          " of CONT_TO_COMM group"
6086         do i=1,nn
6087           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6088         enddo
6089       enddo
6090       call flush(iout)
6091       endif
6092       CorrelType=477
6093       CorrelID=fg_rank+1
6094       CorrelType1=478
6095       CorrelID1=nfgtasks+fg_rank+1
6096       ireq=0
6097 ! Receive the numbers of needed contacts from other processors
6098       do ii=1,ntask_cont_from
6099         iproc=itask_cont_from(ii)
6100         ireq=ireq+1
6101         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6102           FG_COMM,req(ireq),IERR)
6103       enddo
6104 !      write (iout,*) "IRECV ended"
6105 !      call flush(iout)
6106 ! Send the number of contacts needed by other processors
6107       do ii=1,ntask_cont_to
6108         iproc=itask_cont_to(ii)
6109         ireq=ireq+1
6110         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6111           FG_COMM,req(ireq),IERR)
6112       enddo
6113 !      write (iout,*) "ISEND ended"
6114 !      write (iout,*) "number of requests (nn)",ireq
6115       call flush(iout)
6116       if (ireq.gt.0) &
6117         call MPI_Waitall(ireq,req,status_array,ierr)
6118 !      write (iout,*)
6119 !     &  "Numbers of contacts to be received from other processors",
6120 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6121 !      call flush(iout)
6122 ! Receive contacts
6123       ireq=0
6124       do ii=1,ntask_cont_from
6125         iproc=itask_cont_from(ii)
6126         nn=ncont_recv(ii)
6127 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6128 !     &   " of CONT_TO_COMM group"
6129         call flush(iout)
6130         if (nn.gt.0) then
6131           ireq=ireq+1
6132           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6133           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6134 !          write (iout,*) "ireq,req",ireq,req(ireq)
6135         endif
6136       enddo
6137 ! Send the contacts to processors that need them
6138       do ii=1,ntask_cont_to
6139         iproc=itask_cont_to(ii)
6140         nn=ncont_sent(ii)
6141 !        write (iout,*) nn," contacts to processor",iproc,
6142 !     &   " of CONT_TO_COMM group"
6143         if (nn.gt.0) then
6144           ireq=ireq+1
6145           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6146             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6147 !          write (iout,*) "ireq,req",ireq,req(ireq)
6148 !          do i=1,nn
6149 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6150 !          enddo
6151         endif
6152       enddo
6153 !      write (iout,*) "number of requests (contacts)",ireq
6154 !      write (iout,*) "req",(req(i),i=1,4)
6155 !      call flush(iout)
6156       if (ireq.gt.0) &
6157        call MPI_Waitall(ireq,req,status_array,ierr)
6158       do iii=1,ntask_cont_from
6159         iproc=itask_cont_from(iii)
6160         nn=ncont_recv(iii)
6161         if (lprn) then
6162         write (iout,*) "Received",nn," contacts from processor",iproc,&
6163          " of CONT_FROM_COMM group"
6164         call flush(iout)
6165         do i=1,nn
6166           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6167         enddo
6168         call flush(iout)
6169         endif
6170         do i=1,nn
6171           ii=zapas_recv(1,i,iii)
6172 ! Flag the received contacts to prevent double-counting
6173           jj=-zapas_recv(2,i,iii)
6174 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6175 !          call flush(iout)
6176           nnn=num_cont_hb(ii)+1
6177           num_cont_hb(ii)=nnn
6178           jcont_hb(nnn,ii)=jj
6179           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6180           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6181           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6182           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6183           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6184           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6185           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6186           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6187           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6188           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6189           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6190           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6191           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6192           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6193           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6194           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6195           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6196           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6197           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6198           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6199           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6200           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6201           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6202           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6203         enddo
6204       enddo
6205       call flush(iout)
6206       if (lprn) then
6207         write (iout,'(a)') 'Contact function values after receive:'
6208         do i=nnt,nct-2
6209           write (iout,'(2i3,50(1x,i3,f5.2))') &
6210           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6211           j=1,num_cont_hb(i))
6212         enddo
6213         call flush(iout)
6214       endif
6215    30 continue
6216 #endif
6217       if (lprn) then
6218         write (iout,'(a)') 'Contact function values:'
6219         do i=nnt,nct-2
6220           write (iout,'(2i3,50(1x,i3,f5.2))') &
6221           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6222           j=1,num_cont_hb(i))
6223         enddo
6224       endif
6225       ecorr=0.0D0
6226
6227 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6228 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6229 ! Remove the loop below after debugging !!!
6230       do i=nnt,nct
6231         do j=1,3
6232           gradcorr(j,i)=0.0D0
6233           gradxorr(j,i)=0.0D0
6234         enddo
6235       enddo
6236 ! Calculate the local-electrostatic correlation terms
6237       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6238         i1=i+1
6239         num_conti=num_cont_hb(i)
6240         num_conti1=num_cont_hb(i+1)
6241         do jj=1,num_conti
6242           j=jcont_hb(jj,i)
6243           jp=iabs(j)
6244           do kk=1,num_conti1
6245             j1=jcont_hb(kk,i1)
6246             jp1=iabs(j1)
6247 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
6248 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
6249             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6250                 .or. j.lt.0 .and. j1.gt.0) .and. &
6251                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6252 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6253 ! The system gains extra energy.
6254               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6255               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
6256                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6257               n_corr=n_corr+1
6258             else if (j1.eq.j) then
6259 ! Contacts I-J and I-(J+1) occur simultaneously.
6260 ! The system loses extra energy.
6261 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6262             endif
6263           enddo ! kk
6264           do kk=1,num_conti
6265             j1=jcont_hb(kk,i)
6266 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6267 !    &         ' jj=',jj,' kk=',kk
6268             if (j1.eq.j+1) then
6269 ! Contacts I-J and (I+1)-J occur simultaneously.
6270 ! The system loses extra energy.
6271 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6272             endif ! j1==j+1
6273           enddo ! kk
6274         enddo ! jj
6275       enddo ! i
6276       return
6277       end subroutine multibody_hb
6278 !-----------------------------------------------------------------------------
6279       subroutine add_hb_contact(ii,jj,itask)
6280 !      implicit real*8 (a-h,o-z)
6281 !      include "DIMENSIONS"
6282 !      include "COMMON.IOUNITS"
6283 !      include "COMMON.CONTACTS"
6284 !      integer,parameter :: maxconts=nres/4
6285       integer,parameter :: max_dim=26
6286       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6287 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6288 !      common /przechowalnia/ zapas
6289       integer :: i,j,ii,jj,iproc,nn,jjc
6290       integer,dimension(4) :: itask
6291 !      write (iout,*) "itask",itask
6292       do i=1,2
6293         iproc=itask(i)
6294         if (iproc.gt.0) then
6295           do j=1,num_cont_hb(ii)
6296             jjc=jcont_hb(j,ii)
6297 !            write (iout,*) "i",ii," j",jj," jjc",jjc
6298             if (jjc.eq.jj) then
6299               ncont_sent(iproc)=ncont_sent(iproc)+1
6300               nn=ncont_sent(iproc)
6301               zapas(1,nn,iproc)=ii
6302               zapas(2,nn,iproc)=jjc
6303               zapas(3,nn,iproc)=facont_hb(j,ii)
6304               zapas(4,nn,iproc)=ees0p(j,ii)
6305               zapas(5,nn,iproc)=ees0m(j,ii)
6306               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6307               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6308               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6309               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6310               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6311               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6312               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6313               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6314               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6315               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6316               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6317               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6318               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6319               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6320               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6321               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6322               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6323               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6324               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6325               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6326               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6327               exit
6328             endif
6329           enddo
6330         endif
6331       enddo
6332       return
6333       end subroutine add_hb_contact
6334 !-----------------------------------------------------------------------------
6335       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
6336 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6337 !      implicit real*8 (a-h,o-z)
6338 !      include 'DIMENSIONS'
6339 !      include 'COMMON.IOUNITS'
6340       integer,parameter :: max_dim=70
6341 #ifdef MPI
6342       include "mpif.h"
6343 !      integer :: maxconts !max_cont=maxconts=nres/4
6344       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6345       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6346 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6347 !      common /przechowalnia/ zapas
6348       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
6349         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
6350         ierr,iii,nnn
6351 #endif
6352 !      include 'COMMON.SETUP'
6353 !      include 'COMMON.FFIELD'
6354 !      include 'COMMON.DERIV'
6355 !      include 'COMMON.LOCAL'
6356 !      include 'COMMON.INTERACT'
6357 !      include 'COMMON.CONTACTS'
6358 !      include 'COMMON.CHAIN'
6359 !      include 'COMMON.CONTROL'
6360       real(kind=8),dimension(3) :: gx,gx1
6361       integer,dimension(nres) :: num_cont_hb_old
6362       logical :: lprn,ldone
6363 !EL      double precision eello4,eello5,eelo6,eello_turn6
6364 !EL      external eello4,eello5,eello6,eello_turn6
6365 !el local variables
6366       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
6367               j1,jp1,i1,num_conti1
6368       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
6369       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
6370
6371 ! Set lprn=.true. for debugging
6372       lprn=.false.
6373       eturn6=0.0d0
6374 #ifdef MPI
6375 !      maxconts=nres/4
6376       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6377       do i=1,nres
6378         num_cont_hb_old(i)=num_cont_hb(i)
6379       enddo
6380       n_corr=0
6381       n_corr1=0
6382       if (nfgtasks.le.1) goto 30
6383       if (lprn) then
6384         write (iout,'(a)') 'Contact function values before RECEIVE:'
6385         do i=nnt,nct-2
6386           write (iout,'(2i3,50(1x,i2,f5.2))') &
6387           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6388           j=1,num_cont_hb(i))
6389         enddo
6390       endif
6391       call flush(iout)
6392       do i=1,ntask_cont_from
6393         ncont_recv(i)=0
6394       enddo
6395       do i=1,ntask_cont_to
6396         ncont_sent(i)=0
6397       enddo
6398 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6399 !     & ntask_cont_to
6400 ! Make the list of contacts to send to send to other procesors
6401       do i=iturn3_start,iturn3_end
6402 !        write (iout,*) "make contact list turn3",i," num_cont",
6403 !     &    num_cont_hb(i)
6404         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6405       enddo
6406       do i=iturn4_start,iturn4_end
6407 !        write (iout,*) "make contact list turn4",i," num_cont",
6408 !     &   num_cont_hb(i)
6409         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6410       enddo
6411       do ii=1,nat_sent
6412         i=iat_sent(ii)
6413 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6414 !     &    num_cont_hb(i)
6415         do j=1,num_cont_hb(i)
6416         do k=1,4
6417           jjc=jcont_hb(j,i)
6418           iproc=iint_sent_local(k,jjc,ii)
6419 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6420           if (iproc.ne.0) then
6421             ncont_sent(iproc)=ncont_sent(iproc)+1
6422             nn=ncont_sent(iproc)
6423             zapas(1,nn,iproc)=i
6424             zapas(2,nn,iproc)=jjc
6425             zapas(3,nn,iproc)=d_cont(j,i)
6426             ind=3
6427             do kk=1,3
6428               ind=ind+1
6429               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6430             enddo
6431             do kk=1,2
6432               do ll=1,2
6433                 ind=ind+1
6434                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6435               enddo
6436             enddo
6437             do jj=1,5
6438               do kk=1,3
6439                 do ll=1,2
6440                   do mm=1,2
6441                     ind=ind+1
6442                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6443                   enddo
6444                 enddo
6445               enddo
6446             enddo
6447           endif
6448         enddo
6449         enddo
6450       enddo
6451       if (lprn) then
6452       write (iout,*) &
6453         "Numbers of contacts to be sent to other processors",&
6454         (ncont_sent(i),i=1,ntask_cont_to)
6455       write (iout,*) "Contacts sent"
6456       do ii=1,ntask_cont_to
6457         nn=ncont_sent(ii)
6458         iproc=itask_cont_to(ii)
6459         write (iout,*) nn," contacts to processor",iproc,&
6460          " of CONT_TO_COMM group"
6461         do i=1,nn
6462           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6463         enddo
6464       enddo
6465       call flush(iout)
6466       endif
6467       CorrelType=477
6468       CorrelID=fg_rank+1
6469       CorrelType1=478
6470       CorrelID1=nfgtasks+fg_rank+1
6471       ireq=0
6472 ! Receive the numbers of needed contacts from other processors
6473       do ii=1,ntask_cont_from
6474         iproc=itask_cont_from(ii)
6475         ireq=ireq+1
6476         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6477           FG_COMM,req(ireq),IERR)
6478       enddo
6479 !      write (iout,*) "IRECV ended"
6480 !      call flush(iout)
6481 ! Send the number of contacts needed by other processors
6482       do ii=1,ntask_cont_to
6483         iproc=itask_cont_to(ii)
6484         ireq=ireq+1
6485         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6486           FG_COMM,req(ireq),IERR)
6487       enddo
6488 !      write (iout,*) "ISEND ended"
6489 !      write (iout,*) "number of requests (nn)",ireq
6490       call flush(iout)
6491       if (ireq.gt.0) &
6492         call MPI_Waitall(ireq,req,status_array,ierr)
6493 !      write (iout,*)
6494 !     &  "Numbers of contacts to be received from other processors",
6495 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6496 !      call flush(iout)
6497 ! Receive contacts
6498       ireq=0
6499       do ii=1,ntask_cont_from
6500         iproc=itask_cont_from(ii)
6501         nn=ncont_recv(ii)
6502 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6503 !     &   " of CONT_TO_COMM group"
6504         call flush(iout)
6505         if (nn.gt.0) then
6506           ireq=ireq+1
6507           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6508           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6509 !          write (iout,*) "ireq,req",ireq,req(ireq)
6510         endif
6511       enddo
6512 ! Send the contacts to processors that need them
6513       do ii=1,ntask_cont_to
6514         iproc=itask_cont_to(ii)
6515         nn=ncont_sent(ii)
6516 !        write (iout,*) nn," contacts to processor",iproc,
6517 !     &   " of CONT_TO_COMM group"
6518         if (nn.gt.0) then
6519           ireq=ireq+1
6520           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6521             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6522 !          write (iout,*) "ireq,req",ireq,req(ireq)
6523 !          do i=1,nn
6524 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6525 !          enddo
6526         endif
6527       enddo
6528 !      write (iout,*) "number of requests (contacts)",ireq
6529 !      write (iout,*) "req",(req(i),i=1,4)
6530 !      call flush(iout)
6531       if (ireq.gt.0) &
6532        call MPI_Waitall(ireq,req,status_array,ierr)
6533       do iii=1,ntask_cont_from
6534         iproc=itask_cont_from(iii)
6535         nn=ncont_recv(iii)
6536         if (lprn) then
6537         write (iout,*) "Received",nn," contacts from processor",iproc,&
6538          " of CONT_FROM_COMM group"
6539         call flush(iout)
6540         do i=1,nn
6541           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6542         enddo
6543         call flush(iout)
6544         endif
6545         do i=1,nn
6546           ii=zapas_recv(1,i,iii)
6547 ! Flag the received contacts to prevent double-counting
6548           jj=-zapas_recv(2,i,iii)
6549 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6550 !          call flush(iout)
6551           nnn=num_cont_hb(ii)+1
6552           num_cont_hb(ii)=nnn
6553           jcont_hb(nnn,ii)=jj
6554           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6555           ind=3
6556           do kk=1,3
6557             ind=ind+1
6558             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6559           enddo
6560           do kk=1,2
6561             do ll=1,2
6562               ind=ind+1
6563               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6564             enddo
6565           enddo
6566           do jj=1,5
6567             do kk=1,3
6568               do ll=1,2
6569                 do mm=1,2
6570                   ind=ind+1
6571                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6572                 enddo
6573               enddo
6574             enddo
6575           enddo
6576         enddo
6577       enddo
6578       call flush(iout)
6579       if (lprn) then
6580         write (iout,'(a)') 'Contact function values after receive:'
6581         do i=nnt,nct-2
6582           write (iout,'(2i3,50(1x,i3,5f6.3))') &
6583           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6584           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6585         enddo
6586         call flush(iout)
6587       endif
6588    30 continue
6589 #endif
6590       if (lprn) then
6591         write (iout,'(a)') 'Contact function values:'
6592         do i=nnt,nct-2
6593           write (iout,'(2i3,50(1x,i2,5f6.3))') &
6594           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
6595           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6596         enddo
6597       endif
6598       ecorr=0.0D0
6599       ecorr5=0.0d0
6600       ecorr6=0.0d0
6601
6602 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6603 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6604 ! Remove the loop below after debugging !!!
6605       do i=nnt,nct
6606         do j=1,3
6607           gradcorr(j,i)=0.0D0
6608           gradxorr(j,i)=0.0D0
6609         enddo
6610       enddo
6611 ! Calculate the dipole-dipole interaction energies
6612       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6613       do i=iatel_s,iatel_e+1
6614         num_conti=num_cont_hb(i)
6615         do jj=1,num_conti
6616           j=jcont_hb(jj,i)
6617 #ifdef MOMENT
6618           call dipole(i,j,jj)
6619 #endif
6620         enddo
6621       enddo
6622       endif
6623 ! Calculate the local-electrostatic correlation terms
6624 !                write (iout,*) "gradcorr5 in eello5 before loop"
6625 !                do iii=1,nres
6626 !                  write (iout,'(i5,3f10.5)')
6627 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6628 !                enddo
6629       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6630 !        write (iout,*) "corr loop i",i
6631         i1=i+1
6632         num_conti=num_cont_hb(i)
6633         num_conti1=num_cont_hb(i+1)
6634         do jj=1,num_conti
6635           j=jcont_hb(jj,i)
6636           jp=iabs(j)
6637           do kk=1,num_conti1
6638             j1=jcont_hb(kk,i1)
6639             jp1=iabs(j1)
6640 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6641 !     &         ' jj=',jj,' kk=',kk
6642 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
6643             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
6644                 .or. j.lt.0 .and. j1.gt.0) .and. &
6645                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6646 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6647 ! The system gains extra energy.
6648               n_corr=n_corr+1
6649               sqd1=dsqrt(d_cont(jj,i))
6650               sqd2=dsqrt(d_cont(kk,i1))
6651               sred_geom = sqd1*sqd2
6652               IF (sred_geom.lt.cutoff_corr) THEN
6653                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
6654                   ekont,fprimcont)
6655 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6656 !d     &         ' jj=',jj,' kk=',kk
6657                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6658                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6659                 do l=1,3
6660                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6661                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6662                 enddo
6663                 n_corr1=n_corr1+1
6664 !d               write (iout,*) 'sred_geom=',sred_geom,
6665 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
6666 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6667 !d               write (iout,*) "g_contij",g_contij
6668 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6669 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6670                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6671                 if (wcorr4.gt.0.0d0) &
6672                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6673                   if (energy_dec.and.wcorr4.gt.0.0d0) &
6674                        write (iout,'(a6,4i5,0pf7.3)') &
6675                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6676 !                write (iout,*) "gradcorr5 before eello5"
6677 !                do iii=1,nres
6678 !                  write (iout,'(i5,3f10.5)')
6679 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6680 !                enddo
6681                 if (wcorr5.gt.0.0d0) &
6682                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6683 !                write (iout,*) "gradcorr5 after eello5"
6684 !                do iii=1,nres
6685 !                  write (iout,'(i5,3f10.5)')
6686 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6687 !                enddo
6688                   if (energy_dec.and.wcorr5.gt.0.0d0) &
6689                        write (iout,'(a6,4i5,0pf7.3)') &
6690                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6691 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6692 !d                write(2,*)'ijkl',i,jp,i+1,jp1
6693                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
6694                      .or. wturn6.eq.0.0d0))then
6695 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6696                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6697                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6698                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6699 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6700 !d     &            'ecorr6=',ecorr6
6701 !d                write (iout,'(4e15.5)') sred_geom,
6702 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6703 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6704 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6705                 else if (wturn6.gt.0.0d0 &
6706                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6707 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6708                   eturn6=eturn6+eello_turn6(i,jj,kk)
6709                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
6710                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6711 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
6712                 endif
6713               ENDIF
6714 1111          continue
6715             endif
6716           enddo ! kk
6717         enddo ! jj
6718       enddo ! i
6719       do i=1,nres
6720         num_cont_hb(i)=num_cont_hb_old(i)
6721       enddo
6722 !                write (iout,*) "gradcorr5 in eello5"
6723 !                do iii=1,nres
6724 !                  write (iout,'(i5,3f10.5)')
6725 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6726 !                enddo
6727       return
6728       end subroutine multibody_eello
6729 !-----------------------------------------------------------------------------
6730       subroutine add_hb_contact_eello(ii,jj,itask)
6731 !      implicit real*8 (a-h,o-z)
6732 !      include "DIMENSIONS"
6733 !      include "COMMON.IOUNITS"
6734 !      include "COMMON.CONTACTS"
6735 !      integer,parameter :: maxconts=nres/4
6736       integer,parameter :: max_dim=70
6737       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
6738 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6739 !      common /przechowalnia/ zapas
6740
6741       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
6742       integer,dimension(4) ::itask
6743 !      write (iout,*) "itask",itask
6744       do i=1,2
6745         iproc=itask(i)
6746         if (iproc.gt.0) then
6747           do j=1,num_cont_hb(ii)
6748             jjc=jcont_hb(j,ii)
6749 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6750             if (jjc.eq.jj) then
6751               ncont_sent(iproc)=ncont_sent(iproc)+1
6752               nn=ncont_sent(iproc)
6753               zapas(1,nn,iproc)=ii
6754               zapas(2,nn,iproc)=jjc
6755               zapas(3,nn,iproc)=d_cont(j,ii)
6756               ind=3
6757               do kk=1,3
6758                 ind=ind+1
6759                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6760               enddo
6761               do kk=1,2
6762                 do ll=1,2
6763                   ind=ind+1
6764                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6765                 enddo
6766               enddo
6767               do jj=1,5
6768                 do kk=1,3
6769                   do ll=1,2
6770                     do mm=1,2
6771                       ind=ind+1
6772                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6773                     enddo
6774                   enddo
6775                 enddo
6776               enddo
6777               exit
6778             endif
6779           enddo
6780         endif
6781       enddo
6782       return
6783       end subroutine add_hb_contact_eello
6784 !-----------------------------------------------------------------------------
6785       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6786 !      implicit real*8 (a-h,o-z)
6787 !      include 'DIMENSIONS'
6788 !      include 'COMMON.IOUNITS'
6789 !      include 'COMMON.DERIV'
6790 !      include 'COMMON.INTERACT'
6791 !      include 'COMMON.CONTACTS'
6792       real(kind=8),dimension(3) :: gx,gx1
6793       logical :: lprn
6794 !el local variables
6795       integer :: i,j,k,l,jj,kk,ll
6796       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
6797                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
6798                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl
6799
6800       lprn=.false.
6801       eij=facont_hb(jj,i)
6802       ekl=facont_hb(kk,k)
6803       ees0pij=ees0p(jj,i)
6804       ees0pkl=ees0p(kk,k)
6805       ees0mij=ees0m(jj,i)
6806       ees0mkl=ees0m(kk,k)
6807       ekont=eij*ekl
6808       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6809 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6810 ! Following 4 lines for diagnostics.
6811 !d    ees0pkl=0.0D0
6812 !d    ees0pij=1.0D0
6813 !d    ees0mkl=0.0D0
6814 !d    ees0mij=1.0D0
6815 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6816 !     & 'Contacts ',i,j,
6817 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6818 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6819 !     & 'gradcorr_long'
6820 ! Calculate the multi-body contribution to energy.
6821 !      ecorr=ecorr+ekont*ees
6822 ! Calculate multi-body contributions to the gradient.
6823       coeffpees0pij=coeffp*ees0pij
6824       coeffmees0mij=coeffm*ees0mij
6825       coeffpees0pkl=coeffp*ees0pkl
6826       coeffmees0mkl=coeffm*ees0mkl
6827       do ll=1,3
6828 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6829         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
6830         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
6831         coeffmees0mkl*gacontm_hb1(ll,jj,i))
6832         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
6833         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
6834         coeffmees0mkl*gacontm_hb2(ll,jj,i))
6835 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6836         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
6837         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
6838         coeffmees0mij*gacontm_hb1(ll,kk,k))
6839         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
6840         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
6841         coeffmees0mij*gacontm_hb2(ll,kk,k))
6842         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
6843            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
6844            coeffmees0mkl*gacontm_hb3(ll,jj,i))
6845         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6846         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6847         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
6848            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
6849            coeffmees0mij*gacontm_hb3(ll,kk,k))
6850         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6851         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6852 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6853       enddo
6854 !      write (iout,*)
6855 !grad      do m=i+1,j-1
6856 !grad        do ll=1,3
6857 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6858 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6859 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6860 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6861 !grad        enddo
6862 !grad      enddo
6863 !grad      do m=k+1,l-1
6864 !grad        do ll=1,3
6865 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
6866 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
6867 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6868 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6869 !grad        enddo
6870 !grad      enddo
6871 !      write (iout,*) "ehbcorr",ekont*ees
6872       ehbcorr=ekont*ees
6873       return
6874       end function ehbcorr
6875 #ifdef MOMENT
6876 !-----------------------------------------------------------------------------
6877       subroutine dipole(i,j,jj)
6878 !      implicit real*8 (a-h,o-z)
6879 !      include 'DIMENSIONS'
6880 !      include 'COMMON.IOUNITS'
6881 !      include 'COMMON.CHAIN'
6882 !      include 'COMMON.FFIELD'
6883 !      include 'COMMON.DERIV'
6884 !      include 'COMMON.INTERACT'
6885 !      include 'COMMON.CONTACTS'
6886 !      include 'COMMON.TORSION'
6887 !      include 'COMMON.VAR'
6888 !      include 'COMMON.GEO'
6889       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
6890       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
6891       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
6892
6893       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
6894       allocate(dipderx(3,5,4,maxconts,nres))
6895 !
6896
6897       iti1 = itortyp(itype(i+1))
6898       if (j.lt.nres-1) then
6899         itj1 = itortyp(itype(j+1))
6900       else
6901         itj1=ntortyp+1
6902       endif
6903       do iii=1,2
6904         dipi(iii,1)=Ub2(iii,i)
6905         dipderi(iii)=Ub2der(iii,i)
6906         dipi(iii,2)=b1(iii,iti1)
6907         dipj(iii,1)=Ub2(iii,j)
6908         dipderj(iii)=Ub2der(iii,j)
6909         dipj(iii,2)=b1(iii,itj1)
6910       enddo
6911       kkk=0
6912       do iii=1,2
6913         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6914         do jjj=1,2
6915           kkk=kkk+1
6916           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6917         enddo
6918       enddo
6919       do kkk=1,5
6920         do lll=1,3
6921           mmm=0
6922           do iii=1,2
6923             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
6924               auxvec(1))
6925             do jjj=1,2
6926               mmm=mmm+1
6927               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6928             enddo
6929           enddo
6930         enddo
6931       enddo
6932       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6933       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6934       do iii=1,2
6935         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6936       enddo
6937       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6938       do iii=1,2
6939         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6940       enddo
6941       return
6942       end subroutine dipole
6943 #endif
6944 !-----------------------------------------------------------------------------
6945       subroutine calc_eello(i,j,k,l,jj,kk)
6946 !
6947 ! This subroutine computes matrices and vectors needed to calculate
6948 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
6949 !
6950       use comm_kut
6951 !      implicit real*8 (a-h,o-z)
6952 !      include 'DIMENSIONS'
6953 !      include 'COMMON.IOUNITS'
6954 !      include 'COMMON.CHAIN'
6955 !      include 'COMMON.DERIV'
6956 !      include 'COMMON.INTERACT'
6957 !      include 'COMMON.CONTACTS'
6958 !      include 'COMMON.TORSION'
6959 !      include 'COMMON.VAR'
6960 !      include 'COMMON.GEO'
6961 !      include 'COMMON.FFIELD'
6962       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
6963       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
6964       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
6965               itj1
6966 !el      logical :: lprn
6967 !el      common /kutas/ lprn
6968 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6969 !d     & ' jj=',jj,' kk=',kk
6970 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6971 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6972 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6973       do iii=1,2
6974         do jjj=1,2
6975           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6976           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6977         enddo
6978       enddo
6979       call transpose2(aa1(1,1),aa1t(1,1))
6980       call transpose2(aa2(1,1),aa2t(1,1))
6981       do kkk=1,5
6982         do lll=1,3
6983           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
6984             aa1tder(1,1,lll,kkk))
6985           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
6986             aa2tder(1,1,lll,kkk))
6987         enddo
6988       enddo
6989       if (l.eq.j+1) then
6990 ! parallel orientation of the two CA-CA-CA frames.
6991         if (i.gt.1) then
6992           iti=itortyp(itype(i))
6993         else
6994           iti=ntortyp+1
6995         endif
6996         itk1=itortyp(itype(k+1))
6997         itj=itortyp(itype(j))
6998         if (l.lt.nres-1) then
6999           itl1=itortyp(itype(l+1))
7000         else
7001           itl1=ntortyp+1
7002         endif
7003 ! A1 kernel(j+1) A2T
7004 !d        do iii=1,2
7005 !d          write (iout,'(3f10.5,5x,3f10.5)')
7006 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7007 !d        enddo
7008         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7009          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7010          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7011 ! Following matrices are needed only for 6-th order cumulants
7012         IF (wcorr6.gt.0.0d0) THEN
7013         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7014          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7015          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7016         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7017          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7018          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7019          ADtEAderx(1,1,1,1,1,1))
7020         lprn=.false.
7021         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7022          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7023          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7024          ADtEA1derx(1,1,1,1,1,1))
7025         ENDIF
7026 ! End 6-th order cumulants
7027 !d        lprn=.false.
7028 !d        if (lprn) then
7029 !d        write (2,*) 'In calc_eello6'
7030 !d        do iii=1,2
7031 !d          write (2,*) 'iii=',iii
7032 !d          do kkk=1,5
7033 !d            write (2,*) 'kkk=',kkk
7034 !d            do jjj=1,2
7035 !d              write (2,'(3(2f10.5),5x)')
7036 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7037 !d            enddo
7038 !d          enddo
7039 !d        enddo
7040 !d        endif
7041         call transpose2(EUgder(1,1,k),auxmat(1,1))
7042         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7043         call transpose2(EUg(1,1,k),auxmat(1,1))
7044         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7045         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7046         do iii=1,2
7047           do kkk=1,5
7048             do lll=1,3
7049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7050                 EAEAderx(1,1,lll,kkk,iii,1))
7051             enddo
7052           enddo
7053         enddo
7054 ! A1T kernel(i+1) A2
7055         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7056          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7057          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7058 ! Following matrices are needed only for 6-th order cumulants
7059         IF (wcorr6.gt.0.0d0) THEN
7060         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7061          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7062          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7063         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7064          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7065          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7066          ADtEAderx(1,1,1,1,1,2))
7067         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7068          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7069          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7070          ADtEA1derx(1,1,1,1,1,2))
7071         ENDIF
7072 ! End 6-th order cumulants
7073         call transpose2(EUgder(1,1,l),auxmat(1,1))
7074         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7075         call transpose2(EUg(1,1,l),auxmat(1,1))
7076         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7077         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7078         do iii=1,2
7079           do kkk=1,5
7080             do lll=1,3
7081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7082                 EAEAderx(1,1,lll,kkk,iii,2))
7083             enddo
7084           enddo
7085         enddo
7086 ! AEAb1 and AEAb2
7087 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7088 ! They are needed only when the fifth- or the sixth-order cumulants are
7089 ! indluded.
7090         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7091         call transpose2(AEA(1,1,1),auxmat(1,1))
7092         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7093         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7094         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7095         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7096         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7097         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7098         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7099         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7100         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7101         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7102         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7103         call transpose2(AEA(1,1,2),auxmat(1,1))
7104         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7105         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7106         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7107         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7108         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7109         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7110         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7111         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7112         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7113         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7114         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7115 ! Calculate the Cartesian derivatives of the vectors.
7116         do iii=1,2
7117           do kkk=1,5
7118             do lll=1,3
7119               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7120               call matvec2(auxmat(1,1),b1(1,iti),&
7121                 AEAb1derx(1,lll,kkk,iii,1,1))
7122               call matvec2(auxmat(1,1),Ub2(1,i),&
7123                 AEAb2derx(1,lll,kkk,iii,1,1))
7124               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7125                 AEAb1derx(1,lll,kkk,iii,2,1))
7126               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7127                 AEAb2derx(1,lll,kkk,iii,2,1))
7128               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7129               call matvec2(auxmat(1,1),b1(1,itj),&
7130                 AEAb1derx(1,lll,kkk,iii,1,2))
7131               call matvec2(auxmat(1,1),Ub2(1,j),&
7132                 AEAb2derx(1,lll,kkk,iii,1,2))
7133               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
7134                 AEAb1derx(1,lll,kkk,iii,2,2))
7135               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
7136                 AEAb2derx(1,lll,kkk,iii,2,2))
7137             enddo
7138           enddo
7139         enddo
7140         ENDIF
7141 ! End vectors
7142       else
7143 ! Antiparallel orientation of the two CA-CA-CA frames.
7144         if (i.gt.1) then
7145           iti=itortyp(itype(i))
7146         else
7147           iti=ntortyp+1
7148         endif
7149         itk1=itortyp(itype(k+1))
7150         itl=itortyp(itype(l))
7151         itj=itortyp(itype(j))
7152         if (j.lt.nres-1) then
7153           itj1=itortyp(itype(j+1))
7154         else
7155           itj1=ntortyp+1
7156         endif
7157 ! A2 kernel(j-1)T A1T
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7159          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
7160          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7161 ! Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7163            j.eq.i+4 .and. l.eq.i+3)) THEN
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7165          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
7166          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7167         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7168          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
7169          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7170          ADtEAderx(1,1,1,1,1,1))
7171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7172          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
7173          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7174          ADtEA1derx(1,1,1,1,1,1))
7175         ENDIF
7176 ! End 6-th order cumulants
7177         call transpose2(EUgder(1,1,k),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7179         call transpose2(EUg(1,1,k),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7186                 EAEAderx(1,1,lll,kkk,iii,1))
7187             enddo
7188           enddo
7189         enddo
7190 ! A2T kernel(i+1)T A1
7191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7192          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
7193          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7194 ! Following matrices are needed only for 6-th order cumulants
7195         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
7196            j.eq.i+4 .and. l.eq.i+3)) THEN
7197         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7198          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
7199          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7200         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7201          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
7202          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7203          ADtEAderx(1,1,1,1,1,2))
7204         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
7205          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
7206          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7207          ADtEA1derx(1,1,1,1,1,2))
7208         ENDIF
7209 ! End 6-th order cumulants
7210         call transpose2(EUgder(1,1,j),auxmat(1,1))
7211         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7212         call transpose2(EUg(1,1,j),auxmat(1,1))
7213         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7214         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7215         do iii=1,2
7216           do kkk=1,5
7217             do lll=1,3
7218               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7219                 EAEAderx(1,1,lll,kkk,iii,2))
7220             enddo
7221           enddo
7222         enddo
7223 ! AEAb1 and AEAb2
7224 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7225 ! They are needed only when the fifth- or the sixth-order cumulants are
7226 ! indluded.
7227         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
7228           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7229         call transpose2(AEA(1,1,1),auxmat(1,1))
7230         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7231         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7232         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7233         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7234         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7235         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7236         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7237         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7238         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7239         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7240         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7241         call transpose2(AEA(1,1,2),auxmat(1,1))
7242         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7243         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7244         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7245         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7246         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7247         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7248         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7249         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7250         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7251         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7252         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7253 ! Calculate the Cartesian derivatives of the vectors.
7254         do iii=1,2
7255           do kkk=1,5
7256             do lll=1,3
7257               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7258               call matvec2(auxmat(1,1),b1(1,iti),&
7259                 AEAb1derx(1,lll,kkk,iii,1,1))
7260               call matvec2(auxmat(1,1),Ub2(1,i),&
7261                 AEAb2derx(1,lll,kkk,iii,1,1))
7262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7263                 AEAb1derx(1,lll,kkk,iii,2,1))
7264               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7265                 AEAb2derx(1,lll,kkk,iii,2,1))
7266               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7267               call matvec2(auxmat(1,1),b1(1,itl),&
7268                 AEAb1derx(1,lll,kkk,iii,1,2))
7269               call matvec2(auxmat(1,1),Ub2(1,l),&
7270                 AEAb2derx(1,lll,kkk,iii,1,2))
7271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
7272                 AEAb1derx(1,lll,kkk,iii,2,2))
7273               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
7274                 AEAb2derx(1,lll,kkk,iii,2,2))
7275             enddo
7276           enddo
7277         enddo
7278         ENDIF
7279 ! End vectors
7280       endif
7281       return
7282       end subroutine calc_eello
7283 !-----------------------------------------------------------------------------
7284       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
7285       use comm_kut
7286       implicit none
7287       integer :: nderg
7288       logical :: transp
7289       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
7290       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
7291       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
7292       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
7293       integer :: iii,kkk,lll
7294       integer :: jjj,mmm
7295 !el      logical :: lprn
7296 !el      common /kutas/ lprn
7297       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7298       do iii=1,nderg
7299         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
7300           AKAderg(1,1,iii))
7301       enddo
7302 !d      if (lprn) write (2,*) 'In kernel'
7303       do kkk=1,5
7304 !d        if (lprn) write (2,*) 'kkk=',kkk
7305         do lll=1,3
7306           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
7307             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7308 !d          if (lprn) then
7309 !d            write (2,*) 'lll=',lll
7310 !d            write (2,*) 'iii=1'
7311 !d            do jjj=1,2
7312 !d              write (2,'(3(2f10.5),5x)')
7313 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7314 !d            enddo
7315 !d          endif
7316           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
7317             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7318 !d          if (lprn) then
7319 !d            write (2,*) 'lll=',lll
7320 !d            write (2,*) 'iii=2'
7321 !d            do jjj=1,2
7322 !d              write (2,'(3(2f10.5),5x)')
7323 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7324 !d            enddo
7325 !d          endif
7326         enddo
7327       enddo
7328       return
7329       end subroutine kernel
7330 !-----------------------------------------------------------------------------
7331       real(kind=8) function eello4(i,j,k,l,jj,kk)
7332 !      implicit real*8 (a-h,o-z)
7333 !      include 'DIMENSIONS'
7334 !      include 'COMMON.IOUNITS'
7335 !      include 'COMMON.CHAIN'
7336 !      include 'COMMON.DERIV'
7337 !      include 'COMMON.INTERACT'
7338 !      include 'COMMON.CONTACTS'
7339 !      include 'COMMON.TORSION'
7340 !      include 'COMMON.VAR'
7341 !      include 'COMMON.GEO'
7342       real(kind=8),dimension(2,2) :: pizda
7343       real(kind=8),dimension(3) :: ggg1,ggg2
7344       real(kind=8) ::  eel4,glongij,glongkl
7345       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7346 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7347 !d        eello4=0.0d0
7348 !d        return
7349 !d      endif
7350 !d      print *,'eello4:',i,j,k,l,jj,kk
7351 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
7352 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
7353 !old      eij=facont_hb(jj,i)
7354 !old      ekl=facont_hb(kk,k)
7355 !old      ekont=eij*ekl
7356       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7357 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7358       gcorr_loc(k-1)=gcorr_loc(k-1) &
7359          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7360       if (l.eq.j+1) then
7361         gcorr_loc(l-1)=gcorr_loc(l-1) &
7362            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7363       else
7364         gcorr_loc(j-1)=gcorr_loc(j-1) &
7365            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7366       endif
7367       do iii=1,2
7368         do kkk=1,5
7369           do lll=1,3
7370             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
7371                               -EAEAderx(2,2,lll,kkk,iii,1)
7372 !d            derx(lll,kkk,iii)=0.0d0
7373           enddo
7374         enddo
7375       enddo
7376 !d      gcorr_loc(l-1)=0.0d0
7377 !d      gcorr_loc(j-1)=0.0d0
7378 !d      gcorr_loc(k-1)=0.0d0
7379 !d      eel4=1.0d0
7380 !d      write (iout,*)'Contacts have occurred for peptide groups',
7381 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7382 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7383       if (j.lt.nres-1) then
7384         j1=j+1
7385         j2=j-1
7386       else
7387         j1=j-1
7388         j2=j-2
7389       endif
7390       if (l.lt.nres-1) then
7391         l1=l+1
7392         l2=l-1
7393       else
7394         l1=l-1
7395         l2=l-2
7396       endif
7397       do ll=1,3
7398 !grad        ggg1(ll)=eel4*g_contij(ll,1)
7399 !grad        ggg2(ll)=eel4*g_contij(ll,2)
7400         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7401         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7402 !grad        ghalf=0.5d0*ggg1(ll)
7403         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7404         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7405         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7406         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7407         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7408         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7409 !grad        ghalf=0.5d0*ggg2(ll)
7410         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7411         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7412         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7413         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7414         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7415         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7416       enddo
7417 !grad      do m=i+1,j-1
7418 !grad        do ll=1,3
7419 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7420 !grad        enddo
7421 !grad      enddo
7422 !grad      do m=k+1,l-1
7423 !grad        do ll=1,3
7424 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7425 !grad        enddo
7426 !grad      enddo
7427 !grad      do m=i+2,j2
7428 !grad        do ll=1,3
7429 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7430 !grad        enddo
7431 !grad      enddo
7432 !grad      do m=k+2,l2
7433 !grad        do ll=1,3
7434 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7435 !grad        enddo
7436 !grad      enddo
7437 !d      do iii=1,nres-3
7438 !d        write (2,*) iii,gcorr_loc(iii)
7439 !d      enddo
7440       eello4=ekont*eel4
7441 !d      write (2,*) 'ekont',ekont
7442 !d      write (iout,*) 'eello4',ekont*eel4
7443       return
7444       end function eello4
7445 !-----------------------------------------------------------------------------
7446       real(kind=8) function eello5(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,auxmat,auxmat1
7458       real(kind=8),dimension(2) :: vv
7459       real(kind=8),dimension(3) :: ggg1,ggg2
7460       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
7461       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
7462       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
7463 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7464 !                                                                              C
7465 !                            Parallel chains                                   C
7466 !                                                                              C
7467 !          o             o                   o             o                   C
7468 !         /l\           / \             \   / \           / \   /              C
7469 !        /   \         /   \             \ /   \         /   \ /               C
7470 !       j| o |l1       | o |              o| o |         | o |o                C
7471 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7472 !      \i/   \         /   \ /             /   \         /   \                 C
7473 !       o    k1             o                                                  C
7474 !         (I)          (II)                (III)          (IV)                 C
7475 !                                                                              C
7476 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7477 !                                                                              C
7478 !                            Antiparallel chains                               C
7479 !                                                                              C
7480 !          o             o                   o             o                   C
7481 !         /j\           / \             \   / \           / \   /              C
7482 !        /   \         /   \             \ /   \         /   \ /               C
7483 !      j1| o |l        | o |              o| o |         | o |o                C
7484 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7485 !      \i/   \         /   \ /             /   \         /   \                 C
7486 !       o     k1            o                                                  C
7487 !         (I)          (II)                (III)          (IV)                 C
7488 !                                                                              C
7489 !      eello5_1        eello5_2            eello5_3       eello5_4             C
7490 !                                                                              C
7491 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
7492 !                                                                              C
7493 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7494 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7495 !d        eello5=0.0d0
7496 !d        return
7497 !d      endif
7498 !d      write (iout,*)
7499 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7500 !d     &   ' and',k,l
7501       itk=itortyp(itype(k))
7502       itl=itortyp(itype(l))
7503       itj=itortyp(itype(j))
7504       eello5_1=0.0d0
7505       eello5_2=0.0d0
7506       eello5_3=0.0d0
7507       eello5_4=0.0d0
7508 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7509 !d     &   eel5_3_num,eel5_4_num)
7510       do iii=1,2
7511         do kkk=1,5
7512           do lll=1,3
7513             derx(lll,kkk,iii)=0.0d0
7514           enddo
7515         enddo
7516       enddo
7517 !d      eij=facont_hb(jj,i)
7518 !d      ekl=facont_hb(kk,k)
7519 !d      ekont=eij*ekl
7520 !d      write (iout,*)'Contacts have occurred for peptide groups',
7521 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
7522 !d      goto 1111
7523 ! Contribution from the graph I.
7524 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7525 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7526       call transpose2(EUg(1,1,k),auxmat(1,1))
7527       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7528       vv(1)=pizda(1,1)-pizda(2,2)
7529       vv(2)=pizda(1,2)+pizda(2,1)
7530       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
7531        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7532 ! Explicit gradient in virtual-dihedral angles.
7533       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
7534        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
7535        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7536       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7537       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7538       vv(1)=pizda(1,1)-pizda(2,2)
7539       vv(2)=pizda(1,2)+pizda(2,1)
7540       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7541        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
7542        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7543       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7544       vv(1)=pizda(1,1)-pizda(2,2)
7545       vv(2)=pizda(1,2)+pizda(2,1)
7546       if (l.eq.j+1) then
7547         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7548          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7549          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7550       else
7551         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7552          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
7553          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7554       endif
7555 ! Cartesian gradient
7556       do iii=1,2
7557         do kkk=1,5
7558           do lll=1,3
7559             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
7560               pizda(1,1))
7561             vv(1)=pizda(1,1)-pizda(2,2)
7562             vv(2)=pizda(1,2)+pizda(2,1)
7563             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7564              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
7565              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7566           enddo
7567         enddo
7568       enddo
7569 !      goto 1112
7570 !1111  continue
7571 ! Contribution from graph II
7572       call transpose2(EE(1,1,itk),auxmat(1,1))
7573       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7574       vv(1)=pizda(1,1)+pizda(2,2)
7575       vv(2)=pizda(2,1)-pizda(1,2)
7576       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
7577        -0.5d0*scalar2(vv(1),Ctobr(1,k))
7578 ! Explicit gradient in virtual-dihedral angles.
7579       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7580        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7581       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7582       vv(1)=pizda(1,1)+pizda(2,2)
7583       vv(2)=pizda(2,1)-pizda(1,2)
7584       if (l.eq.j+1) then
7585         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7586          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7587          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7588       else
7589         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7590          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
7591          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7592       endif
7593 ! Cartesian gradient
7594       do iii=1,2
7595         do kkk=1,5
7596           do lll=1,3
7597             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7598               pizda(1,1))
7599             vv(1)=pizda(1,1)+pizda(2,2)
7600             vv(2)=pizda(2,1)-pizda(1,2)
7601             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7602              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
7603              -0.5d0*scalar2(vv(1),Ctobr(1,k))
7604           enddo
7605         enddo
7606       enddo
7607 !d      goto 1112
7608 !d1111  continue
7609       if (l.eq.j+1) then
7610 !d        goto 1110
7611 ! Parallel orientation
7612 ! Contribution from graph III
7613         call transpose2(EUg(1,1,l),auxmat(1,1))
7614         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7615         vv(1)=pizda(1,1)-pizda(2,2)
7616         vv(2)=pizda(1,2)+pizda(2,1)
7617         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
7618          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7619 ! Explicit gradient in virtual-dihedral angles.
7620         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7621          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
7622          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7623         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7624         vv(1)=pizda(1,1)-pizda(2,2)
7625         vv(2)=pizda(1,2)+pizda(2,1)
7626         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7627          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
7628          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7629         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7630         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7631         vv(1)=pizda(1,1)-pizda(2,2)
7632         vv(2)=pizda(1,2)+pizda(2,1)
7633         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7634          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
7635          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7636 ! Cartesian gradient
7637         do iii=1,2
7638           do kkk=1,5
7639             do lll=1,3
7640               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7641                 pizda(1,1))
7642               vv(1)=pizda(1,1)-pizda(2,2)
7643               vv(2)=pizda(1,2)+pizda(2,1)
7644               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7645                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
7646                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7647             enddo
7648           enddo
7649         enddo
7650 !d        goto 1112
7651 ! Contribution from graph IV
7652 !d1110    continue
7653         call transpose2(EE(1,1,itl),auxmat(1,1))
7654         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7655         vv(1)=pizda(1,1)+pizda(2,2)
7656         vv(2)=pizda(2,1)-pizda(1,2)
7657         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
7658          -0.5d0*scalar2(vv(1),Ctobr(1,l))
7659 ! Explicit gradient in virtual-dihedral angles.
7660         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7661          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7662         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7663         vv(1)=pizda(1,1)+pizda(2,2)
7664         vv(2)=pizda(2,1)-pizda(1,2)
7665         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7666          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
7667          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7668 ! Cartesian gradient
7669         do iii=1,2
7670           do kkk=1,5
7671             do lll=1,3
7672               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7673                 pizda(1,1))
7674               vv(1)=pizda(1,1)+pizda(2,2)
7675               vv(2)=pizda(2,1)-pizda(1,2)
7676               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
7677                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
7678                -0.5d0*scalar2(vv(1),Ctobr(1,l))
7679             enddo
7680           enddo
7681         enddo
7682       else
7683 ! Antiparallel orientation
7684 ! Contribution from graph III
7685 !        goto 1110
7686         call transpose2(EUg(1,1,j),auxmat(1,1))
7687         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7688         vv(1)=pizda(1,1)-pizda(2,2)
7689         vv(2)=pizda(1,2)+pizda(2,1)
7690         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
7691          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7692 ! Explicit gradient in virtual-dihedral angles.
7693         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
7694          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
7695          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7696         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7697         vv(1)=pizda(1,1)-pizda(2,2)
7698         vv(2)=pizda(1,2)+pizda(2,1)
7699         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7700          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
7701          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7702         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7703         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7704         vv(1)=pizda(1,1)-pizda(2,2)
7705         vv(2)=pizda(1,2)+pizda(2,1)
7706         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7707          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
7708          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7709 ! Cartesian gradient
7710         do iii=1,2
7711           do kkk=1,5
7712             do lll=1,3
7713               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
7714                 pizda(1,1))
7715               vv(1)=pizda(1,1)-pizda(2,2)
7716               vv(2)=pizda(1,2)+pizda(2,1)
7717               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7718                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
7719                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7720             enddo
7721           enddo
7722         enddo
7723 !d        goto 1112
7724 ! Contribution from graph IV
7725 1110    continue
7726         call transpose2(EE(1,1,itj),auxmat(1,1))
7727         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7728         vv(1)=pizda(1,1)+pizda(2,2)
7729         vv(2)=pizda(2,1)-pizda(1,2)
7730         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
7731          -0.5d0*scalar2(vv(1),Ctobr(1,j))
7732 ! Explicit gradient in virtual-dihedral angles.
7733         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
7734          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7735         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7736         vv(1)=pizda(1,1)+pizda(2,2)
7737         vv(2)=pizda(2,1)-pizda(1,2)
7738         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
7739          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
7740          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7741 ! Cartesian gradient
7742         do iii=1,2
7743           do kkk=1,5
7744             do lll=1,3
7745               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7746                 pizda(1,1))
7747               vv(1)=pizda(1,1)+pizda(2,2)
7748               vv(2)=pizda(2,1)-pizda(1,2)
7749               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
7750                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
7751                -0.5d0*scalar2(vv(1),Ctobr(1,j))
7752             enddo
7753           enddo
7754         enddo
7755       endif
7756 1112  continue
7757       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7758 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7759 !d        write (2,*) 'ijkl',i,j,k,l
7760 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7761 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7762 !d      endif
7763 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7764 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7765 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7766 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7767       if (j.lt.nres-1) then
7768         j1=j+1
7769         j2=j-1
7770       else
7771         j1=j-1
7772         j2=j-2
7773       endif
7774       if (l.lt.nres-1) then
7775         l1=l+1
7776         l2=l-1
7777       else
7778         l1=l-1
7779         l2=l-2
7780       endif
7781 !d      eij=1.0d0
7782 !d      ekl=1.0d0
7783 !d      ekont=1.0d0
7784 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7785 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
7786 !        summed up outside the subrouine as for the other subroutines
7787 !        handling long-range interactions. The old code is commented out
7788 !        with "cgrad" to keep track of changes.
7789       do ll=1,3
7790 !grad        ggg1(ll)=eel5*g_contij(ll,1)
7791 !grad        ggg2(ll)=eel5*g_contij(ll,2)
7792         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7793         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7794 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7795 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7796 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7797 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7798 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7799 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7800 !     &   gradcorr5ij,
7801 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7802 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7803 !grad        ghalf=0.5d0*ggg1(ll)
7804 !d        ghalf=0.0d0
7805         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7806         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7807         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7808         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7809         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7810         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7811 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7812 !grad        ghalf=0.5d0*ggg2(ll)
7813         ghalf=0.0d0
7814         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7815         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7816         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7817         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7818         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7819         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7820       enddo
7821 !d      goto 1112
7822 !grad      do m=i+1,j-1
7823 !grad        do ll=1,3
7824 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7825 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7826 !grad        enddo
7827 !grad      enddo
7828 !grad      do m=k+1,l-1
7829 !grad        do ll=1,3
7830 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7831 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7832 !grad        enddo
7833 !grad      enddo
7834 !1112  continue
7835 !grad      do m=i+2,j2
7836 !grad        do ll=1,3
7837 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7838 !grad        enddo
7839 !grad      enddo
7840 !grad      do m=k+2,l2
7841 !grad        do ll=1,3
7842 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7843 !grad        enddo
7844 !grad      enddo
7845 !d      do iii=1,nres-3
7846 !d        write (2,*) iii,g_corr5_loc(iii)
7847 !d      enddo
7848       eello5=ekont*eel5
7849 !d      write (2,*) 'ekont',ekont
7850 !d      write (iout,*) 'eello5',ekont*eel5
7851       return
7852       end function eello5
7853 !-----------------------------------------------------------------------------
7854       real(kind=8) function eello6(i,j,k,l,jj,kk)
7855 !      implicit real*8 (a-h,o-z)
7856 !      include 'DIMENSIONS'
7857 !      include 'COMMON.IOUNITS'
7858 !      include 'COMMON.CHAIN'
7859 !      include 'COMMON.DERIV'
7860 !      include 'COMMON.INTERACT'
7861 !      include 'COMMON.CONTACTS'
7862 !      include 'COMMON.TORSION'
7863 !      include 'COMMON.VAR'
7864 !      include 'COMMON.GEO'
7865 !      include 'COMMON.FFIELD'
7866       real(kind=8),dimension(3) :: ggg1,ggg2
7867       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
7868                    eello6_6,eel6
7869       real(kind=8) :: gradcorr6ij,gradcorr6kl
7870       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
7871 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7872 !d        eello6=0.0d0
7873 !d        return
7874 !d      endif
7875 !d      write (iout,*)
7876 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7877 !d     &   ' and',k,l
7878       eello6_1=0.0d0
7879       eello6_2=0.0d0
7880       eello6_3=0.0d0
7881       eello6_4=0.0d0
7882       eello6_5=0.0d0
7883       eello6_6=0.0d0
7884 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7885 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7886       do iii=1,2
7887         do kkk=1,5
7888           do lll=1,3
7889             derx(lll,kkk,iii)=0.0d0
7890           enddo
7891         enddo
7892       enddo
7893 !d      eij=facont_hb(jj,i)
7894 !d      ekl=facont_hb(kk,k)
7895 !d      ekont=eij*ekl
7896 !d      eij=1.0d0
7897 !d      ekl=1.0d0
7898 !d      ekont=1.0d0
7899       if (l.eq.j+1) then
7900         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7901         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7902         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7903         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7904         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7905         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7906       else
7907         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7908         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7909         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7910         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7911         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7912           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7913         else
7914           eello6_5=0.0d0
7915         endif
7916         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7917       endif
7918 ! If turn contributions are considered, they will be handled separately.
7919       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7920 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7921 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7922 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7923 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7924 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7925 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7926 !d      goto 1112
7927       if (j.lt.nres-1) then
7928         j1=j+1
7929         j2=j-1
7930       else
7931         j1=j-1
7932         j2=j-2
7933       endif
7934       if (l.lt.nres-1) then
7935         l1=l+1
7936         l2=l-1
7937       else
7938         l1=l-1
7939         l2=l-2
7940       endif
7941       do ll=1,3
7942 !grad        ggg1(ll)=eel6*g_contij(ll,1)
7943 !grad        ggg2(ll)=eel6*g_contij(ll,2)
7944 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7945 !grad        ghalf=0.5d0*ggg1(ll)
7946 !d        ghalf=0.0d0
7947         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7948         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7949         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7950         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7951         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7952         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7953         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7954         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7955 !grad        ghalf=0.5d0*ggg2(ll)
7956 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7957 !d        ghalf=0.0d0
7958         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7959         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7960         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7961         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7962         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7963         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7964       enddo
7965 !d      goto 1112
7966 !grad      do m=i+1,j-1
7967 !grad        do ll=1,3
7968 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7969 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7970 !grad        enddo
7971 !grad      enddo
7972 !grad      do m=k+1,l-1
7973 !grad        do ll=1,3
7974 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7975 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7976 !grad        enddo
7977 !grad      enddo
7978 !grad1112  continue
7979 !grad      do m=i+2,j2
7980 !grad        do ll=1,3
7981 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7982 !grad        enddo
7983 !grad      enddo
7984 !grad      do m=k+2,l2
7985 !grad        do ll=1,3
7986 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7987 !grad        enddo
7988 !grad      enddo
7989 !d      do iii=1,nres-3
7990 !d        write (2,*) iii,g_corr6_loc(iii)
7991 !d      enddo
7992       eello6=ekont*eel6
7993 !d      write (2,*) 'ekont',ekont
7994 !d      write (iout,*) 'eello6',ekont*eel6
7995       return
7996       end function eello6
7997 !-----------------------------------------------------------------------------
7998       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
7999       use comm_kut
8000 !      implicit real*8 (a-h,o-z)
8001 !      include 'DIMENSIONS'
8002 !      include 'COMMON.IOUNITS'
8003 !      include 'COMMON.CHAIN'
8004 !      include 'COMMON.DERIV'
8005 !      include 'COMMON.INTERACT'
8006 !      include 'COMMON.CONTACTS'
8007 !      include 'COMMON.TORSION'
8008 !      include 'COMMON.VAR'
8009 !      include 'COMMON.GEO'
8010       real(kind=8),dimension(2) :: vv,vv1
8011       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8012       logical :: swap
8013 !el      logical :: lprn
8014 !el      common /kutas/ lprn
8015       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8016       real(kind=8) :: s1,s2,s3,s4,s5
8017 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8018 !                                                                              C
8019 !      Parallel       Antiparallel                                             C
8020 !                                                                              C
8021 !          o             o                                                     C
8022 !         /l\           /j\                                                    C
8023 !        /   \         /   \                                                   C
8024 !       /| o |         | o |\                                                  C
8025 !     \ j|/k\|  /   \  |/k\|l /                                                C
8026 !      \ /   \ /     \ /   \ /                                                 C
8027 !       o     o       o     o                                                  C
8028 !       i             i                                                        C
8029 !                                                                              C
8030 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8031       itk=itortyp(itype(k))
8032       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8033       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8034       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8035       call transpose2(EUgC(1,1,k),auxmat(1,1))
8036       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8037       vv1(1)=pizda1(1,1)-pizda1(2,2)
8038       vv1(2)=pizda1(1,2)+pizda1(2,1)
8039       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8040       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8041       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8042       s5=scalar2(vv(1),Dtobr2(1,i))
8043 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8044       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8045       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8046        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8047        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8048        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8049        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8050        +scalar2(vv(1),Dtobr2der(1,i)))
8051       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8052       vv1(1)=pizda1(1,1)-pizda1(2,2)
8053       vv1(2)=pizda1(1,2)+pizda1(2,1)
8054       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8055       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8056       if (l.eq.j+1) then
8057         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8058        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8059        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8060        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8061        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8062       else
8063         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8064        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8065        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8066        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8067        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8068       endif
8069       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8071       vv1(1)=pizda1(1,1)-pizda1(2,2)
8072       vv1(2)=pizda1(1,2)+pizda1(2,1)
8073       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8074        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8075        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8076        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8077       do iii=1,2
8078         if (swap) then
8079           ind=3-iii
8080         else
8081           ind=iii
8082         endif
8083         do kkk=1,5
8084           do lll=1,3
8085             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8086             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8087             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8088             call transpose2(EUgC(1,1,k),auxmat(1,1))
8089             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8090               pizda1(1,1))
8091             vv1(1)=pizda1(1,1)-pizda1(2,2)
8092             vv1(2)=pizda1(1,2)+pizda1(2,1)
8093             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8094             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8095              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8096             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8097              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8098             s5=scalar2(vv(1),Dtobr2(1,i))
8099             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8100           enddo
8101         enddo
8102       enddo
8103       return
8104       end function eello6_graph1
8105 !-----------------------------------------------------------------------------
8106       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8107       use comm_kut
8108 !      implicit real*8 (a-h,o-z)
8109 !      include 'DIMENSIONS'
8110 !      include 'COMMON.IOUNITS'
8111 !      include 'COMMON.CHAIN'
8112 !      include 'COMMON.DERIV'
8113 !      include 'COMMON.INTERACT'
8114 !      include 'COMMON.CONTACTS'
8115 !      include 'COMMON.TORSION'
8116 !      include 'COMMON.VAR'
8117 !      include 'COMMON.GEO'
8118       logical :: swap
8119       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8120       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8121 !el      logical :: lprn
8122 !el      common /kutas/ lprn
8123       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8124       real(kind=8) :: s2,s3,s4
8125 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8126 !                                                                              C
8127 !      Parallel       Antiparallel                                             C
8128 !                                                                              C
8129 !          o             o                                                     C
8130 !     \   /l\           /j\   /                                                C
8131 !      \ /   \         /   \ /                                                 C
8132 !       o| o |         | o |o                                                  C
8133 !     \ j|/k\|      \  |/k\|l                                                  C
8134 !      \ /   \       \ /   \                                                   C
8135 !       o             o                                                        C
8136 !       i             i                                                        C
8137 !                                                                              C
8138 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8139 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8140 ! AL 7/4/01 s1 would occur in the sixth-order moment,
8141 !           but not in a cluster cumulant
8142 #ifdef MOMENT
8143       s1=dip(1,jj,i)*dip(1,kk,k)
8144 #endif
8145       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8146       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8147       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8148       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8149       call transpose2(EUg(1,1,k),auxmat(1,1))
8150       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8151       vv(1)=pizda(1,1)-pizda(2,2)
8152       vv(2)=pizda(1,2)+pizda(2,1)
8153       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8154 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8155 #ifdef MOMENT
8156       eello6_graph2=-(s1+s2+s3+s4)
8157 #else
8158       eello6_graph2=-(s2+s3+s4)
8159 #endif
8160 !      eello6_graph2=-s3
8161 ! Derivatives in gamma(i-1)
8162       if (i.gt.1) then
8163 #ifdef MOMENT
8164         s1=dipderg(1,jj,i)*dip(1,kk,k)
8165 #endif
8166         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8167         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8168         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8169         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8170 #ifdef MOMENT
8171         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8172 #else
8173         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8174 #endif
8175 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8176       endif
8177 ! Derivatives in gamma(k-1)
8178 #ifdef MOMENT
8179       s1=dip(1,jj,i)*dipderg(1,kk,k)
8180 #endif
8181       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8182       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8183       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8184       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8185       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8186       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8187       vv(1)=pizda(1,1)-pizda(2,2)
8188       vv(2)=pizda(1,2)+pizda(2,1)
8189       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8190 #ifdef MOMENT
8191       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8192 #else
8193       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8194 #endif
8195 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8196 ! Derivatives in gamma(j-1) or gamma(l-1)
8197       if (j.gt.1) then
8198 #ifdef MOMENT
8199         s1=dipderg(3,jj,i)*dip(1,kk,k)
8200 #endif
8201         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8202         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8203         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8204         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8205         vv(1)=pizda(1,1)-pizda(2,2)
8206         vv(2)=pizda(1,2)+pizda(2,1)
8207         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8208 #ifdef MOMENT
8209         if (swap) then
8210           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8211         else
8212           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8213         endif
8214 #endif
8215         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8216 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8217       endif
8218 ! Derivatives in gamma(l-1) or gamma(j-1)
8219       if (l.gt.1) then
8220 #ifdef MOMENT
8221         s1=dip(1,jj,i)*dipderg(3,kk,k)
8222 #endif
8223         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8224         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8225         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8226         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8227         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8228         vv(1)=pizda(1,1)-pizda(2,2)
8229         vv(2)=pizda(1,2)+pizda(2,1)
8230         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8231 #ifdef MOMENT
8232         if (swap) then
8233           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8234         else
8235           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8236         endif
8237 #endif
8238         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8239 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8240       endif
8241 ! Cartesian derivatives.
8242       if (lprn) then
8243         write (2,*) 'In eello6_graph2'
8244         do iii=1,2
8245           write (2,*) 'iii=',iii
8246           do kkk=1,5
8247             write (2,*) 'kkk=',kkk
8248             do jjj=1,2
8249               write (2,'(3(2f10.5),5x)') &
8250               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8251             enddo
8252           enddo
8253         enddo
8254       endif
8255       do iii=1,2
8256         do kkk=1,5
8257           do lll=1,3
8258 #ifdef MOMENT
8259             if (iii.eq.1) then
8260               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8261             else
8262               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8263             endif
8264 #endif
8265             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
8266               auxvec(1))
8267             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8268             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
8269               auxvec(1))
8270             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8271             call transpose2(EUg(1,1,k),auxmat(1,1))
8272             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8273               pizda(1,1))
8274             vv(1)=pizda(1,1)-pizda(2,2)
8275             vv(2)=pizda(1,2)+pizda(2,1)
8276             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8277 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8278 #ifdef MOMENT
8279             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8280 #else
8281             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8282 #endif
8283             if (swap) then
8284               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8285             else
8286               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8287             endif
8288           enddo
8289         enddo
8290       enddo
8291       return
8292       end function eello6_graph2
8293 !-----------------------------------------------------------------------------
8294       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
8295 !      implicit real*8 (a-h,o-z)
8296 !      include 'DIMENSIONS'
8297 !      include 'COMMON.IOUNITS'
8298 !      include 'COMMON.CHAIN'
8299 !      include 'COMMON.DERIV'
8300 !      include 'COMMON.INTERACT'
8301 !      include 'COMMON.CONTACTS'
8302 !      include 'COMMON.TORSION'
8303 !      include 'COMMON.VAR'
8304 !      include 'COMMON.GEO'
8305       real(kind=8),dimension(2) :: vv,auxvec
8306       real(kind=8),dimension(2,2) :: pizda,auxmat
8307       logical :: swap
8308       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
8309       real(kind=8) :: s1,s2,s3,s4
8310 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8311 !                                                                              C
8312 !      Parallel       Antiparallel                                             C
8313 !                                                                              C
8314 !          o             o                                                     C
8315 !         /l\   /   \   /j\                                                    C
8316 !        /   \ /     \ /   \                                                   C
8317 !       /| o |o       o| o |\                                                  C
8318 !       j|/k\|  /      |/k\|l /                                                C
8319 !        /   \ /       /   \ /                                                 C
8320 !       /     o       /     o                                                  C
8321 !       i             i                                                        C
8322 !                                                                              C
8323 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8324 !
8325 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8326 !           energy moment and not to the cluster cumulant.
8327       iti=itortyp(itype(i))
8328       if (j.lt.nres-1) then
8329         itj1=itortyp(itype(j+1))
8330       else
8331         itj1=ntortyp+1
8332       endif
8333       itk=itortyp(itype(k))
8334       itk1=itortyp(itype(k+1))
8335       if (l.lt.nres-1) then
8336         itl1=itortyp(itype(l+1))
8337       else
8338         itl1=ntortyp+1
8339       endif
8340 #ifdef MOMENT
8341       s1=dip(4,jj,i)*dip(4,kk,k)
8342 #endif
8343       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8344       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8345       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8346       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8347       call transpose2(EE(1,1,itk),auxmat(1,1))
8348       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8349       vv(1)=pizda(1,1)+pizda(2,2)
8350       vv(2)=pizda(2,1)-pizda(1,2)
8351       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8352 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8353 !d     & "sum",-(s2+s3+s4)
8354 #ifdef MOMENT
8355       eello6_graph3=-(s1+s2+s3+s4)
8356 #else
8357       eello6_graph3=-(s2+s3+s4)
8358 #endif
8359 !      eello6_graph3=-s4
8360 ! Derivatives in gamma(k-1)
8361       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8362       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8363       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8364       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8365 ! Derivatives in gamma(l-1)
8366       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8367       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8368       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8369       vv(1)=pizda(1,1)+pizda(2,2)
8370       vv(2)=pizda(2,1)-pizda(1,2)
8371       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8372       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8373 ! Cartesian derivatives.
8374       do iii=1,2
8375         do kkk=1,5
8376           do lll=1,3
8377 #ifdef MOMENT
8378             if (iii.eq.1) then
8379               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8380             else
8381               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8382             endif
8383 #endif
8384             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8385               auxvec(1))
8386             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8387             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8388               auxvec(1))
8389             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8390             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
8391               pizda(1,1))
8392             vv(1)=pizda(1,1)+pizda(2,2)
8393             vv(2)=pizda(2,1)-pizda(1,2)
8394             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8395 #ifdef MOMENT
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8397 #else
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8399 #endif
8400             if (swap) then
8401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8402             else
8403               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8404             endif
8405 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8406           enddo
8407         enddo
8408       enddo
8409       return
8410       end function eello6_graph3
8411 !-----------------------------------------------------------------------------
8412       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8413 !      implicit real*8 (a-h,o-z)
8414 !      include 'DIMENSIONS'
8415 !      include 'COMMON.IOUNITS'
8416 !      include 'COMMON.CHAIN'
8417 !      include 'COMMON.DERIV'
8418 !      include 'COMMON.INTERACT'
8419 !      include 'COMMON.CONTACTS'
8420 !      include 'COMMON.TORSION'
8421 !      include 'COMMON.VAR'
8422 !      include 'COMMON.GEO'
8423 !      include 'COMMON.FFIELD'
8424       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
8425       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8426       logical :: swap
8427       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
8428               iii,kkk,lll
8429       real(kind=8) :: s1,s2,s3,s4
8430 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8431 !                                                                              C
8432 !      Parallel       Antiparallel                                             C
8433 !                                                                              C
8434 !          o             o                                                     C
8435 !         /l\   /   \   /j\                                                    C
8436 !        /   \ /     \ /   \                                                   C
8437 !       /| o |o       o| o |\                                                  C
8438 !     \ j|/k\|      \  |/k\|l                                                  C
8439 !      \ /   \       \ /   \                                                   C
8440 !       o     \       o     \                                                  C
8441 !       i             i                                                        C
8442 !                                                                              C
8443 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8444 !
8445 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
8446 !           energy moment and not to the cluster cumulant.
8447 !d      write (2,*) 'eello_graph4: wturn6',wturn6
8448       iti=itortyp(itype(i))
8449       itj=itortyp(itype(j))
8450       if (j.lt.nres-1) then
8451         itj1=itortyp(itype(j+1))
8452       else
8453         itj1=ntortyp+1
8454       endif
8455       itk=itortyp(itype(k))
8456       if (k.lt.nres-1) then
8457         itk1=itortyp(itype(k+1))
8458       else
8459         itk1=ntortyp+1
8460       endif
8461       itl=itortyp(itype(l))
8462       if (l.lt.nres-1) then
8463         itl1=itortyp(itype(l+1))
8464       else
8465         itl1=ntortyp+1
8466       endif
8467 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8468 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8469 !d     & ' itl',itl,' itl1',itl1
8470 #ifdef MOMENT
8471       if (imat.eq.1) then
8472         s1=dip(3,jj,i)*dip(3,kk,k)
8473       else
8474         s1=dip(2,jj,j)*dip(2,kk,l)
8475       endif
8476 #endif
8477       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8478       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8479       if (j.eq.l+1) then
8480         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8481         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8482       else
8483         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8484         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8485       endif
8486       call transpose2(EUg(1,1,k),auxmat(1,1))
8487       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8488       vv(1)=pizda(1,1)-pizda(2,2)
8489       vv(2)=pizda(2,1)+pizda(1,2)
8490       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8491 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8492 #ifdef MOMENT
8493       eello6_graph4=-(s1+s2+s3+s4)
8494 #else
8495       eello6_graph4=-(s2+s3+s4)
8496 #endif
8497 ! Derivatives in gamma(i-1)
8498       if (i.gt.1) then
8499 #ifdef MOMENT
8500         if (imat.eq.1) then
8501           s1=dipderg(2,jj,i)*dip(3,kk,k)
8502         else
8503           s1=dipderg(4,jj,j)*dip(2,kk,l)
8504         endif
8505 #endif
8506         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8507         if (j.eq.l+1) then
8508           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8509           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8510         else
8511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8512           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8513         endif
8514         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8515         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8516 !d          write (2,*) 'turn6 derivatives'
8517 #ifdef MOMENT
8518           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8519 #else
8520           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8521 #endif
8522         else
8523 #ifdef MOMENT
8524           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8525 #else
8526           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8527 #endif
8528         endif
8529       endif
8530 ! Derivatives in gamma(k-1)
8531 #ifdef MOMENT
8532       if (imat.eq.1) then
8533         s1=dip(3,jj,i)*dipderg(2,kk,k)
8534       else
8535         s1=dip(2,jj,j)*dipderg(4,kk,l)
8536       endif
8537 #endif
8538       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8539       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8540       if (j.eq.l+1) then
8541         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8542         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8543       else
8544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8545         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8546       endif
8547       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8548       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8549       vv(1)=pizda(1,1)-pizda(2,2)
8550       vv(2)=pizda(2,1)+pizda(1,2)
8551       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8552       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8553 #ifdef MOMENT
8554         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8555 #else
8556         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8557 #endif
8558       else
8559 #ifdef MOMENT
8560         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8561 #else
8562         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8563 #endif
8564       endif
8565 ! Derivatives in gamma(j-1) or gamma(l-1)
8566       if (l.eq.j+1 .and. l.gt.1) then
8567         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8568         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8569         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8570         vv(1)=pizda(1,1)-pizda(2,2)
8571         vv(2)=pizda(2,1)+pizda(1,2)
8572         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8573         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8574       else if (j.gt.1) then
8575         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8576         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8577         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8578         vv(1)=pizda(1,1)-pizda(2,2)
8579         vv(2)=pizda(2,1)+pizda(1,2)
8580         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8581         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8582           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8583         else
8584           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8585         endif
8586       endif
8587 ! Cartesian derivatives.
8588       do iii=1,2
8589         do kkk=1,5
8590           do lll=1,3
8591 #ifdef MOMENT
8592             if (iii.eq.1) then
8593               if (imat.eq.1) then
8594                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8595               else
8596                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8597               endif
8598             else
8599               if (imat.eq.1) then
8600                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8601               else
8602                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8603               endif
8604             endif
8605 #endif
8606             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
8607               auxvec(1))
8608             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8609             if (j.eq.l+1) then
8610               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8611                 b1(1,itj1),auxvec(1))
8612               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8613             else
8614               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
8615                 b1(1,itl1),auxvec(1))
8616               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8617             endif
8618             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8619               pizda(1,1))
8620             vv(1)=pizda(1,1)-pizda(2,2)
8621             vv(2)=pizda(2,1)+pizda(1,2)
8622             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8623             if (swap) then
8624               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8625 #ifdef MOMENT
8626                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8627                    -(s1+s2+s4)
8628 #else
8629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
8630                    -(s2+s4)
8631 #endif
8632                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8633               else
8634 #ifdef MOMENT
8635                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8636 #else
8637                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8638 #endif
8639                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8640               endif
8641             else
8642 #ifdef MOMENT
8643               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8644 #else
8645               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8646 #endif
8647               if (l.eq.j+1) then
8648                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8649               else
8650                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8651               endif
8652             endif
8653           enddo
8654         enddo
8655       enddo
8656       return
8657       end function eello6_graph4
8658 !-----------------------------------------------------------------------------
8659       real(kind=8) function eello_turn6(i,jj,kk)
8660 !      implicit real*8 (a-h,o-z)
8661 !      include 'DIMENSIONS'
8662 !      include 'COMMON.IOUNITS'
8663 !      include 'COMMON.CHAIN'
8664 !      include 'COMMON.DERIV'
8665 !      include 'COMMON.INTERACT'
8666 !      include 'COMMON.CONTACTS'
8667 !      include 'COMMON.TORSION'
8668 !      include 'COMMON.VAR'
8669 !      include 'COMMON.GEO'
8670       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
8671       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
8672       real(kind=8),dimension(3) :: ggg1,ggg2
8673       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
8674       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
8675 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8676 !           the respective energy moment and not to the cluster cumulant.
8677 !el local variables
8678       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
8679       integer :: j1,j2,l1,l2,ll
8680       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
8681       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
8682       s1=0.0d0
8683       s8=0.0d0
8684       s13=0.0d0
8685 !
8686       eello_turn6=0.0d0
8687       j=i+4
8688       k=i+1
8689       l=i+3
8690       iti=itortyp(itype(i))
8691       itk=itortyp(itype(k))
8692       itk1=itortyp(itype(k+1))
8693       itl=itortyp(itype(l))
8694       itj=itortyp(itype(j))
8695 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8696 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
8697 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8698 !d        eello6=0.0d0
8699 !d        return
8700 !d      endif
8701 !d      write (iout,*)
8702 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8703 !d     &   ' and',k,l
8704 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
8705       do iii=1,2
8706         do kkk=1,5
8707           do lll=1,3
8708             derx_turn(lll,kkk,iii)=0.0d0
8709           enddo
8710         enddo
8711       enddo
8712 !d      eij=1.0d0
8713 !d      ekl=1.0d0
8714 !d      ekont=1.0d0
8715       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8716 !d      eello6_5=0.0d0
8717 !d      write (2,*) 'eello6_5',eello6_5
8718 #ifdef MOMENT
8719       call transpose2(AEA(1,1,1),auxmat(1,1))
8720       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8721       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8722       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8723 #endif
8724       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8725       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8726       s2 = scalar2(b1(1,itk),vtemp1(1))
8727 #ifdef MOMENT
8728       call transpose2(AEA(1,1,2),atemp(1,1))
8729       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8730       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8731       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8732 #endif
8733       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8734       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8735       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8736 #ifdef MOMENT
8737       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8738       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8739       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8740       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8741       ss13 = scalar2(b1(1,itk),vtemp4(1))
8742       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8743 #endif
8744 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8745 !      s1=0.0d0
8746 !      s2=0.0d0
8747 !      s8=0.0d0
8748 !      s12=0.0d0
8749 !      s13=0.0d0
8750       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8751 ! Derivatives in gamma(i+2)
8752       s1d =0.0d0
8753       s8d =0.0d0
8754 #ifdef MOMENT
8755       call transpose2(AEA(1,1,1),auxmatd(1,1))
8756       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8757       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8758       call transpose2(AEAderg(1,1,2),atempd(1,1))
8759       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8760       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8761 #endif
8762       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8763       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8764       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8765 !      s1d=0.0d0
8766 !      s2d=0.0d0
8767 !      s8d=0.0d0
8768 !      s12d=0.0d0
8769 !      s13d=0.0d0
8770       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8771 ! Derivatives in gamma(i+3)
8772 #ifdef MOMENT
8773       call transpose2(AEA(1,1,1),auxmatd(1,1))
8774       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8775       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8776       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8777 #endif
8778       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8779       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8780       s2d = scalar2(b1(1,itk),vtemp1d(1))
8781 #ifdef MOMENT
8782       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8783       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8784 #endif
8785       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8786 #ifdef MOMENT
8787       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8788       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8789       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8790 #endif
8791 !      s1d=0.0d0
8792 !      s2d=0.0d0
8793 !      s8d=0.0d0
8794 !      s12d=0.0d0
8795 !      s13d=0.0d0
8796 #ifdef MOMENT
8797       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8798                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8799 #else
8800       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
8801                     -0.5d0*ekont*(s2d+s12d)
8802 #endif
8803 ! Derivatives in gamma(i+4)
8804       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8805       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8806       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8807 #ifdef MOMENT
8808       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8809       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8810       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8811 #endif
8812 !      s1d=0.0d0
8813 !      s2d=0.0d0
8814 !      s8d=0.0d0
8815 !      s12d=0.0d0
8816 !      s13d=0.0d0
8817 #ifdef MOMENT
8818       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8819 #else
8820       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8821 #endif
8822 ! Derivatives in gamma(i+5)
8823 #ifdef MOMENT
8824       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8825       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8826       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8827 #endif
8828       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8829       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8830       s2d = scalar2(b1(1,itk),vtemp1d(1))
8831 #ifdef MOMENT
8832       call transpose2(AEA(1,1,2),atempd(1,1))
8833       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8834       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8835 #endif
8836       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8837       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8838 #ifdef MOMENT
8839       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8840       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8841       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8842 #endif
8843 !      s1d=0.0d0
8844 !      s2d=0.0d0
8845 !      s8d=0.0d0
8846 !      s12d=0.0d0
8847 !      s13d=0.0d0
8848 #ifdef MOMENT
8849       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8850                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8851 #else
8852       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
8853                     -0.5d0*ekont*(s2d+s12d)
8854 #endif
8855 ! Cartesian derivatives
8856       do iii=1,2
8857         do kkk=1,5
8858           do lll=1,3
8859 #ifdef MOMENT
8860             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8861             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8862             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8863 #endif
8864             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8865             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
8866                 vtemp1d(1))
8867             s2d = scalar2(b1(1,itk),vtemp1d(1))
8868 #ifdef MOMENT
8869             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8870             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8871             s8d = -(atempd(1,1)+atempd(2,2))* &
8872                  scalar2(cc(1,1,itl),vtemp2(1))
8873 #endif
8874             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
8875                  auxmatd(1,1))
8876             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8877             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8878 !      s1d=0.0d0
8879 !      s2d=0.0d0
8880 !      s8d=0.0d0
8881 !      s12d=0.0d0
8882 !      s13d=0.0d0
8883 #ifdef MOMENT
8884             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8885               - 0.5d0*(s1d+s2d)
8886 #else
8887             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
8888               - 0.5d0*s2d
8889 #endif
8890 #ifdef MOMENT
8891             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8892               - 0.5d0*(s8d+s12d)
8893 #else
8894             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
8895               - 0.5d0*s12d
8896 #endif
8897           enddo
8898         enddo
8899       enddo
8900 #ifdef MOMENT
8901       do kkk=1,5
8902         do lll=1,3
8903           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
8904             achuj_tempd(1,1))
8905           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8906           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8907           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8908           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8909           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
8910             vtemp4d(1))
8911           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8912           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8913           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8914         enddo
8915       enddo
8916 #endif
8917 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8918 !d     &  16*eel_turn6_num
8919 !d      goto 1112
8920       if (j.lt.nres-1) then
8921         j1=j+1
8922         j2=j-1
8923       else
8924         j1=j-1
8925         j2=j-2
8926       endif
8927       if (l.lt.nres-1) then
8928         l1=l+1
8929         l2=l-1
8930       else
8931         l1=l-1
8932         l2=l-2
8933       endif
8934       do ll=1,3
8935 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8936 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8937 !grad        ghalf=0.5d0*ggg1(ll)
8938 !d        ghalf=0.0d0
8939         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8940         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8941         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
8942           +ekont*derx_turn(ll,2,1)
8943         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8944         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
8945           +ekont*derx_turn(ll,4,1)
8946         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8947         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8948         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8949 !grad        ghalf=0.5d0*ggg2(ll)
8950 !d        ghalf=0.0d0
8951         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
8952           +ekont*derx_turn(ll,2,2)
8953         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8954         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
8955           +ekont*derx_turn(ll,4,2)
8956         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8957         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8958         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8959       enddo
8960 !d      goto 1112
8961 !grad      do m=i+1,j-1
8962 !grad        do ll=1,3
8963 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8964 !grad        enddo
8965 !grad      enddo
8966 !grad      do m=k+1,l-1
8967 !grad        do ll=1,3
8968 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8969 !grad        enddo
8970 !grad      enddo
8971 !grad1112  continue
8972 !grad      do m=i+2,j2
8973 !grad        do ll=1,3
8974 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8975 !grad        enddo
8976 !grad      enddo
8977 !grad      do m=k+2,l2
8978 !grad        do ll=1,3
8979 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8980 !grad        enddo
8981 !grad      enddo
8982 !d      do iii=1,nres-3
8983 !d        write (2,*) iii,g_corr6_loc(iii)
8984 !d      enddo
8985       eello_turn6=ekont*eel_turn6
8986 !d      write (2,*) 'ekont',ekont
8987 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
8988       return
8989       end function eello_turn6
8990 !-----------------------------------------------------------------------------
8991       subroutine MATVEC2(A1,V1,V2)
8992 !DIR$ INLINEALWAYS MATVEC2
8993 #ifndef OSF
8994 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8995 #endif
8996 !      implicit real*8 (a-h,o-z)
8997 !      include 'DIMENSIONS'
8998       real(kind=8),dimension(2) :: V1,V2
8999       real(kind=8),dimension(2,2) :: A1
9000       real(kind=8) :: vaux1,vaux2
9001 !      DO 1 I=1,2
9002 !        VI=0.0
9003 !        DO 3 K=1,2
9004 !    3     VI=VI+A1(I,K)*V1(K)
9005 !        Vaux(I)=VI
9006 !    1 CONTINUE
9007
9008       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9009       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9010
9011       v2(1)=vaux1
9012       v2(2)=vaux2
9013       end subroutine MATVEC2
9014 !-----------------------------------------------------------------------------
9015       subroutine MATMAT2(A1,A2,A3)
9016 #ifndef OSF
9017 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9018 #endif
9019 !      implicit real*8 (a-h,o-z)
9020 !      include 'DIMENSIONS'
9021       real(kind=8),dimension(2,2) :: A1,A2,A3
9022       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9023 !      DIMENSION AI3(2,2)
9024 !        DO  J=1,2
9025 !          A3IJ=0.0
9026 !          DO K=1,2
9027 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9028 !          enddo
9029 !          A3(I,J)=A3IJ
9030 !       enddo
9031 !      enddo
9032
9033       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9034       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9035       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9036       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9037
9038       A3(1,1)=AI3_11
9039       A3(2,1)=AI3_21
9040       A3(1,2)=AI3_12
9041       A3(2,2)=AI3_22
9042       end subroutine MATMAT2
9043 !-----------------------------------------------------------------------------
9044       real(kind=8) function scalar2(u,v)
9045 !DIR$ INLINEALWAYS scalar2
9046       implicit none
9047       real(kind=8),dimension(2) :: u,v
9048       real(kind=8) :: sc
9049       integer :: i
9050       scalar2=u(1)*v(1)+u(2)*v(2)
9051       return
9052       end function scalar2
9053 !-----------------------------------------------------------------------------
9054       subroutine transpose2(a,at)
9055 !DIR$ INLINEALWAYS transpose2
9056 #ifndef OSF
9057 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9058 #endif
9059       implicit none
9060       real(kind=8),dimension(2,2) :: a,at
9061       at(1,1)=a(1,1)
9062       at(1,2)=a(2,1)
9063       at(2,1)=a(1,2)
9064       at(2,2)=a(2,2)
9065       return
9066       end subroutine transpose2
9067 !-----------------------------------------------------------------------------
9068       subroutine transpose(n,a,at)
9069       implicit none
9070       integer :: n,i,j
9071       real(kind=8),dimension(n,n) :: a,at
9072       do i=1,n
9073         do j=1,n
9074           at(j,i)=a(i,j)
9075         enddo
9076       enddo
9077       return
9078       end subroutine transpose
9079 !-----------------------------------------------------------------------------
9080       subroutine prodmat3(a1,a2,kk,transp,prod)
9081 !DIR$ INLINEALWAYS prodmat3
9082 #ifndef OSF
9083 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9084 #endif
9085       implicit none
9086       integer :: i,j
9087       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9088       logical :: transp
9089 !rc      double precision auxmat(2,2),prod_(2,2)
9090
9091       if (transp) then
9092 !rc        call transpose2(kk(1,1),auxmat(1,1))
9093 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9094 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9095
9096            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9097        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9098            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9099        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9100            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9101        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9102            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9103        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9104
9105       else
9106 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9107 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9108
9109            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9110         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9111            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9112         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9113            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9114         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9115            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9116         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9117
9118       endif
9119 !      call transpose2(a2(1,1),a2t(1,1))
9120
9121 !rc      print *,transp
9122 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9123 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9124
9125       return
9126       end subroutine prodmat3
9127 !-----------------------------------------------------------------------------
9128 ! energy_p_new_barrier.F
9129 !-----------------------------------------------------------------------------
9130       subroutine sum_gradient
9131 !      implicit real*8 (a-h,o-z)
9132       use io_base, only: pdbout
9133 !      include 'DIMENSIONS'
9134 #ifndef ISNAN
9135       external proc_proc
9136 #ifdef WINPGI
9137 !MS$ATTRIBUTES C ::  proc_proc
9138 #endif
9139 #endif
9140 #ifdef MPI
9141       include 'mpif.h'
9142 #endif
9143       real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,&
9144                    gloc_scbuf !(3,maxres)
9145
9146       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
9147 !#endif
9148 !el local variables
9149       integer :: i,j,k,ierror,ierr
9150       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
9151                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
9152                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
9153                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
9154                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
9155                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
9156                    gsccorr_max,gsccorrx_max,time00
9157
9158 !      include 'COMMON.SETUP'
9159 !      include 'COMMON.IOUNITS'
9160 !      include 'COMMON.FFIELD'
9161 !      include 'COMMON.DERIV'
9162 !      include 'COMMON.INTERACT'
9163 !      include 'COMMON.SBRIDGE'
9164 !      include 'COMMON.CHAIN'
9165 !      include 'COMMON.VAR'
9166 !      include 'COMMON.CONTROL'
9167 !      include 'COMMON.TIME1'
9168 !      include 'COMMON.MAXGRAD'
9169 !      include 'COMMON.SCCOR'
9170 #ifdef TIMING
9171       time01=MPI_Wtime()
9172 #endif
9173 #ifdef DEBUG
9174       write (iout,*) "sum_gradient gvdwc, gvdwx"
9175       do i=1,nres
9176         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9177          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
9178       enddo
9179       call flush(iout)
9180 #endif
9181 #ifdef MPI
9182         gradbufc=0.0d0
9183         gradbufx=0.0d0
9184         gradbufc_sum=0.0d0
9185         gloc_scbuf=0.0d0
9186         glocbuf=0.0d0
9187 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
9188         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
9189           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
9190 #endif
9191 !
9192 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
9193 !            in virtual-bond-vector coordinates
9194 !
9195 #ifdef DEBUG
9196 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
9197 !      do i=1,nres-1
9198 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
9199 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
9200 !      enddo
9201 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
9202 !      do i=1,nres-1
9203 !        write (iout,'(i5,3f10.5,2x,f10.5)')
9204 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
9205 !      enddo
9206       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
9207       do i=1,nres
9208         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9209          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
9210          (gvdwc_scpp(j,i),j=1,3)
9211       enddo
9212       write (iout,*) "gelc_long gvdwpp gel_loc_long"
9213       do i=1,nres
9214         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
9215          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
9216          (gelc_loc_long(j,i),j=1,3)
9217       enddo
9218       call flush(iout)
9219 #endif
9220 #ifdef SPLITELE
9221       do i=1,nct
9222         do j=1,3
9223           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9224                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9225                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9226                       wel_loc*gel_loc_long(j,i)+ &
9227                       wcorr*gradcorr_long(j,i)+ &
9228                       wcorr5*gradcorr5_long(j,i)+ &
9229                       wcorr6*gradcorr6_long(j,i)+ &
9230                       wturn6*gcorr6_turn_long(j,i)+ &
9231                       wstrain*ghpbc(j,i)
9232         enddo
9233       enddo
9234 #else
9235       do i=1,nct
9236         do j=1,3
9237           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
9238                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
9239                       welec*gelc_long(j,i)+ &
9240                       wbond*gradb(j,i)+ &
9241                       wel_loc*gel_loc_long(j,i)+ &
9242                       wcorr*gradcorr_long(j,i)+ &
9243                       wcorr5*gradcorr5_long(j,i)+ &
9244                       wcorr6*gradcorr6_long(j,i)+ &
9245                       wturn6*gcorr6_turn_long(j,i)+ &
9246                       wstrain*ghpbc(j,i)
9247         enddo
9248       enddo
9249 #endif
9250 #ifdef MPI
9251       if (nfgtasks.gt.1) then
9252       time00=MPI_Wtime()
9253 #ifdef DEBUG
9254       write (iout,*) "gradbufc before allreduce"
9255       do i=1,nres
9256         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9257       enddo
9258       call flush(iout)
9259 #endif
9260       do i=1,nres
9261         do j=1,3
9262           gradbufc_sum(j,i)=gradbufc(j,i)
9263         enddo
9264       enddo
9265 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
9266 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
9267 !      time_reduce=time_reduce+MPI_Wtime()-time00
9268 #ifdef DEBUG
9269 !      write (iout,*) "gradbufc_sum after allreduce"
9270 !      do i=1,nres
9271 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
9272 !      enddo
9273 !      call flush(iout)
9274 #endif
9275 #ifdef TIMING
9276 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
9277 #endif
9278       do i=nnt,nres
9279         do k=1,3
9280           gradbufc(k,i)=0.0d0
9281         enddo
9282       enddo
9283 #ifdef DEBUG
9284       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
9285       write (iout,*) (i," jgrad_start",jgrad_start(i),&
9286                         " jgrad_end  ",jgrad_end(i),&
9287                         i=igrad_start,igrad_end)
9288 #endif
9289 !
9290 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
9291 ! do not parallelize this part.
9292 !
9293 !      do i=igrad_start,igrad_end
9294 !        do j=jgrad_start(i),jgrad_end(i)
9295 !          do k=1,3
9296 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
9297 !          enddo
9298 !        enddo
9299 !      enddo
9300       do j=1,3
9301         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9302       enddo
9303       do i=nres-2,nnt,-1
9304         do j=1,3
9305           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9306         enddo
9307       enddo
9308 #ifdef DEBUG
9309       write (iout,*) "gradbufc after summing"
9310       do i=1,nres
9311         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9312       enddo
9313       call flush(iout)
9314 #endif
9315       else
9316 #endif
9317 !el#define DEBUG
9318 #ifdef DEBUG
9319       write (iout,*) "gradbufc"
9320       do i=1,nres
9321         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9322       enddo
9323       call flush(iout)
9324 #endif
9325 !el#undef DEBUG
9326       do i=1,nres
9327         do j=1,3
9328           gradbufc_sum(j,i)=gradbufc(j,i)
9329           gradbufc(j,i)=0.0d0
9330         enddo
9331       enddo
9332       do j=1,3
9333         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
9334       enddo
9335       do i=nres-2,nnt,-1
9336         do j=1,3
9337           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
9338         enddo
9339       enddo
9340 !      do i=nnt,nres-1
9341 !        do k=1,3
9342 !          gradbufc(k,i)=0.0d0
9343 !        enddo
9344 !        do j=i+1,nres
9345 !          do k=1,3
9346 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
9347 !          enddo
9348 !        enddo
9349 !      enddo
9350 !el#define DEBUG
9351 #ifdef DEBUG
9352       write (iout,*) "gradbufc after summing"
9353       do i=1,nres
9354         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
9355       enddo
9356       call flush(iout)
9357 #endif
9358 !el#undef DEBUG
9359 #ifdef MPI
9360       endif
9361 #endif
9362       do k=1,3
9363         gradbufc(k,nres)=0.0d0
9364       enddo
9365 !el----------------
9366 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
9367 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
9368 !el-----------------
9369       do i=1,nct
9370         do j=1,3
9371 #ifdef SPLITELE
9372           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9373                       wel_loc*gel_loc(j,i)+ &
9374                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9375                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
9376                       wel_loc*gel_loc_long(j,i)+ &
9377                       wcorr*gradcorr_long(j,i)+ &
9378                       wcorr5*gradcorr5_long(j,i)+ &
9379                       wcorr6*gradcorr6_long(j,i)+ &
9380                       wturn6*gcorr6_turn_long(j,i))+ &
9381                       wbond*gradb(j,i)+ &
9382                       wcorr*gradcorr(j,i)+ &
9383                       wturn3*gcorr3_turn(j,i)+ &
9384                       wturn4*gcorr4_turn(j,i)+ &
9385                       wcorr5*gradcorr5(j,i)+ &
9386                       wcorr6*gradcorr6(j,i)+ &
9387                       wturn6*gcorr6_turn(j,i)+ &
9388                       wsccor*gsccorc(j,i) &
9389                      +wscloc*gscloc(j,i)
9390 #else
9391           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
9392                       wel_loc*gel_loc(j,i)+ &
9393                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
9394                       welec*gelc_long(j,i)+ &
9395                       wel_loc*gel_loc_long(j,i)+ &
9396 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
9397                       wcorr5*gradcorr5_long(j,i)+ &
9398                       wcorr6*gradcorr6_long(j,i)+ &
9399                       wturn6*gcorr6_turn_long(j,i))+ &
9400                       wbond*gradb(j,i)+ &
9401                       wcorr*gradcorr(j,i)+ &
9402                       wturn3*gcorr3_turn(j,i)+ &
9403                       wturn4*gcorr4_turn(j,i)+ &
9404                       wcorr5*gradcorr5(j,i)+ &
9405                       wcorr6*gradcorr6(j,i)+ &
9406                       wturn6*gcorr6_turn(j,i)+ &
9407                       wsccor*gsccorc(j,i) &
9408                      +wscloc*gscloc(j,i)
9409 #endif
9410           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
9411                         wbond*gradbx(j,i)+ &
9412                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
9413                         wsccor*gsccorx(j,i) &
9414                        +wscloc*gsclocx(j,i)
9415         enddo
9416       enddo
9417 #ifdef DEBUG
9418       write (iout,*) "gloc before adding corr"
9419       do i=1,4*nres
9420         write (iout,*) i,gloc(i,icg)
9421       enddo
9422 #endif
9423       do i=1,nres-3
9424         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
9425          +wcorr5*g_corr5_loc(i) &
9426          +wcorr6*g_corr6_loc(i) &
9427          +wturn4*gel_loc_turn4(i) &
9428          +wturn3*gel_loc_turn3(i) &
9429          +wturn6*gel_loc_turn6(i) &
9430          +wel_loc*gel_loc_loc(i)
9431       enddo
9432 #ifdef DEBUG
9433       write (iout,*) "gloc after adding corr"
9434       do i=1,4*nres
9435         write (iout,*) i,gloc(i,icg)
9436       enddo
9437 #endif
9438 #ifdef MPI
9439       if (nfgtasks.gt.1) then
9440         do j=1,3
9441           do i=1,nres
9442             gradbufc(j,i)=gradc(j,i,icg)
9443             gradbufx(j,i)=gradx(j,i,icg)
9444           enddo
9445         enddo
9446         do i=1,4*nres
9447           glocbuf(i)=gloc(i,icg)
9448         enddo
9449 !#define DEBUG
9450 #ifdef DEBUG
9451       write (iout,*) "gloc_sc before reduce"
9452       do i=1,nres
9453        do j=1,1
9454         write (iout,*) i,j,gloc_sc(j,i,icg)
9455        enddo
9456       enddo
9457 #endif
9458 !#undef DEBUG
9459         do i=1,nres
9460          do j=1,3
9461           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
9462          enddo
9463         enddo
9464         time00=MPI_Wtime()
9465         call MPI_Barrier(FG_COMM,IERR)
9466         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
9467         time00=MPI_Wtime()
9468         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
9469           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9470         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
9471           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9472         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
9473           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9474         time_reduce=time_reduce+MPI_Wtime()-time00
9475         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
9476           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9477         time_reduce=time_reduce+MPI_Wtime()-time00
9478 !#define DEBUG
9479 #ifdef DEBUG
9480       write (iout,*) "gloc_sc after reduce"
9481       do i=1,nres
9482        do j=1,1
9483         write (iout,*) i,j,gloc_sc(j,i,icg)
9484        enddo
9485       enddo
9486 #endif
9487 !#undef DEBUG
9488 #ifdef DEBUG
9489       write (iout,*) "gloc after reduce"
9490       do i=1,4*nres
9491         write (iout,*) i,gloc(i,icg)
9492       enddo
9493 #endif
9494       endif
9495 #endif
9496       if (gnorm_check) then
9497 !
9498 ! Compute the maximum elements of the gradient
9499 !
9500       gvdwc_max=0.0d0
9501       gvdwc_scp_max=0.0d0
9502       gelc_max=0.0d0
9503       gvdwpp_max=0.0d0
9504       gradb_max=0.0d0
9505       ghpbc_max=0.0d0
9506       gradcorr_max=0.0d0
9507       gel_loc_max=0.0d0
9508       gcorr3_turn_max=0.0d0
9509       gcorr4_turn_max=0.0d0
9510       gradcorr5_max=0.0d0
9511       gradcorr6_max=0.0d0
9512       gcorr6_turn_max=0.0d0
9513       gsccorc_max=0.0d0
9514       gscloc_max=0.0d0
9515       gvdwx_max=0.0d0
9516       gradx_scp_max=0.0d0
9517       ghpbx_max=0.0d0
9518       gradxorr_max=0.0d0
9519       gsccorx_max=0.0d0
9520       gsclocx_max=0.0d0
9521       do i=1,nct
9522         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
9523         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
9524         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
9525         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
9526          gvdwc_scp_max=gvdwc_scp_norm
9527         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
9528         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
9529         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
9530         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
9531         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
9532         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
9533         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
9534         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
9535         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
9536         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
9537         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
9538         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
9539         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
9540           gcorr3_turn(1,i)))
9541         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
9542           gcorr3_turn_max=gcorr3_turn_norm
9543         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
9544           gcorr4_turn(1,i)))
9545         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
9546           gcorr4_turn_max=gcorr4_turn_norm
9547         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
9548         if (gradcorr5_norm.gt.gradcorr5_max) &
9549           gradcorr5_max=gradcorr5_norm
9550         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
9551         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
9552         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
9553           gcorr6_turn(1,i)))
9554         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
9555           gcorr6_turn_max=gcorr6_turn_norm
9556         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
9557         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
9558         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
9559         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
9560         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
9561         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
9562         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
9563         if (gradx_scp_norm.gt.gradx_scp_max) &
9564           gradx_scp_max=gradx_scp_norm
9565         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
9566         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
9567         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
9568         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
9569         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
9570         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
9571         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
9572         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
9573       enddo
9574       if (gradout) then
9575 #ifdef AIX
9576         open(istat,file=statname,position="append")
9577 #else
9578         open(istat,file=statname,access="append")
9579 #endif
9580         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
9581            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
9582            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
9583            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
9584            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
9585            gsccorx_max,gsclocx_max
9586         close(istat)
9587         if (gvdwc_max.gt.1.0d4) then
9588           write (iout,*) "gvdwc gvdwx gradb gradbx"
9589           do i=nnt,nct
9590             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
9591               gradb(j,i),gradbx(j,i),j=1,3)
9592           enddo
9593           call pdbout(0.0d0,'cipiszcze',iout)
9594           call flush(iout)
9595         endif
9596       endif
9597       endif
9598 !el#define DEBUG
9599 #ifdef DEBUG
9600       write (iout,*) "gradc gradx gloc"
9601       do i=1,nres
9602         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
9603          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
9604       enddo
9605 #endif
9606 !el#undef DEBUG
9607 #ifdef TIMING
9608       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
9609 #endif
9610       return
9611       end subroutine sum_gradient
9612 !-----------------------------------------------------------------------------
9613       subroutine sc_grad
9614 !      implicit real*8 (a-h,o-z)
9615       use calc_data
9616 !      include 'DIMENSIONS'
9617 !      include 'COMMON.CHAIN'
9618 !      include 'COMMON.DERIV'
9619 !      include 'COMMON.CALC'
9620 !      include 'COMMON.IOUNITS'
9621       real(kind=8), dimension(3) :: dcosom1,dcosom2
9622
9623       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
9624       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
9625       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
9626            -2.0D0*alf12*eps3der+sigder*sigsq_om12
9627 ! diagnostics only
9628 !      eom1=0.0d0
9629 !      eom2=0.0d0
9630 !      eom12=evdwij*eps1_om12
9631 ! end diagnostics
9632 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
9633 !       " sigder",sigder
9634 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
9635 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
9636 !C      print *,sss_ele_cut,'in sc_grad'
9637       do k=1,3
9638         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
9639         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
9640       enddo
9641       do k=1,3
9642         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
9643 !C      print *,'gg',k,gg(k)
9644       enddo
9645 !      write (iout,*) "gg",(gg(k),k=1,3)
9646       do k=1,3
9647         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
9648                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9649                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
9650                   *sss_ele_cut
9651
9652         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
9653                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9654                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
9655                   *sss_ele_cut
9656
9657 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
9658 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
9659 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
9660 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
9661       enddo
9662 !
9663 ! Calculate the components of the gradient in DC and X
9664 !
9665 !grad      do k=i,j-1
9666 !grad        do l=1,3
9667 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
9668 !grad        enddo
9669 !grad      enddo
9670       do l=1,3
9671         gvdwc(l,i)=gvdwc(l,i)-gg(l)
9672         gvdwc(l,j)=gvdwc(l,j)+gg(l)
9673       enddo
9674       return
9675       end subroutine sc_grad
9676 #ifdef CRYST_THETA
9677 !-----------------------------------------------------------------------------
9678       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
9679
9680       use comm_calcthet
9681 !      implicit real*8 (a-h,o-z)
9682 !      include 'DIMENSIONS'
9683 !      include 'COMMON.LOCAL'
9684 !      include 'COMMON.IOUNITS'
9685 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
9686 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9687 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
9688       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
9689       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
9690 !el      integer :: it
9691 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
9692 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
9693 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
9694 !el local variables
9695
9696       delthec=thetai-thet_pred_mean
9697       delthe0=thetai-theta0i
9698 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
9699       t3 = thetai-thet_pred_mean
9700       t6 = t3**2
9701       t9 = term1
9702       t12 = t3*sigcsq
9703       t14 = t12+t6*sigsqtc
9704       t16 = 1.0d0
9705       t21 = thetai-theta0i
9706       t23 = t21**2
9707       t26 = term2
9708       t27 = t21*t26
9709       t32 = termexp
9710       t40 = t32**2
9711       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
9712        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
9713        *(-t12*t9-ak*sig0inv*t27)
9714       return
9715       end subroutine mixder
9716 #endif
9717 !-----------------------------------------------------------------------------
9718 ! cartder.F
9719 !-----------------------------------------------------------------------------
9720       subroutine cartder
9721 !-----------------------------------------------------------------------------
9722 ! This subroutine calculates the derivatives of the consecutive virtual
9723 ! bond vectors and the SC vectors in the virtual-bond angles theta and
9724 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
9725 ! in the angles alpha and omega, describing the location of a side chain
9726 ! in its local coordinate system.
9727 !
9728 ! The derivatives are stored in the following arrays:
9729 !
9730 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
9731 ! The structure is as follows:
9732 !
9733 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
9734 ! 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)
9735 !         . . . . . . . . . . . .  . . . . . .
9736 ! 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)
9737 !                          .
9738 !                          .
9739 !                          .
9740 ! 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)
9741 !
9742 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
9743 ! The structure is same as above.
9744 !
9745 ! DCDS - the derivatives of the side chain vectors in the local spherical
9746 ! andgles alph and omega:
9747 !
9748 ! 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)
9749 ! 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)
9750 !                          .
9751 !                          .
9752 !                          .
9753 ! 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)
9754 !
9755 ! Version of March '95, based on an early version of November '91.
9756 !
9757 !**********************************************************************
9758 !      implicit real*8 (a-h,o-z)
9759 !      include 'DIMENSIONS'
9760 !      include 'COMMON.VAR'
9761 !      include 'COMMON.CHAIN'
9762 !      include 'COMMON.DERIV'
9763 !      include 'COMMON.GEO'
9764 !      include 'COMMON.LOCAL'
9765 !      include 'COMMON.INTERACT'
9766       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
9767       real(kind=8),dimension(3,3) :: dp,temp
9768 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
9769       real(kind=8),dimension(3) :: xx,xx1
9770 !el local variables
9771       integer :: i,k,l,j,m,ind,ind1,jjj
9772       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
9773                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
9774                  sint2,xp,yp,xxp,yyp,zzp,dj
9775
9776 !      common /przechowalnia/ fromto
9777       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
9778 ! get the position of the jth ijth fragment of the chain coordinate system
9779 ! in the fromto array.
9780 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
9781 !
9782 !      maxdim=(nres-1)*(nres-2)/2
9783 !      allocate(dcdv(6,maxdim),dxds(6,nres))
9784 ! calculate the derivatives of transformation matrix elements in theta
9785 !
9786
9787 !el      call flush(iout) !el
9788       do i=1,nres-2
9789         rdt(1,1,i)=-rt(1,2,i)
9790         rdt(1,2,i)= rt(1,1,i)
9791         rdt(1,3,i)= 0.0d0
9792         rdt(2,1,i)=-rt(2,2,i)
9793         rdt(2,2,i)= rt(2,1,i)
9794         rdt(2,3,i)= 0.0d0
9795         rdt(3,1,i)=-rt(3,2,i)
9796         rdt(3,2,i)= rt(3,1,i)
9797         rdt(3,3,i)= 0.0d0
9798       enddo
9799 !
9800 ! derivatives in phi
9801 !
9802       do i=2,nres-2
9803         drt(1,1,i)= 0.0d0
9804         drt(1,2,i)= 0.0d0
9805         drt(1,3,i)= 0.0d0
9806         drt(2,1,i)= rt(3,1,i)
9807         drt(2,2,i)= rt(3,2,i)
9808         drt(2,3,i)= rt(3,3,i)
9809         drt(3,1,i)=-rt(2,1,i)
9810         drt(3,2,i)=-rt(2,2,i)
9811         drt(3,3,i)=-rt(2,3,i)
9812       enddo
9813 !
9814 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
9815 !
9816       do i=2,nres-2
9817         ind=indmat(i,i+1)
9818         do k=1,3
9819           do l=1,3
9820             temp(k,l)=rt(k,l,i)
9821           enddo
9822         enddo
9823         do k=1,3
9824           do l=1,3
9825             fromto(k,l,ind)=temp(k,l)
9826           enddo
9827         enddo
9828         do j=i+1,nres-2
9829           ind=indmat(i,j+1)
9830           do k=1,3
9831             do l=1,3
9832               dpkl=0.0d0
9833               do m=1,3
9834                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
9835               enddo
9836               dp(k,l)=dpkl
9837               fromto(k,l,ind)=dpkl
9838             enddo
9839           enddo
9840           do k=1,3
9841             do l=1,3
9842               temp(k,l)=dp(k,l)
9843             enddo
9844           enddo
9845         enddo
9846       enddo
9847 !
9848 ! Calculate derivatives.
9849 !
9850       ind1=0
9851       do i=1,nres-2
9852         ind1=ind1+1
9853 !
9854 ! Derivatives of DC(i+1) in theta(i+2)
9855 !
9856         do j=1,3
9857           do k=1,2
9858             dpjk=0.0D0
9859             do l=1,3
9860               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
9861             enddo
9862             dp(j,k)=dpjk
9863             prordt(j,k,i)=dp(j,k)
9864           enddo
9865           dp(j,3)=0.0D0
9866           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
9867         enddo
9868 !
9869 ! Derivatives of SC(i+1) in theta(i+2)
9870 !
9871         xx1(1)=-0.5D0*xloc(2,i+1)
9872         xx1(2)= 0.5D0*xloc(1,i+1)
9873         do j=1,3
9874           xj=0.0D0
9875           do k=1,2
9876             xj=xj+r(j,k,i)*xx1(k)
9877           enddo
9878           xx(j)=xj
9879         enddo
9880         do j=1,3
9881           rj=0.0D0
9882           do k=1,3
9883             rj=rj+prod(j,k,i)*xx(k)
9884           enddo
9885           dxdv(j,ind1)=rj
9886         enddo
9887 !
9888 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
9889 ! than the other off-diagonal derivatives.
9890 !
9891         do j=1,3
9892           dxoiij=0.0D0
9893           do k=1,3
9894             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9895           enddo
9896           dxdv(j,ind1+1)=dxoiij
9897         enddo
9898 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
9899 !
9900 ! Derivatives of DC(i+1) in phi(i+2)
9901 !
9902         do j=1,3
9903           do k=1,3
9904             dpjk=0.0
9905             do l=2,3
9906               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
9907             enddo
9908             dp(j,k)=dpjk
9909             prodrt(j,k,i)=dp(j,k)
9910           enddo
9911           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
9912         enddo
9913 !
9914 ! Derivatives of SC(i+1) in phi(i+2)
9915 !
9916         xx(1)= 0.0D0
9917         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
9918         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
9919         do j=1,3
9920           rj=0.0D0
9921           do k=2,3
9922             rj=rj+prod(j,k,i)*xx(k)
9923           enddo
9924           dxdv(j+3,ind1)=-rj
9925         enddo
9926 !
9927 ! Derivatives of SC(i+1) in phi(i+3).
9928 !
9929         do j=1,3
9930           dxoiij=0.0D0
9931           do k=1,3
9932             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
9933           enddo
9934           dxdv(j+3,ind1+1)=dxoiij
9935         enddo
9936 !
9937 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
9938 ! theta(nres) and phi(i+3) thru phi(nres).
9939 !
9940         do j=i+1,nres-2
9941           ind1=ind1+1
9942           ind=indmat(i+1,j+1)
9943 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
9944           do k=1,3
9945             do l=1,3
9946               tempkl=0.0D0
9947               do m=1,2
9948                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
9949               enddo
9950               temp(k,l)=tempkl
9951             enddo
9952           enddo
9953 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
9954 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
9955 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
9956 ! Derivatives of virtual-bond vectors in theta
9957           do k=1,3
9958             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
9959           enddo
9960 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
9961 ! Derivatives of SC vectors in theta
9962           do k=1,3
9963             dxoijk=0.0D0
9964             do l=1,3
9965               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9966             enddo
9967             dxdv(k,ind1+1)=dxoijk
9968           enddo
9969 !
9970 !--- Calculate the derivatives in phi
9971 !
9972           do k=1,3
9973             do l=1,3
9974               tempkl=0.0D0
9975               do m=1,3
9976                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
9977               enddo
9978               temp(k,l)=tempkl
9979             enddo
9980           enddo
9981           do k=1,3
9982             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
9983           enddo
9984           do k=1,3
9985             dxoijk=0.0D0
9986             do l=1,3
9987               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
9988             enddo
9989             dxdv(k+3,ind1+1)=dxoijk
9990           enddo
9991         enddo
9992       enddo
9993 !
9994 ! Derivatives in alpha and omega:
9995 !
9996       do i=2,nres-1
9997 !       dsci=dsc(itype(i))
9998         dsci=vbld(i+nres)
9999 #ifdef OSF
10000         alphi=alph(i)
10001         omegi=omeg(i)
10002         if(alphi.ne.alphi) alphi=100.0
10003         if(omegi.ne.omegi) omegi=-100.0
10004 #else
10005         alphi=alph(i)
10006         omegi=omeg(i)
10007 #endif
10008 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10009         cosalphi=dcos(alphi)
10010         sinalphi=dsin(alphi)
10011         cosomegi=dcos(omegi)
10012         sinomegi=dsin(omegi)
10013         temp(1,1)=-dsci*sinalphi
10014         temp(2,1)= dsci*cosalphi*cosomegi
10015         temp(3,1)=-dsci*cosalphi*sinomegi
10016         temp(1,2)=0.0D0
10017         temp(2,2)=-dsci*sinalphi*sinomegi
10018         temp(3,2)=-dsci*sinalphi*cosomegi
10019         theta2=pi-0.5D0*theta(i+1)
10020         cost2=dcos(theta2)
10021         sint2=dsin(theta2)
10022         jjj=0
10023 !d      print *,((temp(l,k),l=1,3),k=1,2)
10024         do j=1,2
10025           xp=temp(1,j)
10026           yp=temp(2,j)
10027           xxp= xp*cost2+yp*sint2
10028           yyp=-xp*sint2+yp*cost2
10029           zzp=temp(3,j)
10030           xx(1)=xxp
10031           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10032           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10033           do k=1,3
10034             dj=0.0D0
10035             do l=1,3
10036               dj=dj+prod(k,l,i-1)*xx(l)
10037             enddo
10038             dxds(jjj+k,i)=dj
10039           enddo
10040           jjj=jjj+3
10041         enddo
10042       enddo
10043       return
10044       end subroutine cartder
10045 !-----------------------------------------------------------------------------
10046 ! checkder_p.F
10047 !-----------------------------------------------------------------------------
10048       subroutine check_cartgrad
10049 ! Check the gradient of Cartesian coordinates in internal coordinates.
10050 !      implicit real*8 (a-h,o-z)
10051 !      include 'DIMENSIONS'
10052 !      include 'COMMON.IOUNITS'
10053 !      include 'COMMON.VAR'
10054 !      include 'COMMON.CHAIN'
10055 !      include 'COMMON.GEO'
10056 !      include 'COMMON.LOCAL'
10057 !      include 'COMMON.DERIV'
10058       real(kind=8),dimension(6,nres) :: temp
10059       real(kind=8),dimension(3) :: xx,gg
10060       integer :: i,k,j,ii
10061       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10062 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10063 !
10064 ! Check the gradient of the virtual-bond and SC vectors in the internal
10065 ! coordinates.
10066 !
10067       aincr=1.0d-7
10068       aincr2=5.0d-8
10069       call cartder
10070       write (iout,'(a)') '**************** dx/dalpha'
10071       write (iout,'(a)')
10072       do i=2,nres-1
10073         alphi=alph(i)
10074         alph(i)=alph(i)+aincr
10075         do k=1,3
10076           temp(k,i)=dc(k,nres+i)
10077         enddo
10078         call chainbuild
10079         do k=1,3
10080           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10081           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
10082         enddo
10083         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10084         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
10085         write (iout,'(a)')
10086         alph(i)=alphi
10087         call chainbuild
10088       enddo
10089       write (iout,'(a)')
10090       write (iout,'(a)') '**************** dx/domega'
10091       write (iout,'(a)')
10092       do i=2,nres-1
10093         omegi=omeg(i)
10094         omeg(i)=omeg(i)+aincr
10095         do k=1,3
10096           temp(k,i)=dc(k,nres+i)
10097         enddo
10098         call chainbuild
10099         do k=1,3
10100           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
10101           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
10102                 (aincr*dabs(dxds(k+3,i))+aincr))
10103         enddo
10104         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
10105             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
10106         write (iout,'(a)')
10107         omeg(i)=omegi
10108         call chainbuild
10109       enddo
10110       write (iout,'(a)')
10111       write (iout,'(a)') '**************** dx/dtheta'
10112       write (iout,'(a)')
10113       do i=3,nres
10114         theti=theta(i)
10115         theta(i)=theta(i)+aincr
10116         do j=i-1,nres-1
10117           do k=1,3
10118             temp(k,j)=dc(k,nres+j)
10119           enddo
10120         enddo
10121         call chainbuild
10122         do j=i-1,nres-1
10123           ii = indmat(i-2,j)
10124 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
10125           do k=1,3
10126             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10127             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
10128                   (aincr*dabs(dxdv(k,ii))+aincr))
10129           enddo
10130           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10131               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
10132           write(iout,'(a)')
10133         enddo
10134         write (iout,'(a)')
10135         theta(i)=theti
10136         call chainbuild
10137       enddo
10138       write (iout,'(a)') '***************** dx/dphi'
10139       write (iout,'(a)')
10140       do i=4,nres
10141         phi(i)=phi(i)+aincr
10142         do j=i-1,nres-1
10143           do k=1,3
10144             temp(k,j)=dc(k,nres+j)
10145           enddo
10146         enddo
10147         call chainbuild
10148         do j=i-1,nres-1
10149           ii = indmat(i-2,j)
10150 !         print *,'ii=',ii
10151           do k=1,3
10152             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
10153             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
10154                   (aincr*dabs(dxdv(k+3,ii))+aincr))
10155           enddo
10156           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10157               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10158           write(iout,'(a)')
10159         enddo
10160         phi(i)=phi(i)-aincr
10161         call chainbuild
10162       enddo
10163       write (iout,'(a)') '****************** ddc/dtheta'
10164       do i=1,nres-2
10165         thet=theta(i+2)
10166         theta(i+2)=thet+aincr
10167         do j=i,nres
10168           do k=1,3
10169             temp(k,j)=dc(k,j)
10170           enddo
10171         enddo
10172         call chainbuild
10173         do j=i+1,nres-1
10174           ii = indmat(i,j)
10175 !         print *,'ii=',ii
10176           do k=1,3
10177             gg(k)=(dc(k,j)-temp(k,j))/aincr
10178             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
10179                  (aincr*dabs(dcdv(k,ii))+aincr))
10180           enddo
10181           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10182                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
10183           write (iout,'(a)')
10184         enddo
10185         do j=1,nres
10186           do k=1,3
10187             dc(k,j)=temp(k,j)
10188           enddo
10189         enddo
10190         theta(i+2)=thet
10191       enddo
10192       write (iout,'(a)') '******************* ddc/dphi'
10193       do i=1,nres-3
10194         phii=phi(i+3)
10195         phi(i+3)=phii+aincr
10196         do j=1,nres
10197           do k=1,3
10198             temp(k,j)=dc(k,j)
10199           enddo
10200         enddo
10201         call chainbuild
10202         do j=i+2,nres-1
10203           ii = indmat(i+1,j)
10204 !         print *,'ii=',ii
10205           do k=1,3
10206             gg(k)=(dc(k,j)-temp(k,j))/aincr
10207             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
10208                  (aincr*dabs(dcdv(k+3,ii))+aincr))
10209           enddo
10210           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
10211                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
10212           write (iout,'(a)')
10213         enddo
10214         do j=1,nres
10215           do k=1,3
10216             dc(k,j)=temp(k,j)
10217           enddo
10218         enddo
10219         phi(i+3)=phii
10220       enddo
10221       return
10222       end subroutine check_cartgrad
10223 !-----------------------------------------------------------------------------
10224       subroutine check_ecart
10225 ! Check the gradient of the energy in Cartesian coordinates.
10226 !     implicit real*8 (a-h,o-z)
10227 !     include 'DIMENSIONS'
10228 !     include 'COMMON.CHAIN'
10229 !     include 'COMMON.DERIV'
10230 !     include 'COMMON.IOUNITS'
10231 !     include 'COMMON.VAR'
10232 !     include 'COMMON.CONTACTS'
10233       use comm_srutu
10234 !el      integer :: icall
10235 !el      common /srutu/ icall
10236       real(kind=8),dimension(6) :: ggg
10237       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10238       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10239       real(kind=8),dimension(6,nres) :: grad_s
10240       real(kind=8),dimension(0:n_ene) :: energia,energia1
10241       integer :: uiparm(1)
10242       real(kind=8) :: urparm(1)
10243 !EL      external fdum
10244       integer :: nf,i,j,k
10245       real(kind=8) :: aincr,etot,etot1
10246       icg=1
10247       nf=0
10248       nfl=0
10249       call zerograd
10250       aincr=1.0D-7
10251       print '(a)','CG processor',me,' calling CHECK_CART.'
10252       nf=0
10253       icall=0
10254       call geom_to_var(nvar,x)
10255       call etotal(energia)
10256       etot=energia(0)
10257 !el      call enerprint(energia)
10258       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
10259       icall =1
10260       do i=1,nres
10261         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10262       enddo
10263       do i=1,nres
10264         do j=1,3
10265           grad_s(j,i)=gradc(j,i,icg)
10266           grad_s(j+3,i)=gradx(j,i,icg)
10267         enddo
10268       enddo
10269       call flush(iout)
10270       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10271       do i=1,nres
10272         do j=1,3
10273           xx(j)=c(j,i+nres)
10274           ddc(j)=dc(j,i)
10275           ddx(j)=dc(j,i+nres)
10276         enddo
10277         do j=1,3
10278           dc(j,i)=dc(j,i)+aincr
10279           do k=i+1,nres
10280             c(j,k)=c(j,k)+aincr
10281             c(j,k+nres)=c(j,k+nres)+aincr
10282           enddo
10283           call etotal(energia1)
10284           etot1=energia1(0)
10285           ggg(j)=(etot1-etot)/aincr
10286           dc(j,i)=ddc(j)
10287           do k=i+1,nres
10288             c(j,k)=c(j,k)-aincr
10289             c(j,k+nres)=c(j,k+nres)-aincr
10290           enddo
10291         enddo
10292         do j=1,3
10293           c(j,i+nres)=c(j,i+nres)+aincr
10294           dc(j,i+nres)=dc(j,i+nres)+aincr
10295           call etotal(energia1)
10296           etot1=energia1(0)
10297           ggg(j+3)=(etot1-etot)/aincr
10298           c(j,i+nres)=xx(j)
10299           dc(j,i+nres)=ddx(j)
10300         enddo
10301         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
10302          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
10303       enddo
10304       return
10305       end subroutine check_ecart
10306 #ifdef CARGRAD
10307 !-----------------------------------------------------------------------------
10308       subroutine check_ecartint
10309 ! Check the gradient of the energy in Cartesian coordinates.
10310       use io_base, only: intout
10311 !      implicit real*8 (a-h,o-z)
10312 !      include 'DIMENSIONS'
10313 !      include 'COMMON.CONTROL'
10314 !      include 'COMMON.CHAIN'
10315 !      include 'COMMON.DERIV'
10316 !      include 'COMMON.IOUNITS'
10317 !      include 'COMMON.VAR'
10318 !      include 'COMMON.CONTACTS'
10319 !      include 'COMMON.MD'
10320 !      include 'COMMON.LOCAL'
10321 !      include 'COMMON.SPLITELE'
10322       use comm_srutu
10323 !el      integer :: icall
10324 !el      common /srutu/ icall
10325       real(kind=8),dimension(6) :: ggg,ggg1
10326       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
10327       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10328       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
10329       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10330       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10331       real(kind=8),dimension(0:n_ene) :: energia,energia1
10332       integer :: uiparm(1)
10333       real(kind=8) :: urparm(1)
10334 !EL      external fdum
10335       integer :: i,j,k,nf
10336       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10337                    etot21,etot22
10338       r_cut=2.0d0
10339       rlambd=0.3d0
10340       icg=1
10341       nf=0
10342       nfl=0
10343       call intout
10344 !      call intcartderiv
10345 !      call checkintcartgrad
10346       call zerograd
10347       aincr=1.0D-5
10348       write(iout,*) 'Calling CHECK_ECARTINT.'
10349       nf=0
10350       icall=0
10351       write (iout,*) "Before geom_to_var"
10352       call geom_to_var(nvar,x)
10353       write (iout,*) "after geom_to_var"
10354       write (iout,*) "split_ene ",split_ene
10355       call flush(iout)
10356       if (.not.split_ene) then
10357         write(iout,*) 'Calling CHECK_ECARTINT if'
10358         call etotal(energia)
10359 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10360         etot=energia(0)
10361         write (iout,*) "etot",etot
10362         call flush(iout)
10363 !el        call enerprint(energia)
10364 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10365         call flush(iout)
10366         write (iout,*) "enter cartgrad"
10367         call flush(iout)
10368         call cartgrad
10369 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10370         write (iout,*) "exit cartgrad"
10371         call flush(iout)
10372         icall =1
10373         do i=1,nres
10374           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10375         enddo
10376         do j=1,3
10377           grad_s(j,0)=gcart(j,0)
10378         enddo
10379 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
10380         do i=1,nres
10381           do j=1,3
10382             grad_s(j,i)=gcart(j,i)
10383             grad_s(j+3,i)=gxcart(j,i)
10384           enddo
10385         enddo
10386       else
10387 write(iout,*) 'Calling CHECK_ECARTIN else.'
10388 !- split gradient check
10389         call zerograd
10390         call etotal_long(energia)
10391 !el        call enerprint(energia)
10392         call flush(iout)
10393         write (iout,*) "enter cartgrad"
10394         call flush(iout)
10395         call cartgrad
10396         write (iout,*) "exit cartgrad"
10397         call flush(iout)
10398         icall =1
10399         write (iout,*) "longrange grad"
10400         do i=1,nres
10401           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10402           (gxcart(j,i),j=1,3)
10403         enddo
10404         do j=1,3
10405           grad_s(j,0)=gcart(j,0)
10406         enddo
10407         do i=1,nres
10408           do j=1,3
10409             grad_s(j,i)=gcart(j,i)
10410             grad_s(j+3,i)=gxcart(j,i)
10411           enddo
10412         enddo
10413         call zerograd
10414         call etotal_short(energia)
10415 !el        call enerprint(energia)
10416         call flush(iout)
10417         write (iout,*) "enter cartgrad"
10418         call flush(iout)
10419         call cartgrad
10420         write (iout,*) "exit cartgrad"
10421         call flush(iout)
10422         icall =1
10423         write (iout,*) "shortrange grad"
10424         do i=1,nres
10425           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10426           (gxcart(j,i),j=1,3)
10427         enddo
10428         do j=1,3
10429           grad_s1(j,0)=gcart(j,0)
10430         enddo
10431         do i=1,nres
10432           do j=1,3
10433             grad_s1(j,i)=gcart(j,i)
10434             grad_s1(j+3,i)=gxcart(j,i)
10435           enddo
10436         enddo
10437       endif
10438       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10439 !      do i=1,nres
10440       do i=nnt,nct
10441         do j=1,3
10442           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
10443           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
10444           ddc(j)=c(j,i)
10445           ddx(j)=c(j,i+nres)
10446           dcnorm_safe1(j)=dc_norm(j,i-1)
10447           dcnorm_safe2(j)=dc_norm(j,i)
10448           dxnorm_safe(j)=dc_norm(j,i+nres)
10449         enddo
10450         do j=1,3
10451           c(j,i)=ddc(j)+aincr
10452           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
10453           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
10454           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10455           dc(j,i)=c(j,i+1)-c(j,i)
10456           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10457           call int_from_cart1(.false.)
10458           if (.not.split_ene) then
10459             call etotal(energia1)
10460             etot1=energia1(0)
10461             write (iout,*) "ij",i,j," etot1",etot1
10462           else
10463 !- split gradient
10464             call etotal_long(energia1)
10465             etot11=energia1(0)
10466             call etotal_short(energia1)
10467             etot12=energia1(0)
10468           endif
10469 !- end split gradient
10470 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10471           c(j,i)=ddc(j)-aincr
10472           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
10473           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
10474           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10475           dc(j,i)=c(j,i+1)-c(j,i)
10476           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10477           call int_from_cart1(.false.)
10478           if (.not.split_ene) then
10479             call etotal(energia1)
10480             etot2=energia1(0)
10481             write (iout,*) "ij",i,j," etot2",etot2
10482             ggg(j)=(etot1-etot2)/(2*aincr)
10483           else
10484 !- split gradient
10485             call etotal_long(energia1)
10486             etot21=energia1(0)
10487             ggg(j)=(etot11-etot21)/(2*aincr)
10488             call etotal_short(energia1)
10489             etot22=energia1(0)
10490             ggg1(j)=(etot12-etot22)/(2*aincr)
10491 !- end split gradient
10492 !            write (iout,*) "etot21",etot21," etot22",etot22
10493           endif
10494 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10495           c(j,i)=ddc(j)
10496           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
10497           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
10498           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
10499           dc(j,i)=c(j,i+1)-c(j,i)
10500           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10501           dc_norm(j,i-1)=dcnorm_safe1(j)
10502           dc_norm(j,i)=dcnorm_safe2(j)
10503           dc_norm(j,i+nres)=dxnorm_safe(j)
10504         enddo
10505         do j=1,3
10506           c(j,i+nres)=ddx(j)+aincr
10507           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10508           call int_from_cart1(.false.)
10509           if (.not.split_ene) then
10510             call etotal(energia1)
10511             etot1=energia1(0)
10512           else
10513 !- split gradient
10514             call etotal_long(energia1)
10515             etot11=energia1(0)
10516             call etotal_short(energia1)
10517             etot12=energia1(0)
10518           endif
10519 !- end split gradient
10520           c(j,i+nres)=ddx(j)-aincr
10521           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10522           call int_from_cart1(.false.)
10523           if (.not.split_ene) then
10524             call etotal(energia1)
10525             etot2=energia1(0)
10526             ggg(j+3)=(etot1-etot2)/(2*aincr)
10527           else
10528 !- split gradient
10529             call etotal_long(energia1)
10530             etot21=energia1(0)
10531             ggg(j+3)=(etot11-etot21)/(2*aincr)
10532             call etotal_short(energia1)
10533             etot22=energia1(0)
10534             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10535 !- end split gradient
10536           endif
10537 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10538           c(j,i+nres)=ddx(j)
10539           dc(j,i+nres)=c(j,i+nres)-c(j,i)
10540           dc_norm(j,i+nres)=dxnorm_safe(j)
10541           call int_from_cart1(.false.)
10542         enddo
10543         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10544          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10545         if (split_ene) then
10546           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10547          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10548          k=1,6)
10549          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10550          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10551          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10552         endif
10553       enddo
10554       return
10555       end subroutine check_ecartint
10556 #else
10557 !-----------------------------------------------------------------------------
10558       subroutine check_ecartint
10559 ! Check the gradient of the energy in Cartesian coordinates.
10560       use io_base, only: intout
10561 !      implicit real*8 (a-h,o-z)
10562 !      include 'DIMENSIONS'
10563 !      include 'COMMON.CONTROL'
10564 !      include 'COMMON.CHAIN'
10565 !      include 'COMMON.DERIV'
10566 !      include 'COMMON.IOUNITS'
10567 !      include 'COMMON.VAR'
10568 !      include 'COMMON.CONTACTS'
10569 !      include 'COMMON.MD'
10570 !      include 'COMMON.LOCAL'
10571 !      include 'COMMON.SPLITELE'
10572       use comm_srutu
10573 !el      integer :: icall
10574 !el      common /srutu/ icall
10575       real(kind=8),dimension(6) :: ggg,ggg1
10576       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
10577       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
10578       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
10579       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
10580       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
10581       real(kind=8),dimension(0:n_ene) :: energia,energia1
10582       integer :: uiparm(1)
10583       real(kind=8) :: urparm(1)
10584 !EL      external fdum
10585       integer :: i,j,k,nf
10586       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
10587                    etot21,etot22
10588       r_cut=2.0d0
10589       rlambd=0.3d0
10590       icg=1
10591       nf=0
10592       nfl=0
10593       call intout
10594 !      call intcartderiv
10595 !      call checkintcartgrad
10596       call zerograd
10597       aincr=1.0D-6
10598       write(iout,*) 'Calling CHECK_ECARTINT.'
10599       nf=0
10600       icall=0
10601       call geom_to_var(nvar,x)
10602       if (.not.split_ene) then
10603         call etotal(energia)
10604         etot=energia(0)
10605 !el        call enerprint(energia)
10606         call flush(iout)
10607         write (iout,*) "enter cartgrad"
10608         call flush(iout)
10609         call cartgrad
10610         write (iout,*) "exit cartgrad"
10611         call flush(iout)
10612         icall =1
10613         do i=1,nres
10614           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
10615         enddo
10616         do j=1,3
10617           grad_s(j,0)=gcart(j,0)
10618         enddo
10619         do i=1,nres
10620           do j=1,3
10621             grad_s(j,i)=gcart(j,i)
10622             grad_s(j+3,i)=gxcart(j,i)
10623           enddo
10624         enddo
10625       else
10626 !- split gradient check
10627         call zerograd
10628         call etotal_long(energia)
10629 !el        call enerprint(energia)
10630         call flush(iout)
10631         write (iout,*) "enter cartgrad"
10632         call flush(iout)
10633         call cartgrad
10634         write (iout,*) "exit cartgrad"
10635         call flush(iout)
10636         icall =1
10637         write (iout,*) "longrange grad"
10638         do i=1,nres
10639           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10640           (gxcart(j,i),j=1,3)
10641         enddo
10642         do j=1,3
10643           grad_s(j,0)=gcart(j,0)
10644         enddo
10645         do i=1,nres
10646           do j=1,3
10647             grad_s(j,i)=gcart(j,i)
10648             grad_s(j+3,i)=gxcart(j,i)
10649           enddo
10650         enddo
10651         call zerograd
10652         call etotal_short(energia)
10653 !el        call enerprint(energia)
10654         call flush(iout)
10655         write (iout,*) "enter cartgrad"
10656         call flush(iout)
10657         call cartgrad
10658         write (iout,*) "exit cartgrad"
10659         call flush(iout)
10660         icall =1
10661         write (iout,*) "shortrange grad"
10662         do i=1,nres
10663           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
10664           (gxcart(j,i),j=1,3)
10665         enddo
10666         do j=1,3
10667           grad_s1(j,0)=gcart(j,0)
10668         enddo
10669         do i=1,nres
10670           do j=1,3
10671             grad_s1(j,i)=gcart(j,i)
10672             grad_s1(j+3,i)=gxcart(j,i)
10673           enddo
10674         enddo
10675       endif
10676       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
10677       do i=0,nres
10678         do j=1,3
10679           xx(j)=c(j,i+nres)
10680           ddc(j)=dc(j,i)
10681           ddx(j)=dc(j,i+nres)
10682           do k=1,3
10683             dcnorm_safe(k)=dc_norm(k,i)
10684             dxnorm_safe(k)=dc_norm(k,i+nres)
10685           enddo
10686         enddo
10687         do j=1,3
10688           dc(j,i)=ddc(j)+aincr
10689           call chainbuild_cart
10690 #ifdef MPI
10691 ! Broadcast the order to compute internal coordinates to the slaves.
10692 !          if (nfgtasks.gt.1)
10693 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
10694 #endif
10695 !          call int_from_cart1(.false.)
10696           if (.not.split_ene) then
10697             call etotal(energia1)
10698             etot1=energia1(0)
10699           else
10700 !- split gradient
10701             call etotal_long(energia1)
10702             etot11=energia1(0)
10703             call etotal_short(energia1)
10704             etot12=energia1(0)
10705 !            write (iout,*) "etot11",etot11," etot12",etot12
10706           endif
10707 !- end split gradient
10708 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10709           dc(j,i)=ddc(j)-aincr
10710           call chainbuild_cart
10711 !          call int_from_cart1(.false.)
10712           if (.not.split_ene) then
10713             call etotal(energia1)
10714             etot2=energia1(0)
10715             ggg(j)=(etot1-etot2)/(2*aincr)
10716           else
10717 !- split gradient
10718             call etotal_long(energia1)
10719             etot21=energia1(0)
10720             ggg(j)=(etot11-etot21)/(2*aincr)
10721             call etotal_short(energia1)
10722             etot22=energia1(0)
10723             ggg1(j)=(etot12-etot22)/(2*aincr)
10724 !- end split gradient
10725 !            write (iout,*) "etot21",etot21," etot22",etot22
10726           endif
10727 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10728           dc(j,i)=ddc(j)
10729           call chainbuild_cart
10730         enddo
10731         do j=1,3
10732           dc(j,i+nres)=ddx(j)+aincr
10733           call chainbuild_cart
10734 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
10735 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10736 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10737 !          write (iout,*) "dxnormnorm",dsqrt(
10738 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10739 !          write (iout,*) "dxnormnormsafe",dsqrt(
10740 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10741 !          write (iout,*)
10742           if (.not.split_ene) then
10743             call etotal(energia1)
10744             etot1=energia1(0)
10745           else
10746 !- split gradient
10747             call etotal_long(energia1)
10748             etot11=energia1(0)
10749             call etotal_short(energia1)
10750             etot12=energia1(0)
10751           endif
10752 !- end split gradient
10753 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
10754           dc(j,i+nres)=ddx(j)-aincr
10755           call chainbuild_cart
10756 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
10757 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
10758 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
10759 !          write (iout,*)
10760 !          write (iout,*) "dxnormnorm",dsqrt(
10761 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
10762 !          write (iout,*) "dxnormnormsafe",dsqrt(
10763 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
10764           if (.not.split_ene) then
10765             call etotal(energia1)
10766             etot2=energia1(0)
10767             ggg(j+3)=(etot1-etot2)/(2*aincr)
10768           else
10769 !- split gradient
10770             call etotal_long(energia1)
10771             etot21=energia1(0)
10772             ggg(j+3)=(etot11-etot21)/(2*aincr)
10773             call etotal_short(energia1)
10774             etot22=energia1(0)
10775             ggg1(j+3)=(etot12-etot22)/(2*aincr)
10776 !- end split gradient
10777           endif
10778 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
10779           dc(j,i+nres)=ddx(j)
10780           call chainbuild_cart
10781         enddo
10782         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10783          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
10784         if (split_ene) then
10785           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10786          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
10787          k=1,6)
10788          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
10789          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
10790          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
10791         endif
10792       enddo
10793       return
10794       end subroutine check_ecartint
10795 #endif
10796 !-----------------------------------------------------------------------------
10797       subroutine check_eint
10798 ! Check the gradient of energy in internal coordinates.
10799 !      implicit real*8 (a-h,o-z)
10800 !      include 'DIMENSIONS'
10801 !      include 'COMMON.CHAIN'
10802 !      include 'COMMON.DERIV'
10803 !      include 'COMMON.IOUNITS'
10804 !      include 'COMMON.VAR'
10805 !      include 'COMMON.GEO'
10806       use comm_srutu
10807 !el      integer :: icall
10808 !el      common /srutu/ icall
10809       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
10810       integer :: uiparm(1)
10811       real(kind=8) :: urparm(1)
10812       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
10813       character(len=6) :: key
10814 !EL      external fdum
10815       integer :: i,ii,nf
10816       real(kind=8) :: xi,aincr,etot,etot1,etot2
10817       call zerograd
10818       aincr=1.0D-7
10819       print '(a)','Calling CHECK_INT.'
10820       nf=0
10821       nfl=0
10822       icg=1
10823       call geom_to_var(nvar,x)
10824       call var_to_geom(nvar,x)
10825       call chainbuild
10826       icall=1
10827       print *,'ICG=',ICG
10828       call etotal(energia)
10829       etot = energia(0)
10830 !el      call enerprint(energia)
10831       print *,'ICG=',ICG
10832 #ifdef MPL
10833       if (MyID.ne.BossID) then
10834         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
10835         nf=x(nvar+1)
10836         nfl=x(nvar+2)
10837         icg=x(nvar+3)
10838       endif
10839 #endif
10840       nf=1
10841       nfl=3
10842 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
10843       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
10844 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
10845       icall=1
10846       do i=1,nvar
10847         xi=x(i)
10848         x(i)=xi-0.5D0*aincr
10849         call var_to_geom(nvar,x)
10850         call chainbuild
10851         call etotal(energia1)
10852         etot1=energia1(0)
10853         x(i)=xi+0.5D0*aincr
10854         call var_to_geom(nvar,x)
10855         call chainbuild
10856         call etotal(energia2)
10857         etot2=energia2(0)
10858         gg(i)=(etot2-etot1)/aincr
10859         write (iout,*) i,etot1,etot2
10860         x(i)=xi
10861       enddo
10862       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
10863           '     RelDiff*100% '
10864       do i=1,nvar
10865         if (i.le.nphi) then
10866           ii=i
10867           key = ' phi'
10868         else if (i.le.nphi+ntheta) then
10869           ii=i-nphi
10870           key=' theta'
10871         else if (i.le.nphi+ntheta+nside) then
10872            ii=i-(nphi+ntheta)
10873            key=' alpha'
10874         else
10875            ii=i-(nphi+ntheta+nside)
10876            key=' omega'
10877         endif
10878         write (iout,'(i3,a,i3,3(1pd16.6))') &
10879        i,key,ii,gg(i),gana(i),&
10880        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
10881       enddo
10882       return
10883       end subroutine check_eint
10884 !-----------------------------------------------------------------------------
10885 ! econstr_local.F
10886 !-----------------------------------------------------------------------------
10887       subroutine Econstr_back
10888 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
10889 !      implicit real*8 (a-h,o-z)
10890 !      include 'DIMENSIONS'
10891 !      include 'COMMON.CONTROL'
10892 !      include 'COMMON.VAR'
10893 !      include 'COMMON.MD'
10894       use MD_data
10895 !#ifndef LANG0
10896 !      include 'COMMON.LANGEVIN'
10897 !#else
10898 !      include 'COMMON.LANGEVIN.lang0'
10899 !#endif
10900 !      include 'COMMON.CHAIN'
10901 !      include 'COMMON.DERIV'
10902 !      include 'COMMON.GEO'
10903 !      include 'COMMON.LOCAL'
10904 !      include 'COMMON.INTERACT'
10905 !      include 'COMMON.IOUNITS'
10906 !      include 'COMMON.NAMES'
10907 !      include 'COMMON.TIME1'
10908       integer :: i,j,ii,k
10909       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
10910
10911       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
10912       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
10913       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
10914
10915       Uconst_back=0.0d0
10916       do i=1,nres
10917         dutheta(i)=0.0d0
10918         dugamma(i)=0.0d0
10919         do j=1,3
10920           duscdiff(j,i)=0.0d0
10921           duscdiffx(j,i)=0.0d0
10922         enddo
10923       enddo
10924       do i=1,nfrag_back
10925         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10926 !
10927 ! Deviations from theta angles
10928 !
10929         utheta_i=0.0d0
10930         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
10931           dtheta_i=theta(j)-thetaref(j)
10932           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
10933           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10934         enddo
10935         utheta(i)=utheta_i/(ii-1)
10936 !
10937 ! Deviations from gamma angles
10938 !
10939         ugamma_i=0.0d0
10940         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
10941           dgamma_i=pinorm(phi(j)-phiref(j))
10942 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
10943           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
10944           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
10945 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
10946         enddo
10947         ugamma(i)=ugamma_i/(ii-2)
10948 !
10949 ! Deviations from local SC geometry
10950 !
10951         uscdiff(i)=0.0d0
10952         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
10953           dxx=xxtab(j)-xxref(j)
10954           dyy=yytab(j)-yyref(j)
10955           dzz=zztab(j)-zzref(j)
10956           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
10957           do k=1,3
10958             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
10959              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
10960              (ii-1)
10961             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
10962              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
10963              (ii-1)
10964             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
10965            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
10966             /(ii-1)
10967           enddo
10968 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10969 !     &      xxref(j),yyref(j),zzref(j)
10970         enddo
10971         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
10972 !        write (iout,*) i," uscdiff",uscdiff(i)
10973 !
10974 ! Put together deviations from local geometry
10975 !
10976         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
10977           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
10978 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
10979 !     &   " uconst_back",uconst_back
10980         utheta(i)=dsqrt(utheta(i))
10981         ugamma(i)=dsqrt(ugamma(i))
10982         uscdiff(i)=dsqrt(uscdiff(i))
10983       enddo
10984       return
10985       end subroutine Econstr_back
10986 !-----------------------------------------------------------------------------
10987 ! energy_p_new-sep_barrier.F
10988 !-----------------------------------------------------------------------------
10989       real(kind=8) function sscale(r)
10990 !      include "COMMON.SPLITELE"
10991       real(kind=8) :: r,gamm
10992       if(r.lt.r_cut-rlamb) then
10993         sscale=1.0d0
10994       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10995         gamm=(r-(r_cut-rlamb))/rlamb
10996         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10997       else
10998         sscale=0d0
10999       endif
11000       return
11001       end function sscale
11002       real(kind=8) function sscale_grad(r)
11003 !      include "COMMON.SPLITELE"
11004       real(kind=8) :: r,gamm
11005       if(r.lt.r_cut-rlamb) then
11006         sscale_grad=0.0d0
11007       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11008         gamm=(r-(r_cut-rlamb))/rlamb
11009         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11010       else
11011         sscale_grad=0d0
11012       endif
11013       return
11014       end function sscale_grad
11015
11016 !!!!!!!!!! PBCSCALE
11017       real(kind=8) function sscale_ele(r)
11018 !      include "COMMON.SPLITELE"
11019       real(kind=8) :: r,gamm
11020       if(r.lt.r_cut_ele-rlamb_ele) then
11021         sscale_ele=1.0d0
11022       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11023         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11024         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11025       else
11026         sscale_ele=0d0
11027       endif
11028       return
11029       end function sscale_ele
11030
11031       real(kind=8)  function sscagrad_ele(r)
11032       real(kind=8) :: r,gamm
11033 !      include "COMMON.SPLITELE"
11034       if(r.lt.r_cut_ele-rlamb_ele) then
11035         sscagrad_ele=0.0d0
11036       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11037         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11038         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11039       else
11040         sscagrad_ele=0.0d0
11041       endif
11042       return
11043       end function sscagrad_ele
11044 !!!!!!!!!!!!!!!
11045 !-----------------------------------------------------------------------------
11046       subroutine elj_long(evdw)
11047 !
11048 ! This subroutine calculates the interaction energy of nonbonded side chains
11049 ! assuming the LJ potential of interaction.
11050 !
11051 !      implicit real*8 (a-h,o-z)
11052 !      include 'DIMENSIONS'
11053 !      include 'COMMON.GEO'
11054 !      include 'COMMON.VAR'
11055 !      include 'COMMON.LOCAL'
11056 !      include 'COMMON.CHAIN'
11057 !      include 'COMMON.DERIV'
11058 !      include 'COMMON.INTERACT'
11059 !      include 'COMMON.TORSION'
11060 !      include 'COMMON.SBRIDGE'
11061 !      include 'COMMON.NAMES'
11062 !      include 'COMMON.IOUNITS'
11063 !      include 'COMMON.CONTACTS'
11064       real(kind=8),parameter :: accur=1.0d-10
11065       real(kind=8),dimension(3) :: gg
11066 !el local variables
11067       integer :: i,iint,j,k,itypi,itypi1,itypj
11068       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11069       real(kind=8) :: e1,e2,evdwij,evdw
11070 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11071       evdw=0.0D0
11072       do i=iatsc_s,iatsc_e
11073         itypi=itype(i)
11074         if (itypi.eq.ntyp1) cycle
11075         itypi1=itype(i+1)
11076         xi=c(1,nres+i)
11077         yi=c(2,nres+i)
11078         zi=c(3,nres+i)
11079 !
11080 ! Calculate SC interaction energy.
11081 !
11082         do iint=1,nint_gr(i)
11083 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11084 !d   &                  'iend=',iend(i,iint)
11085           do j=istart(i,iint),iend(i,iint)
11086             itypj=itype(j)
11087             if (itypj.eq.ntyp1) cycle
11088             xj=c(1,nres+j)-xi
11089             yj=c(2,nres+j)-yi
11090             zj=c(3,nres+j)-zi
11091             rij=xj*xj+yj*yj+zj*zj
11092             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11093             if (sss.lt.1.0d0) then
11094               rrij=1.0D0/rij
11095               eps0ij=eps(itypi,itypj)
11096               fac=rrij**expon2
11097               e1=fac*fac*aa(itypi,itypj)
11098               e2=fac*bb(itypi,itypj)
11099               evdwij=e1+e2
11100               evdw=evdw+(1.0d0-sss)*evdwij
11101 !
11102 ! Calculate the components of the gradient in DC and X
11103 !
11104               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
11105               gg(1)=xj*fac
11106               gg(2)=yj*fac
11107               gg(3)=zj*fac
11108               do k=1,3
11109                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11110                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11111                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11112                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11113               enddo
11114             endif
11115           enddo      ! j
11116         enddo        ! iint
11117       enddo          ! i
11118       do i=1,nct
11119         do j=1,3
11120           gvdwc(j,i)=expon*gvdwc(j,i)
11121           gvdwx(j,i)=expon*gvdwx(j,i)
11122         enddo
11123       enddo
11124 !******************************************************************************
11125 !
11126 !                              N O T E !!!
11127 !
11128 ! To save time, the factor of EXPON has been extracted from ALL components
11129 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11130 ! use!
11131 !
11132 !******************************************************************************
11133       return
11134       end subroutine elj_long
11135 !-----------------------------------------------------------------------------
11136       subroutine elj_short(evdw)
11137 !
11138 ! This subroutine calculates the interaction energy of nonbonded side chains
11139 ! assuming the LJ potential of interaction.
11140 !
11141 !      implicit real*8 (a-h,o-z)
11142 !      include 'DIMENSIONS'
11143 !      include 'COMMON.GEO'
11144 !      include 'COMMON.VAR'
11145 !      include 'COMMON.LOCAL'
11146 !      include 'COMMON.CHAIN'
11147 !      include 'COMMON.DERIV'
11148 !      include 'COMMON.INTERACT'
11149 !      include 'COMMON.TORSION'
11150 !      include 'COMMON.SBRIDGE'
11151 !      include 'COMMON.NAMES'
11152 !      include 'COMMON.IOUNITS'
11153 !      include 'COMMON.CONTACTS'
11154       real(kind=8),parameter :: accur=1.0d-10
11155       real(kind=8),dimension(3) :: gg
11156 !el local variables
11157       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
11158       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
11159       real(kind=8) :: e1,e2,evdwij,evdw
11160 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
11161       evdw=0.0D0
11162       do i=iatsc_s,iatsc_e
11163         itypi=itype(i)
11164         if (itypi.eq.ntyp1) cycle
11165         itypi1=itype(i+1)
11166         xi=c(1,nres+i)
11167         yi=c(2,nres+i)
11168         zi=c(3,nres+i)
11169 ! Change 12/1/95
11170         num_conti=0
11171 !
11172 ! Calculate SC interaction energy.
11173 !
11174         do iint=1,nint_gr(i)
11175 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
11176 !d   &                  'iend=',iend(i,iint)
11177           do j=istart(i,iint),iend(i,iint)
11178             itypj=itype(j)
11179             if (itypj.eq.ntyp1) cycle
11180             xj=c(1,nres+j)-xi
11181             yj=c(2,nres+j)-yi
11182             zj=c(3,nres+j)-zi
11183 ! Change 12/1/95 to calculate four-body interactions
11184             rij=xj*xj+yj*yj+zj*zj
11185             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
11186             if (sss.gt.0.0d0) then
11187               rrij=1.0D0/rij
11188               eps0ij=eps(itypi,itypj)
11189               fac=rrij**expon2
11190               e1=fac*fac*aa(itypi,itypj)
11191               e2=fac*bb(itypi,itypj)
11192               evdwij=e1+e2
11193               evdw=evdw+sss*evdwij
11194 !
11195 ! Calculate the components of the gradient in DC and X
11196 !
11197               fac=-rrij*(e1+evdwij)*sss
11198               gg(1)=xj*fac
11199               gg(2)=yj*fac
11200               gg(3)=zj*fac
11201               do k=1,3
11202                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11203                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11204                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11205                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11206               enddo
11207             endif
11208           enddo      ! j
11209         enddo        ! iint
11210       enddo          ! i
11211       do i=1,nct
11212         do j=1,3
11213           gvdwc(j,i)=expon*gvdwc(j,i)
11214           gvdwx(j,i)=expon*gvdwx(j,i)
11215         enddo
11216       enddo
11217 !******************************************************************************
11218 !
11219 !                              N O T E !!!
11220 !
11221 ! To save time, the factor of EXPON has been extracted from ALL components
11222 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
11223 ! use!
11224 !
11225 !******************************************************************************
11226       return
11227       end subroutine elj_short
11228 !-----------------------------------------------------------------------------
11229       subroutine eljk_long(evdw)
11230 !
11231 ! This subroutine calculates the interaction energy of nonbonded side chains
11232 ! assuming the LJK potential of interaction.
11233 !
11234 !      implicit real*8 (a-h,o-z)
11235 !      include 'DIMENSIONS'
11236 !      include 'COMMON.GEO'
11237 !      include 'COMMON.VAR'
11238 !      include 'COMMON.LOCAL'
11239 !      include 'COMMON.CHAIN'
11240 !      include 'COMMON.DERIV'
11241 !      include 'COMMON.INTERACT'
11242 !      include 'COMMON.IOUNITS'
11243 !      include 'COMMON.NAMES'
11244       real(kind=8),dimension(3) :: gg
11245       logical :: scheck
11246 !el local variables
11247       integer :: i,iint,j,k,itypi,itypi1,itypj
11248       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11249                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11250 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11251       evdw=0.0D0
11252       do i=iatsc_s,iatsc_e
11253         itypi=itype(i)
11254         if (itypi.eq.ntyp1) cycle
11255         itypi1=itype(i+1)
11256         xi=c(1,nres+i)
11257         yi=c(2,nres+i)
11258         zi=c(3,nres+i)
11259 !
11260 ! Calculate SC interaction energy.
11261 !
11262         do iint=1,nint_gr(i)
11263           do j=istart(i,iint),iend(i,iint)
11264             itypj=itype(j)
11265             if (itypj.eq.ntyp1) cycle
11266             xj=c(1,nres+j)-xi
11267             yj=c(2,nres+j)-yi
11268             zj=c(3,nres+j)-zi
11269             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11270             fac_augm=rrij**expon
11271             e_augm=augm(itypi,itypj)*fac_augm
11272             r_inv_ij=dsqrt(rrij)
11273             rij=1.0D0/r_inv_ij
11274             sss=sscale(rij/sigma(itypi,itypj))
11275             if (sss.lt.1.0d0) then
11276               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11277               fac=r_shift_inv**expon
11278               e1=fac*fac*aa(itypi,itypj)
11279               e2=fac*bb(itypi,itypj)
11280               evdwij=e_augm+e1+e2
11281 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11282 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11283 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11284 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11285 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11286 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11287 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11288               evdw=evdw+(1.0d0-sss)*evdwij
11289 !
11290 ! Calculate the components of the gradient in DC and X
11291 !
11292               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11293               fac=fac*(1.0d0-sss)
11294               gg(1)=xj*fac
11295               gg(2)=yj*fac
11296               gg(3)=zj*fac
11297               do k=1,3
11298                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11299                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11300                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11301                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11302               enddo
11303             endif
11304           enddo      ! j
11305         enddo        ! iint
11306       enddo          ! i
11307       do i=1,nct
11308         do j=1,3
11309           gvdwc(j,i)=expon*gvdwc(j,i)
11310           gvdwx(j,i)=expon*gvdwx(j,i)
11311         enddo
11312       enddo
11313       return
11314       end subroutine eljk_long
11315 !-----------------------------------------------------------------------------
11316       subroutine eljk_short(evdw)
11317 !
11318 ! This subroutine calculates the interaction energy of nonbonded side chains
11319 ! assuming the LJK potential of interaction.
11320 !
11321 !      implicit real*8 (a-h,o-z)
11322 !      include 'DIMENSIONS'
11323 !      include 'COMMON.GEO'
11324 !      include 'COMMON.VAR'
11325 !      include 'COMMON.LOCAL'
11326 !      include 'COMMON.CHAIN'
11327 !      include 'COMMON.DERIV'
11328 !      include 'COMMON.INTERACT'
11329 !      include 'COMMON.IOUNITS'
11330 !      include 'COMMON.NAMES'
11331       real(kind=8),dimension(3) :: gg
11332       logical :: scheck
11333 !el local variables
11334       integer :: i,iint,j,k,itypi,itypi1,itypj
11335       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
11336                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
11337 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
11338       evdw=0.0D0
11339       do i=iatsc_s,iatsc_e
11340         itypi=itype(i)
11341         if (itypi.eq.ntyp1) cycle
11342         itypi1=itype(i+1)
11343         xi=c(1,nres+i)
11344         yi=c(2,nres+i)
11345         zi=c(3,nres+i)
11346 !
11347 ! Calculate SC interaction energy.
11348 !
11349         do iint=1,nint_gr(i)
11350           do j=istart(i,iint),iend(i,iint)
11351             itypj=itype(j)
11352             if (itypj.eq.ntyp1) cycle
11353             xj=c(1,nres+j)-xi
11354             yj=c(2,nres+j)-yi
11355             zj=c(3,nres+j)-zi
11356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11357             fac_augm=rrij**expon
11358             e_augm=augm(itypi,itypj)*fac_augm
11359             r_inv_ij=dsqrt(rrij)
11360             rij=1.0D0/r_inv_ij
11361             sss=sscale(rij/sigma(itypi,itypj))
11362             if (sss.gt.0.0d0) then
11363               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
11364               fac=r_shift_inv**expon
11365               e1=fac*fac*aa(itypi,itypj)
11366               e2=fac*bb(itypi,itypj)
11367               evdwij=e_augm+e1+e2
11368 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11369 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11370 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
11371 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
11372 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
11373 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
11374 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
11375               evdw=evdw+sss*evdwij
11376 !
11377 ! Calculate the components of the gradient in DC and X
11378 !
11379               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
11380               fac=fac*sss
11381               gg(1)=xj*fac
11382               gg(2)=yj*fac
11383               gg(3)=zj*fac
11384               do k=1,3
11385                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
11386                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
11387                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
11388                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
11389               enddo
11390             endif
11391           enddo      ! j
11392         enddo        ! iint
11393       enddo          ! i
11394       do i=1,nct
11395         do j=1,3
11396           gvdwc(j,i)=expon*gvdwc(j,i)
11397           gvdwx(j,i)=expon*gvdwx(j,i)
11398         enddo
11399       enddo
11400       return
11401       end subroutine eljk_short
11402 !-----------------------------------------------------------------------------
11403       subroutine ebp_long(evdw)
11404 !
11405 ! This subroutine calculates the interaction energy of nonbonded side chains
11406 ! assuming the Berne-Pechukas potential of interaction.
11407 !
11408       use calc_data
11409 !      implicit real*8 (a-h,o-z)
11410 !      include 'DIMENSIONS'
11411 !      include 'COMMON.GEO'
11412 !      include 'COMMON.VAR'
11413 !      include 'COMMON.LOCAL'
11414 !      include 'COMMON.CHAIN'
11415 !      include 'COMMON.DERIV'
11416 !      include 'COMMON.NAMES'
11417 !      include 'COMMON.INTERACT'
11418 !      include 'COMMON.IOUNITS'
11419 !      include 'COMMON.CALC'
11420       use comm_srutu
11421 !el      integer :: icall
11422 !el      common /srutu/ icall
11423 !     double precision rrsave(maxdim)
11424       logical :: lprn
11425 !el local variables
11426       integer :: iint,itypi,itypi1,itypj
11427       real(kind=8) :: rrij,xi,yi,zi,fac
11428       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
11429       evdw=0.0D0
11430 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11431       evdw=0.0D0
11432 !     if (icall.eq.0) then
11433 !       lprn=.true.
11434 !     else
11435         lprn=.false.
11436 !     endif
11437 !el      ind=0
11438       do i=iatsc_s,iatsc_e
11439         itypi=itype(i)
11440         if (itypi.eq.ntyp1) cycle
11441         itypi1=itype(i+1)
11442         xi=c(1,nres+i)
11443         yi=c(2,nres+i)
11444         zi=c(3,nres+i)
11445         dxi=dc_norm(1,nres+i)
11446         dyi=dc_norm(2,nres+i)
11447         dzi=dc_norm(3,nres+i)
11448 !        dsci_inv=dsc_inv(itypi)
11449         dsci_inv=vbld_inv(i+nres)
11450 !
11451 ! Calculate SC interaction energy.
11452 !
11453         do iint=1,nint_gr(i)
11454           do j=istart(i,iint),iend(i,iint)
11455 !el            ind=ind+1
11456             itypj=itype(j)
11457             if (itypj.eq.ntyp1) cycle
11458 !            dscj_inv=dsc_inv(itypj)
11459             dscj_inv=vbld_inv(j+nres)
11460             chi1=chi(itypi,itypj)
11461             chi2=chi(itypj,itypi)
11462             chi12=chi1*chi2
11463             chip1=chip(itypi)
11464             chip2=chip(itypj)
11465             chip12=chip1*chip2
11466             alf1=alp(itypi)
11467             alf2=alp(itypj)
11468             alf12=0.5D0*(alf1+alf2)
11469             xj=c(1,nres+j)-xi
11470             yj=c(2,nres+j)-yi
11471             zj=c(3,nres+j)-zi
11472             dxj=dc_norm(1,nres+j)
11473             dyj=dc_norm(2,nres+j)
11474             dzj=dc_norm(3,nres+j)
11475             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11476             rij=dsqrt(rrij)
11477             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11478
11479             if (sss.lt.1.0d0) then
11480
11481 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11482               call sc_angular
11483 ! Calculate whole angle-dependent part of epsilon and contributions
11484 ! to its derivatives
11485               fac=(rrij*sigsq)**expon2
11486               e1=fac*fac*aa(itypi,itypj)
11487               e2=fac*bb(itypi,itypj)
11488               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11489               eps2der=evdwij*eps3rt
11490               eps3der=evdwij*eps2rt
11491               evdwij=evdwij*eps2rt*eps3rt
11492               evdw=evdw+evdwij*(1.0d0-sss)
11493               if (lprn) then
11494               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11495               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11496 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11497 !d     &          restyp(itypi),i,restyp(itypj),j,
11498 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11499 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11500 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11501 !d     &          evdwij
11502               endif
11503 ! Calculate gradient components.
11504               e1=e1*eps1*eps2rt**2*eps3rt**2
11505               fac=-expon*(e1+evdwij)
11506               sigder=fac/sigsq
11507               fac=rrij*fac
11508 ! Calculate radial part of the gradient
11509               gg(1)=xj*fac
11510               gg(2)=yj*fac
11511               gg(3)=zj*fac
11512 ! Calculate the angular part of the gradient and sum add the contributions
11513 ! to the appropriate components of the Cartesian gradient.
11514               call sc_grad_scale(1.0d0-sss)
11515             endif
11516           enddo      ! j
11517         enddo        ! iint
11518       enddo          ! i
11519 !     stop
11520       return
11521       end subroutine ebp_long
11522 !-----------------------------------------------------------------------------
11523       subroutine ebp_short(evdw)
11524 !
11525 ! This subroutine calculates the interaction energy of nonbonded side chains
11526 ! assuming the Berne-Pechukas potential of interaction.
11527 !
11528       use calc_data
11529 !      implicit real*8 (a-h,o-z)
11530 !      include 'DIMENSIONS'
11531 !      include 'COMMON.GEO'
11532 !      include 'COMMON.VAR'
11533 !      include 'COMMON.LOCAL'
11534 !      include 'COMMON.CHAIN'
11535 !      include 'COMMON.DERIV'
11536 !      include 'COMMON.NAMES'
11537 !      include 'COMMON.INTERACT'
11538 !      include 'COMMON.IOUNITS'
11539 !      include 'COMMON.CALC'
11540       use comm_srutu
11541 !el      integer :: icall
11542 !el      common /srutu/ icall
11543 !     double precision rrsave(maxdim)
11544       logical :: lprn
11545 !el local variables
11546       integer :: iint,itypi,itypi1,itypj
11547       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
11548       real(kind=8) :: sss,e1,e2,evdw
11549       evdw=0.0D0
11550 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
11551       evdw=0.0D0
11552 !     if (icall.eq.0) then
11553 !       lprn=.true.
11554 !     else
11555         lprn=.false.
11556 !     endif
11557 !el      ind=0
11558       do i=iatsc_s,iatsc_e
11559         itypi=itype(i)
11560         if (itypi.eq.ntyp1) cycle
11561         itypi1=itype(i+1)
11562         xi=c(1,nres+i)
11563         yi=c(2,nres+i)
11564         zi=c(3,nres+i)
11565         dxi=dc_norm(1,nres+i)
11566         dyi=dc_norm(2,nres+i)
11567         dzi=dc_norm(3,nres+i)
11568 !        dsci_inv=dsc_inv(itypi)
11569         dsci_inv=vbld_inv(i+nres)
11570 !
11571 ! Calculate SC interaction energy.
11572 !
11573         do iint=1,nint_gr(i)
11574           do j=istart(i,iint),iend(i,iint)
11575 !el            ind=ind+1
11576             itypj=itype(j)
11577             if (itypj.eq.ntyp1) cycle
11578 !            dscj_inv=dsc_inv(itypj)
11579             dscj_inv=vbld_inv(j+nres)
11580             chi1=chi(itypi,itypj)
11581             chi2=chi(itypj,itypi)
11582             chi12=chi1*chi2
11583             chip1=chip(itypi)
11584             chip2=chip(itypj)
11585             chip12=chip1*chip2
11586             alf1=alp(itypi)
11587             alf2=alp(itypj)
11588             alf12=0.5D0*(alf1+alf2)
11589             xj=c(1,nres+j)-xi
11590             yj=c(2,nres+j)-yi
11591             zj=c(3,nres+j)-zi
11592             dxj=dc_norm(1,nres+j)
11593             dyj=dc_norm(2,nres+j)
11594             dzj=dc_norm(3,nres+j)
11595             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11596             rij=dsqrt(rrij)
11597             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11598
11599             if (sss.gt.0.0d0) then
11600
11601 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
11602               call sc_angular
11603 ! Calculate whole angle-dependent part of epsilon and contributions
11604 ! to its derivatives
11605               fac=(rrij*sigsq)**expon2
11606               e1=fac*fac*aa(itypi,itypj)
11607               e2=fac*bb(itypi,itypj)
11608               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11609               eps2der=evdwij*eps3rt
11610               eps3der=evdwij*eps2rt
11611               evdwij=evdwij*eps2rt*eps3rt
11612               evdw=evdw+evdwij*sss
11613               if (lprn) then
11614               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11615               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11616 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
11617 !d     &          restyp(itypi),i,restyp(itypj),j,
11618 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
11619 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
11620 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
11621 !d     &          evdwij
11622               endif
11623 ! Calculate gradient components.
11624               e1=e1*eps1*eps2rt**2*eps3rt**2
11625               fac=-expon*(e1+evdwij)
11626               sigder=fac/sigsq
11627               fac=rrij*fac
11628 ! Calculate radial part of the gradient
11629               gg(1)=xj*fac
11630               gg(2)=yj*fac
11631               gg(3)=zj*fac
11632 ! Calculate the angular part of the gradient and sum add the contributions
11633 ! to the appropriate components of the Cartesian gradient.
11634               call sc_grad_scale(sss)
11635             endif
11636           enddo      ! j
11637         enddo        ! iint
11638       enddo          ! i
11639 !     stop
11640       return
11641       end subroutine ebp_short
11642 !-----------------------------------------------------------------------------
11643       subroutine egb_long(evdw)
11644 !
11645 ! This subroutine calculates the interaction energy of nonbonded side chains
11646 ! assuming the Gay-Berne potential of interaction.
11647 !
11648       use calc_data
11649 !      implicit real*8 (a-h,o-z)
11650 !      include 'DIMENSIONS'
11651 !      include 'COMMON.GEO'
11652 !      include 'COMMON.VAR'
11653 !      include 'COMMON.LOCAL'
11654 !      include 'COMMON.CHAIN'
11655 !      include 'COMMON.DERIV'
11656 !      include 'COMMON.NAMES'
11657 !      include 'COMMON.INTERACT'
11658 !      include 'COMMON.IOUNITS'
11659 !      include 'COMMON.CALC'
11660 !      include 'COMMON.CONTROL'
11661       logical :: lprn
11662 !el local variables
11663       integer :: iint,itypi,itypi1,itypj,subchap
11664       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
11665       real(kind=8) :: sss,e1,e2,evdw,sss_grad
11666       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11667                     dist_temp, dist_init
11668
11669       evdw=0.0D0
11670 !cccc      energy_dec=.false.
11671 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11672       evdw=0.0D0
11673       lprn=.false.
11674 !     if (icall.eq.0) lprn=.false.
11675 !el      ind=0
11676       do i=iatsc_s,iatsc_e
11677         itypi=itype(i)
11678         if (itypi.eq.ntyp1) cycle
11679         itypi1=itype(i+1)
11680         xi=c(1,nres+i)
11681         yi=c(2,nres+i)
11682         zi=c(3,nres+i)
11683           xi=mod(xi,boxxsize)
11684           if (xi.lt.0) xi=xi+boxxsize
11685           yi=mod(yi,boxysize)
11686           if (yi.lt.0) yi=yi+boxysize
11687           zi=mod(zi,boxzsize)
11688           if (zi.lt.0) zi=zi+boxzsize
11689         dxi=dc_norm(1,nres+i)
11690         dyi=dc_norm(2,nres+i)
11691         dzi=dc_norm(3,nres+i)
11692 !        dsci_inv=dsc_inv(itypi)
11693         dsci_inv=vbld_inv(i+nres)
11694 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11695 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11696 !
11697 ! Calculate SC interaction energy.
11698 !
11699         do iint=1,nint_gr(i)
11700           do j=istart(i,iint),iend(i,iint)
11701 !el            ind=ind+1
11702             itypj=itype(j)
11703             if (itypj.eq.ntyp1) cycle
11704 !            dscj_inv=dsc_inv(itypj)
11705             dscj_inv=vbld_inv(j+nres)
11706 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11707 !     &       1.0d0/vbld(j+nres)
11708 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11709             sig0ij=sigma(itypi,itypj)
11710             chi1=chi(itypi,itypj)
11711             chi2=chi(itypj,itypi)
11712             chi12=chi1*chi2
11713             chip1=chip(itypi)
11714             chip2=chip(itypj)
11715             chip12=chip1*chip2
11716             alf1=alp(itypi)
11717             alf2=alp(itypj)
11718             alf12=0.5D0*(alf1+alf2)
11719             xj=c(1,nres+j)
11720             yj=c(2,nres+j)
11721             zj=c(3,nres+j)
11722 ! Searching for nearest neighbour
11723           xj=mod(xj,boxxsize)
11724           if (xj.lt.0) xj=xj+boxxsize
11725           yj=mod(yj,boxysize)
11726           if (yj.lt.0) yj=yj+boxysize
11727           zj=mod(zj,boxzsize)
11728           if (zj.lt.0) zj=zj+boxzsize
11729           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11730           xj_safe=xj
11731           yj_safe=yj
11732           zj_safe=zj
11733           subchap=0
11734           do xshift=-1,1
11735           do yshift=-1,1
11736           do zshift=-1,1
11737           xj=xj_safe+xshift*boxxsize
11738           yj=yj_safe+yshift*boxysize
11739           zj=zj_safe+zshift*boxzsize
11740           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11741           if(dist_temp.lt.dist_init) then
11742             dist_init=dist_temp
11743             xj_temp=xj
11744             yj_temp=yj
11745             zj_temp=zj
11746             subchap=1
11747           endif
11748           enddo
11749           enddo
11750           enddo
11751           if (subchap.eq.1) then
11752           xj=xj_temp-xi
11753           yj=yj_temp-yi
11754           zj=zj_temp-zi
11755           else
11756           xj=xj_safe-xi
11757           yj=yj_safe-yi
11758           zj=zj_safe-zi
11759           endif
11760
11761             dxj=dc_norm(1,nres+j)
11762             dyj=dc_norm(2,nres+j)
11763             dzj=dc_norm(3,nres+j)
11764             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11765             rij=dsqrt(rrij)
11766             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11767             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11768             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11769             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11770             if (sss_ele_cut.le.0.0) cycle
11771             if (sss.lt.1.0d0) then
11772
11773 ! Calculate angle-dependent terms of energy and contributions to their
11774 ! derivatives.
11775               call sc_angular
11776               sigsq=1.0D0/sigsq
11777               sig=sig0ij*dsqrt(sigsq)
11778               rij_shift=1.0D0/rij-sig+sig0ij
11779 ! for diagnostics; uncomment
11780 !              rij_shift=1.2*sig0ij
11781 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11782               if (rij_shift.le.0.0D0) then
11783                 evdw=1.0D20
11784 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11785 !d     &          restyp(itypi),i,restyp(itypj),j,
11786 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11787                 return
11788               endif
11789               sigder=-sig*sigsq
11790 !---------------------------------------------------------------
11791               rij_shift=1.0D0/rij_shift
11792               fac=rij_shift**expon
11793               e1=fac*fac*aa(itypi,itypj)
11794               e2=fac*bb(itypi,itypj)
11795               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
11796               eps2der=evdwij*eps3rt
11797               eps3der=evdwij*eps2rt
11798 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
11799 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
11800               evdwij=evdwij*eps2rt*eps3rt
11801               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
11802               if (lprn) then
11803               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
11804               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
11805               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
11806                 restyp(itypi),i,restyp(itypj),j,&
11807                 epsi,sigm,chi1,chi2,chip1,chip2,&
11808                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
11809                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
11810                 evdwij
11811               endif
11812
11813               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
11814                               'evdw',i,j,evdwij
11815 !              if (energy_dec) write (iout,*) &
11816 !                              'evdw',i,j,evdwij,"egb_long"
11817
11818 ! Calculate gradient components.
11819               e1=e1*eps1*eps2rt**2*eps3rt**2
11820               fac=-expon*(e1+evdwij)*rij_shift
11821               sigder=fac*sigder
11822               fac=rij*fac
11823               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
11824             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
11825             /sigmaii(itypi,itypj))
11826 !              fac=0.0d0
11827 ! Calculate the radial part of the gradient
11828               gg(1)=xj*fac
11829               gg(2)=yj*fac
11830               gg(3)=zj*fac
11831 ! Calculate angular part of the gradient.
11832               call sc_grad_scale(1.0d0-sss)
11833             endif
11834           enddo      ! j
11835         enddo        ! iint
11836       enddo          ! i
11837 !      write (iout,*) "Number of loop steps in EGB:",ind
11838 !ccc      energy_dec=.false.
11839       return
11840       end subroutine egb_long
11841 !-----------------------------------------------------------------------------
11842       subroutine egb_short(evdw)
11843 !
11844 ! This subroutine calculates the interaction energy of nonbonded side chains
11845 ! assuming the Gay-Berne potential of interaction.
11846 !
11847       use calc_data
11848 !      implicit real*8 (a-h,o-z)
11849 !      include 'DIMENSIONS'
11850 !      include 'COMMON.GEO'
11851 !      include 'COMMON.VAR'
11852 !      include 'COMMON.LOCAL'
11853 !      include 'COMMON.CHAIN'
11854 !      include 'COMMON.DERIV'
11855 !      include 'COMMON.NAMES'
11856 !      include 'COMMON.INTERACT'
11857 !      include 'COMMON.IOUNITS'
11858 !      include 'COMMON.CALC'
11859 !      include 'COMMON.CONTROL'
11860       logical :: lprn
11861 !el local variables
11862       integer :: iint,itypi,itypi1,itypj,subchap
11863       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
11864       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
11865       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
11866                     dist_temp, dist_init
11867       evdw=0.0D0
11868 !cccc      energy_dec=.false.
11869 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
11870       evdw=0.0D0
11871       lprn=.false.
11872 !     if (icall.eq.0) lprn=.false.
11873 !el      ind=0
11874       do i=iatsc_s,iatsc_e
11875         itypi=itype(i)
11876         if (itypi.eq.ntyp1) cycle
11877         itypi1=itype(i+1)
11878         xi=c(1,nres+i)
11879         yi=c(2,nres+i)
11880         zi=c(3,nres+i)
11881           xi=mod(xi,boxxsize)
11882           if (xi.lt.0) xi=xi+boxxsize
11883           yi=mod(yi,boxysize)
11884           if (yi.lt.0) yi=yi+boxysize
11885           zi=mod(zi,boxzsize)
11886           if (zi.lt.0) zi=zi+boxzsize
11887         dxi=dc_norm(1,nres+i)
11888         dyi=dc_norm(2,nres+i)
11889         dzi=dc_norm(3,nres+i)
11890 !        dsci_inv=dsc_inv(itypi)
11891         dsci_inv=vbld_inv(i+nres)
11892
11893         dxi=dc_norm(1,nres+i)
11894         dyi=dc_norm(2,nres+i)
11895         dzi=dc_norm(3,nres+i)
11896 !        dsci_inv=dsc_inv(itypi)
11897         dsci_inv=vbld_inv(i+nres)
11898 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
11899 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
11900 !
11901 ! Calculate SC interaction energy.
11902 !
11903         do iint=1,nint_gr(i)
11904           do j=istart(i,iint),iend(i,iint)
11905 !el            ind=ind+1
11906             itypj=itype(j)
11907             if (itypj.eq.ntyp1) cycle
11908 !            dscj_inv=dsc_inv(itypj)
11909             dscj_inv=vbld_inv(j+nres)
11910 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
11911 !     &       1.0d0/vbld(j+nres)
11912 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
11913             sig0ij=sigma(itypi,itypj)
11914             chi1=chi(itypi,itypj)
11915             chi2=chi(itypj,itypi)
11916             chi12=chi1*chi2
11917             chip1=chip(itypi)
11918             chip2=chip(itypj)
11919             chip12=chip1*chip2
11920             alf1=alp(itypi)
11921             alf2=alp(itypj)
11922             alf12=0.5D0*(alf1+alf2)
11923 !            xj=c(1,nres+j)-xi
11924 !            yj=c(2,nres+j)-yi
11925 !            zj=c(3,nres+j)-zi
11926             xj=c(1,nres+j)
11927             yj=c(2,nres+j)
11928             zj=c(3,nres+j)
11929 ! Searching for nearest neighbour
11930           xj=mod(xj,boxxsize)
11931           if (xj.lt.0) xj=xj+boxxsize
11932           yj=mod(yj,boxysize)
11933           if (yj.lt.0) yj=yj+boxysize
11934           zj=mod(zj,boxzsize)
11935           if (zj.lt.0) zj=zj+boxzsize
11936           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11937           xj_safe=xj
11938           yj_safe=yj
11939           zj_safe=zj
11940           subchap=0
11941           do xshift=-1,1
11942           do yshift=-1,1
11943           do zshift=-1,1
11944           xj=xj_safe+xshift*boxxsize
11945           yj=yj_safe+yshift*boxysize
11946           zj=zj_safe+zshift*boxzsize
11947           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
11948           if(dist_temp.lt.dist_init) then
11949             dist_init=dist_temp
11950             xj_temp=xj
11951             yj_temp=yj
11952             zj_temp=zj
11953             subchap=1
11954           endif
11955           enddo
11956           enddo
11957           enddo
11958           if (subchap.eq.1) then
11959           xj=xj_temp-xi
11960           yj=yj_temp-yi
11961           zj=zj_temp-zi
11962           else
11963           xj=xj_safe-xi
11964           yj=yj_safe-yi
11965           zj=zj_safe-zi
11966           endif
11967
11968             dxj=dc_norm(1,nres+j)
11969             dyj=dc_norm(2,nres+j)
11970             dzj=dc_norm(3,nres+j)
11971             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
11972             rij=dsqrt(rrij)
11973             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
11974             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
11975             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
11976             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
11977             if (sss_ele_cut.le.0.0) cycle
11978
11979             if (sss.gt.0.0d0) then
11980
11981 ! Calculate angle-dependent terms of energy and contributions to their
11982 ! derivatives.
11983               call sc_angular
11984               sigsq=1.0D0/sigsq
11985               sig=sig0ij*dsqrt(sigsq)
11986               rij_shift=1.0D0/rij-sig+sig0ij
11987 ! for diagnostics; uncomment
11988 !              rij_shift=1.2*sig0ij
11989 ! I hate to put IF's in the loops, but here don't have another choice!!!!
11990               if (rij_shift.le.0.0D0) then
11991                 evdw=1.0D20
11992 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
11993 !d     &          restyp(itypi),i,restyp(itypj),j,
11994 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
11995                 return
11996               endif
11997               sigder=-sig*sigsq
11998 !---------------------------------------------------------------
11999               rij_shift=1.0D0/rij_shift
12000               fac=rij_shift**expon
12001               e1=fac*fac*aa(itypi,itypj)
12002               e2=fac*bb(itypi,itypj)
12003               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12004               eps2der=evdwij*eps3rt
12005               eps3der=evdwij*eps2rt
12006 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12007 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12008               evdwij=evdwij*eps2rt*eps3rt
12009               evdw=evdw+evdwij*sss*sss_ele_cut
12010               if (lprn) then
12011               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12012               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12013               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12014                 restyp(itypi),i,restyp(itypj),j,&
12015                 epsi,sigm,chi1,chi2,chip1,chip2,&
12016                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12017                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12018                 evdwij
12019               endif
12020
12021               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12022                               'evdw',i,j,evdwij
12023 !              if (energy_dec) write (iout,*) &
12024 !                              'evdw',i,j,evdwij,"egb_short"
12025
12026 ! Calculate gradient components.
12027               e1=e1*eps1*eps2rt**2*eps3rt**2
12028               fac=-expon*(e1+evdwij)*rij_shift
12029               sigder=fac*sigder
12030               fac=rij*fac
12031               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12032             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
12033             /sigmaii(itypi,itypj))
12034
12035 !              fac=0.0d0
12036 ! Calculate the radial part of the gradient
12037               gg(1)=xj*fac
12038               gg(2)=yj*fac
12039               gg(3)=zj*fac
12040 ! Calculate angular part of the gradient.
12041               call sc_grad_scale(sss)
12042             endif
12043           enddo      ! j
12044         enddo        ! iint
12045       enddo          ! i
12046 !      write (iout,*) "Number of loop steps in EGB:",ind
12047 !ccc      energy_dec=.false.
12048       return
12049       end subroutine egb_short
12050 !-----------------------------------------------------------------------------
12051       subroutine egbv_long(evdw)
12052 !
12053 ! This subroutine calculates the interaction energy of nonbonded side chains
12054 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12055 !
12056       use calc_data
12057 !      implicit real*8 (a-h,o-z)
12058 !      include 'DIMENSIONS'
12059 !      include 'COMMON.GEO'
12060 !      include 'COMMON.VAR'
12061 !      include 'COMMON.LOCAL'
12062 !      include 'COMMON.CHAIN'
12063 !      include 'COMMON.DERIV'
12064 !      include 'COMMON.NAMES'
12065 !      include 'COMMON.INTERACT'
12066 !      include 'COMMON.IOUNITS'
12067 !      include 'COMMON.CALC'
12068       use comm_srutu
12069 !el      integer :: icall
12070 !el      common /srutu/ icall
12071       logical :: lprn
12072 !el local variables
12073       integer :: iint,itypi,itypi1,itypj
12074       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
12075       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
12076       evdw=0.0D0
12077 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12078       evdw=0.0D0
12079       lprn=.false.
12080 !     if (icall.eq.0) lprn=.true.
12081 !el      ind=0
12082       do i=iatsc_s,iatsc_e
12083         itypi=itype(i)
12084         if (itypi.eq.ntyp1) cycle
12085         itypi1=itype(i+1)
12086         xi=c(1,nres+i)
12087         yi=c(2,nres+i)
12088         zi=c(3,nres+i)
12089         dxi=dc_norm(1,nres+i)
12090         dyi=dc_norm(2,nres+i)
12091         dzi=dc_norm(3,nres+i)
12092 !        dsci_inv=dsc_inv(itypi)
12093         dsci_inv=vbld_inv(i+nres)
12094 !
12095 ! Calculate SC interaction energy.
12096 !
12097         do iint=1,nint_gr(i)
12098           do j=istart(i,iint),iend(i,iint)
12099 !el            ind=ind+1
12100             itypj=itype(j)
12101             if (itypj.eq.ntyp1) cycle
12102 !            dscj_inv=dsc_inv(itypj)
12103             dscj_inv=vbld_inv(j+nres)
12104             sig0ij=sigma(itypi,itypj)
12105             r0ij=r0(itypi,itypj)
12106             chi1=chi(itypi,itypj)
12107             chi2=chi(itypj,itypi)
12108             chi12=chi1*chi2
12109             chip1=chip(itypi)
12110             chip2=chip(itypj)
12111             chip12=chip1*chip2
12112             alf1=alp(itypi)
12113             alf2=alp(itypj)
12114             alf12=0.5D0*(alf1+alf2)
12115             xj=c(1,nres+j)-xi
12116             yj=c(2,nres+j)-yi
12117             zj=c(3,nres+j)-zi
12118             dxj=dc_norm(1,nres+j)
12119             dyj=dc_norm(2,nres+j)
12120             dzj=dc_norm(3,nres+j)
12121             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12122             rij=dsqrt(rrij)
12123
12124             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12125
12126             if (sss.lt.1.0d0) then
12127
12128 ! Calculate angle-dependent terms of energy and contributions to their
12129 ! derivatives.
12130               call sc_angular
12131               sigsq=1.0D0/sigsq
12132               sig=sig0ij*dsqrt(sigsq)
12133               rij_shift=1.0D0/rij-sig+r0ij
12134 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12135               if (rij_shift.le.0.0D0) then
12136                 evdw=1.0D20
12137                 return
12138               endif
12139               sigder=-sig*sigsq
12140 !---------------------------------------------------------------
12141               rij_shift=1.0D0/rij_shift
12142               fac=rij_shift**expon
12143               e1=fac*fac*aa(itypi,itypj)
12144               e2=fac*bb(itypi,itypj)
12145               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12146               eps2der=evdwij*eps3rt
12147               eps3der=evdwij*eps2rt
12148               fac_augm=rrij**expon
12149               e_augm=augm(itypi,itypj)*fac_augm
12150               evdwij=evdwij*eps2rt*eps3rt
12151               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
12152               if (lprn) then
12153               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12154               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12155               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12156                 restyp(itypi),i,restyp(itypj),j,&
12157                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12158                 chi1,chi2,chip1,chip2,&
12159                 eps1,eps2rt**2,eps3rt**2,&
12160                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12161                 evdwij+e_augm
12162               endif
12163 ! Calculate gradient components.
12164               e1=e1*eps1*eps2rt**2*eps3rt**2
12165               fac=-expon*(e1+evdwij)*rij_shift
12166               sigder=fac*sigder
12167               fac=rij*fac-2*expon*rrij*e_augm
12168 ! Calculate the radial part of the gradient
12169               gg(1)=xj*fac
12170               gg(2)=yj*fac
12171               gg(3)=zj*fac
12172 ! Calculate angular part of the gradient.
12173               call sc_grad_scale(1.0d0-sss)
12174             endif
12175           enddo      ! j
12176         enddo        ! iint
12177       enddo          ! i
12178       end subroutine egbv_long
12179 !-----------------------------------------------------------------------------
12180       subroutine egbv_short(evdw)
12181 !
12182 ! This subroutine calculates the interaction energy of nonbonded side chains
12183 ! assuming the Gay-Berne-Vorobjev potential of interaction.
12184 !
12185       use calc_data
12186 !      implicit real*8 (a-h,o-z)
12187 !      include 'DIMENSIONS'
12188 !      include 'COMMON.GEO'
12189 !      include 'COMMON.VAR'
12190 !      include 'COMMON.LOCAL'
12191 !      include 'COMMON.CHAIN'
12192 !      include 'COMMON.DERIV'
12193 !      include 'COMMON.NAMES'
12194 !      include 'COMMON.INTERACT'
12195 !      include 'COMMON.IOUNITS'
12196 !      include 'COMMON.CALC'
12197       use comm_srutu
12198 !el      integer :: icall
12199 !el      common /srutu/ icall
12200       logical :: lprn
12201 !el local variables
12202       integer :: iint,itypi,itypi1,itypj
12203       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
12204       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
12205       evdw=0.0D0
12206 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12207       evdw=0.0D0
12208       lprn=.false.
12209 !     if (icall.eq.0) lprn=.true.
12210 !el      ind=0
12211       do i=iatsc_s,iatsc_e
12212         itypi=itype(i)
12213         if (itypi.eq.ntyp1) cycle
12214         itypi1=itype(i+1)
12215         xi=c(1,nres+i)
12216         yi=c(2,nres+i)
12217         zi=c(3,nres+i)
12218         dxi=dc_norm(1,nres+i)
12219         dyi=dc_norm(2,nres+i)
12220         dzi=dc_norm(3,nres+i)
12221 !        dsci_inv=dsc_inv(itypi)
12222         dsci_inv=vbld_inv(i+nres)
12223 !
12224 ! Calculate SC interaction energy.
12225 !
12226         do iint=1,nint_gr(i)
12227           do j=istart(i,iint),iend(i,iint)
12228 !el            ind=ind+1
12229             itypj=itype(j)
12230             if (itypj.eq.ntyp1) cycle
12231 !            dscj_inv=dsc_inv(itypj)
12232             dscj_inv=vbld_inv(j+nres)
12233             sig0ij=sigma(itypi,itypj)
12234             r0ij=r0(itypi,itypj)
12235             chi1=chi(itypi,itypj)
12236             chi2=chi(itypj,itypi)
12237             chi12=chi1*chi2
12238             chip1=chip(itypi)
12239             chip2=chip(itypj)
12240             chip12=chip1*chip2
12241             alf1=alp(itypi)
12242             alf2=alp(itypj)
12243             alf12=0.5D0*(alf1+alf2)
12244             xj=c(1,nres+j)-xi
12245             yj=c(2,nres+j)-yi
12246             zj=c(3,nres+j)-zi
12247             dxj=dc_norm(1,nres+j)
12248             dyj=dc_norm(2,nres+j)
12249             dzj=dc_norm(3,nres+j)
12250             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12251             rij=dsqrt(rrij)
12252
12253             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12254
12255             if (sss.gt.0.0d0) then
12256
12257 ! Calculate angle-dependent terms of energy and contributions to their
12258 ! derivatives.
12259               call sc_angular
12260               sigsq=1.0D0/sigsq
12261               sig=sig0ij*dsqrt(sigsq)
12262               rij_shift=1.0D0/rij-sig+r0ij
12263 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12264               if (rij_shift.le.0.0D0) then
12265                 evdw=1.0D20
12266                 return
12267               endif
12268               sigder=-sig*sigsq
12269 !---------------------------------------------------------------
12270               rij_shift=1.0D0/rij_shift
12271               fac=rij_shift**expon
12272               e1=fac*fac*aa(itypi,itypj)
12273               e2=fac*bb(itypi,itypj)
12274               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12275               eps2der=evdwij*eps3rt
12276               eps3der=evdwij*eps2rt
12277               fac_augm=rrij**expon
12278               e_augm=augm(itypi,itypj)*fac_augm
12279               evdwij=evdwij*eps2rt*eps3rt
12280               evdw=evdw+(evdwij+e_augm)*sss
12281               if (lprn) then
12282               sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12283               epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12284               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12285                 restyp(itypi),i,restyp(itypj),j,&
12286                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
12287                 chi1,chi2,chip1,chip2,&
12288                 eps1,eps2rt**2,eps3rt**2,&
12289                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12290                 evdwij+e_augm
12291               endif
12292 ! Calculate gradient components.
12293               e1=e1*eps1*eps2rt**2*eps3rt**2
12294               fac=-expon*(e1+evdwij)*rij_shift
12295               sigder=fac*sigder
12296               fac=rij*fac-2*expon*rrij*e_augm
12297 ! Calculate the radial part of the gradient
12298               gg(1)=xj*fac
12299               gg(2)=yj*fac
12300               gg(3)=zj*fac
12301 ! Calculate angular part of the gradient.
12302               call sc_grad_scale(sss)
12303             endif
12304           enddo      ! j
12305         enddo        ! iint
12306       enddo          ! i
12307       end subroutine egbv_short
12308 !-----------------------------------------------------------------------------
12309       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
12310 !
12311 ! This subroutine calculates the average interaction energy and its gradient
12312 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
12313 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
12314 ! The potential depends both on the distance of peptide-group centers and on
12315 ! the orientation of the CA-CA virtual bonds.
12316 !
12317 !      implicit real*8 (a-h,o-z)
12318
12319       use comm_locel
12320 #ifdef MPI
12321       include 'mpif.h'
12322 #endif
12323 !      include 'DIMENSIONS'
12324 !      include 'COMMON.CONTROL'
12325 !      include 'COMMON.SETUP'
12326 !      include 'COMMON.IOUNITS'
12327 !      include 'COMMON.GEO'
12328 !      include 'COMMON.VAR'
12329 !      include 'COMMON.LOCAL'
12330 !      include 'COMMON.CHAIN'
12331 !      include 'COMMON.DERIV'
12332 !      include 'COMMON.INTERACT'
12333 !      include 'COMMON.CONTACTS'
12334 !      include 'COMMON.TORSION'
12335 !      include 'COMMON.VECTORS'
12336 !      include 'COMMON.FFIELD'
12337 !      include 'COMMON.TIME1'
12338       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
12339       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
12340       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12341 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12342       real(kind=8),dimension(4) :: muij
12343 !el      integer :: num_conti,j1,j2
12344 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12345 !el                   dz_normi,xmedi,ymedi,zmedi
12346 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12347 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12348 !el          num_conti,j1,j2
12349 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12350 #ifdef MOMENT
12351       real(kind=8) :: scal_el=1.0d0
12352 #else
12353       real(kind=8) :: scal_el=0.5d0
12354 #endif
12355 ! 12/13/98
12356 ! 13-go grudnia roku pamietnego...
12357       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12358                                              0.0d0,1.0d0,0.0d0,&
12359                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12360 !el local variables
12361       integer :: i,j,k
12362       real(kind=8) :: fac
12363       real(kind=8) :: dxj,dyj,dzj
12364       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
12365
12366 !      allocate(num_cont_hb(nres)) !(maxres)
12367 !d      write(iout,*) 'In EELEC'
12368 !d      do i=1,nloctyp
12369 !d        write(iout,*) 'Type',i
12370 !d        write(iout,*) 'B1',B1(:,i)
12371 !d        write(iout,*) 'B2',B2(:,i)
12372 !d        write(iout,*) 'CC',CC(:,:,i)
12373 !d        write(iout,*) 'DD',DD(:,:,i)
12374 !d        write(iout,*) 'EE',EE(:,:,i)
12375 !d      enddo
12376 !d      call check_vecgrad
12377 !d      stop
12378       if (icheckgrad.eq.1) then
12379         do i=1,nres-1
12380           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
12381           do k=1,3
12382             dc_norm(k,i)=dc(k,i)*fac
12383           enddo
12384 !          write (iout,*) 'i',i,' fac',fac
12385         enddo
12386       endif
12387       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12388           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
12389           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
12390 !        call vec_and_deriv
12391 #ifdef TIMING
12392         time01=MPI_Wtime()
12393 #endif
12394         call set_matrices
12395 #ifdef TIMING
12396         time_mat=time_mat+MPI_Wtime()-time01
12397 #endif
12398       endif
12399 !d      do i=1,nres-1
12400 !d        write (iout,*) 'i=',i
12401 !d        do k=1,3
12402 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
12403 !d        enddo
12404 !d        do k=1,3
12405 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
12406 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
12407 !d        enddo
12408 !d      enddo
12409       t_eelecij=0.0d0
12410       ees=0.0D0
12411       evdw1=0.0D0
12412       eel_loc=0.0d0
12413       eello_turn3=0.0d0
12414       eello_turn4=0.0d0
12415 !el      ind=0
12416       do i=1,nres
12417         num_cont_hb(i)=0
12418       enddo
12419 !d      print '(a)','Enter EELEC'
12420 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
12421 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
12422 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
12423       do i=1,nres
12424         gel_loc_loc(i)=0.0d0
12425         gcorr_loc(i)=0.0d0
12426       enddo
12427 !
12428 !
12429 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
12430 !
12431 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
12432 !
12433       do i=iturn3_start,iturn3_end
12434         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
12435         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
12436         dxi=dc(1,i)
12437         dyi=dc(2,i)
12438         dzi=dc(3,i)
12439         dx_normi=dc_norm(1,i)
12440         dy_normi=dc_norm(2,i)
12441         dz_normi=dc_norm(3,i)
12442         xmedi=c(1,i)+0.5d0*dxi
12443         ymedi=c(2,i)+0.5d0*dyi
12444         zmedi=c(3,i)+0.5d0*dzi
12445         num_conti=0
12446         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
12447         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
12448         num_cont_hb(i)=num_conti
12449       enddo
12450       do i=iturn4_start,iturn4_end
12451         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
12452           .or. itype(i+3).eq.ntyp1 &
12453           .or. itype(i+4).eq.ntyp1) cycle
12454         dxi=dc(1,i)
12455         dyi=dc(2,i)
12456         dzi=dc(3,i)
12457         dx_normi=dc_norm(1,i)
12458         dy_normi=dc_norm(2,i)
12459         dz_normi=dc_norm(3,i)
12460         xmedi=c(1,i)+0.5d0*dxi
12461         ymedi=c(2,i)+0.5d0*dyi
12462         zmedi=c(3,i)+0.5d0*dzi
12463         num_conti=num_cont_hb(i)
12464         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
12465         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
12466           call eturn4(i,eello_turn4)
12467         num_cont_hb(i)=num_conti
12468       enddo   ! i
12469 !
12470 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
12471 !
12472       do i=iatel_s,iatel_e
12473         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
12474         dxi=dc(1,i)
12475         dyi=dc(2,i)
12476         dzi=dc(3,i)
12477         dx_normi=dc_norm(1,i)
12478         dy_normi=dc_norm(2,i)
12479         dz_normi=dc_norm(3,i)
12480         xmedi=c(1,i)+0.5d0*dxi
12481         ymedi=c(2,i)+0.5d0*dyi
12482         zmedi=c(3,i)+0.5d0*dzi
12483 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
12484         num_conti=num_cont_hb(i)
12485         do j=ielstart(i),ielend(i)
12486           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
12487           call eelecij_scale(i,j,ees,evdw1,eel_loc)
12488         enddo ! j
12489         num_cont_hb(i)=num_conti
12490       enddo   ! i
12491 !      write (iout,*) "Number of loop steps in EELEC:",ind
12492 !d      do i=1,nres
12493 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
12494 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
12495 !d      enddo
12496 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
12497 !cc      eel_loc=eel_loc+eello_turn3
12498 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
12499       return
12500       end subroutine eelec_scale
12501 !-----------------------------------------------------------------------------
12502       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
12503 !      implicit real*8 (a-h,o-z)
12504
12505       use comm_locel
12506 !      include 'DIMENSIONS'
12507 #ifdef MPI
12508       include "mpif.h"
12509 #endif
12510 !      include 'COMMON.CONTROL'
12511 !      include 'COMMON.IOUNITS'
12512 !      include 'COMMON.GEO'
12513 !      include 'COMMON.VAR'
12514 !      include 'COMMON.LOCAL'
12515 !      include 'COMMON.CHAIN'
12516 !      include 'COMMON.DERIV'
12517 !      include 'COMMON.INTERACT'
12518 !      include 'COMMON.CONTACTS'
12519 !      include 'COMMON.TORSION'
12520 !      include 'COMMON.VECTORS'
12521 !      include 'COMMON.FFIELD'
12522 !      include 'COMMON.TIME1'
12523       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg
12524       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
12525       real(kind=8),dimension(2,2) :: acipa !el,a_temp
12526 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
12527       real(kind=8),dimension(4) :: muij
12528 !el      integer :: num_conti,j1,j2
12529 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
12530 !el                   dz_normi,xmedi,ymedi,zmedi
12531 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
12532 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
12533 !el          num_conti,j1,j2
12534 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
12535 #ifdef MOMENT
12536       real(kind=8) :: scal_el=1.0d0
12537 #else
12538       real(kind=8) :: scal_el=0.5d0
12539 #endif
12540 ! 12/13/98
12541 ! 13-go grudnia roku pamietnego...
12542       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
12543                                              0.0d0,1.0d0,0.0d0,&
12544                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
12545 !el local variables
12546       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m
12547       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
12548       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
12549       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
12550       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
12551       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
12552       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
12553                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
12554                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
12555                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
12556                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
12557                   ecosam,ecosbm,ecosgm,ghalf,time00
12558 !      integer :: maxconts
12559 !      maxconts = nres/4
12560 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12561 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12562 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12563 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12564 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12565 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12566 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12567 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
12568 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
12569 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
12570 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
12571 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
12572 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
12573
12574 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
12575 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
12576
12577 #ifdef MPI
12578           time00=MPI_Wtime()
12579 #endif
12580 !d      write (iout,*) "eelecij",i,j
12581 !el          ind=ind+1
12582           iteli=itel(i)
12583           itelj=itel(j)
12584           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
12585           aaa=app(iteli,itelj)
12586           bbb=bpp(iteli,itelj)
12587           ael6i=ael6(iteli,itelj)
12588           ael3i=ael3(iteli,itelj)
12589           dxj=dc(1,j)
12590           dyj=dc(2,j)
12591           dzj=dc(3,j)
12592           dx_normj=dc_norm(1,j)
12593           dy_normj=dc_norm(2,j)
12594           dz_normj=dc_norm(3,j)
12595           xj=c(1,j)+0.5D0*dxj-xmedi
12596           yj=c(2,j)+0.5D0*dyj-ymedi
12597           zj=c(3,j)+0.5D0*dzj-zmedi
12598           rij=xj*xj+yj*yj+zj*zj
12599           rrmij=1.0D0/rij
12600           rij=dsqrt(rij)
12601           rmij=1.0D0/rij
12602 ! For extracting the short-range part of Evdwpp
12603           sss=sscale(rij/rpp(iteli,itelj))
12604
12605           r3ij=rrmij*rmij
12606           r6ij=r3ij*r3ij
12607           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
12608           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
12609           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
12610           fac=cosa-3.0D0*cosb*cosg
12611           ev1=aaa*r6ij*r6ij
12612 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
12613           if (j.eq.i+2) ev1=scal_el*ev1
12614           ev2=bbb*r6ij
12615           fac3=ael6i*r6ij
12616           fac4=ael3i*r3ij
12617           evdwij=ev1+ev2
12618           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
12619           el2=fac4*fac
12620           eesij=el1+el2
12621 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
12622           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
12623           ees=ees+eesij
12624           evdw1=evdw1+evdwij*(1.0d0-sss)
12625 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
12626 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
12627 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
12628 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
12629
12630           if (energy_dec) then
12631               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
12632               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
12633           endif
12634
12635 !
12636 ! Calculate contributions to the Cartesian gradient.
12637 !
12638 #ifdef SPLITELE
12639           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
12640           facel=-3*rrmij*(el1+eesij)
12641           fac1=fac
12642           erij(1)=xj*rmij
12643           erij(2)=yj*rmij
12644           erij(3)=zj*rmij
12645 !
12646 ! Radial derivatives. First process both termini of the fragment (i,j)
12647 !
12648           ggg(1)=facel*xj
12649           ggg(2)=facel*yj
12650           ggg(3)=facel*zj
12651 !          do k=1,3
12652 !            ghalf=0.5D0*ggg(k)
12653 !            gelc(k,i)=gelc(k,i)+ghalf
12654 !            gelc(k,j)=gelc(k,j)+ghalf
12655 !          enddo
12656 ! 9/28/08 AL Gradient compotents will be summed only at the end
12657           do k=1,3
12658             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12659             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12660           enddo
12661 !
12662 ! Loop over residues i+1 thru j-1.
12663 !
12664 !grad          do k=i+1,j-1
12665 !grad            do l=1,3
12666 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12667 !grad            enddo
12668 !grad          enddo
12669           ggg(1)=facvdw*xj
12670           ggg(2)=facvdw*yj
12671           ggg(3)=facvdw*zj
12672 !          do k=1,3
12673 !            ghalf=0.5D0*ggg(k)
12674 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
12675 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
12676 !          enddo
12677 ! 9/28/08 AL Gradient compotents will be summed only at the end
12678           do k=1,3
12679             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12680             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12681           enddo
12682 !
12683 ! Loop over residues i+1 thru j-1.
12684 !
12685 !grad          do k=i+1,j-1
12686 !grad            do l=1,3
12687 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
12688 !grad            enddo
12689 !grad          enddo
12690 #else
12691           facvdw=ev1+evdwij*(1.0d0-sss)
12692           facel=el1+eesij
12693           fac1=fac
12694           fac=-3*rrmij*(facvdw+facvdw+facel)
12695           erij(1)=xj*rmij
12696           erij(2)=yj*rmij
12697           erij(3)=zj*rmij
12698 !
12699 ! Radial derivatives. First process both termini of the fragment (i,j)
12700 !
12701           ggg(1)=fac*xj
12702           ggg(2)=fac*yj
12703           ggg(3)=fac*zj
12704 !          do k=1,3
12705 !            ghalf=0.5D0*ggg(k)
12706 !            gelc(k,i)=gelc(k,i)+ghalf
12707 !            gelc(k,j)=gelc(k,j)+ghalf
12708 !          enddo
12709 ! 9/28/08 AL Gradient compotents will be summed only at the end
12710           do k=1,3
12711             gelc_long(k,j)=gelc(k,j)+ggg(k)
12712             gelc_long(k,i)=gelc(k,i)-ggg(k)
12713           enddo
12714 !
12715 ! Loop over residues i+1 thru j-1.
12716 !
12717 !grad          do k=i+1,j-1
12718 !grad            do l=1,3
12719 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12720 !grad            enddo
12721 !grad          enddo
12722 ! 9/28/08 AL Gradient compotents will be summed only at the end
12723           ggg(1)=facvdw*xj
12724           ggg(2)=facvdw*yj
12725           ggg(3)=facvdw*zj
12726           do k=1,3
12727             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
12728             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
12729           enddo
12730 #endif
12731 !
12732 ! Angular part
12733 !
12734           ecosa=2.0D0*fac3*fac1+fac4
12735           fac4=-3.0D0*fac4
12736           fac3=-6.0D0*fac3
12737           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
12738           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
12739           do k=1,3
12740             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
12741             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
12742           enddo
12743 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
12744 !d   &          (dcosg(k),k=1,3)
12745           do k=1,3
12746             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
12747           enddo
12748 !          do k=1,3
12749 !            ghalf=0.5D0*ggg(k)
12750 !            gelc(k,i)=gelc(k,i)+ghalf
12751 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
12752 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12753 !            gelc(k,j)=gelc(k,j)+ghalf
12754 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
12755 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12756 !          enddo
12757 !grad          do k=i+1,j-1
12758 !grad            do l=1,3
12759 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
12760 !grad            enddo
12761 !grad          enddo
12762           do k=1,3
12763             gelc(k,i)=gelc(k,i) &
12764                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
12765                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
12766             gelc(k,j)=gelc(k,j) &
12767                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
12768                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
12769             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
12770             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
12771           enddo
12772           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
12773               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
12774               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
12775 !
12776 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
12777 !   energy of a peptide unit is assumed in the form of a second-order
12778 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
12779 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
12780 !   are computed for EVERY pair of non-contiguous peptide groups.
12781 !
12782           if (j.lt.nres-1) then
12783             j1=j+1
12784             j2=j-1
12785           else
12786             j1=j-1
12787             j2=j-2
12788           endif
12789           kkk=0
12790           do k=1,2
12791             do l=1,2
12792               kkk=kkk+1
12793               muij(kkk)=mu(k,i)*mu(l,j)
12794             enddo
12795           enddo
12796 !d         write (iout,*) 'EELEC: i',i,' j',j
12797 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
12798 !d          write(iout,*) 'muij',muij
12799           ury=scalar(uy(1,i),erij)
12800           urz=scalar(uz(1,i),erij)
12801           vry=scalar(uy(1,j),erij)
12802           vrz=scalar(uz(1,j),erij)
12803           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
12804           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
12805           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
12806           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
12807           fac=dsqrt(-ael6i)*r3ij
12808           a22=a22*fac
12809           a23=a23*fac
12810           a32=a32*fac
12811           a33=a33*fac
12812 !d          write (iout,'(4i5,4f10.5)')
12813 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
12814 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
12815 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
12816 !d     &      uy(:,j),uz(:,j)
12817 !d          write (iout,'(4f10.5)')
12818 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
12819 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
12820 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
12821 !d           write (iout,'(9f10.5/)')
12822 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
12823 ! Derivatives of the elements of A in virtual-bond vectors
12824           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
12825           do k=1,3
12826             uryg(k,1)=scalar(erder(1,k),uy(1,i))
12827             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
12828             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
12829             urzg(k,1)=scalar(erder(1,k),uz(1,i))
12830             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
12831             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
12832             vryg(k,1)=scalar(erder(1,k),uy(1,j))
12833             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
12834             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
12835             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
12836             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
12837             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
12838           enddo
12839 ! Compute radial contributions to the gradient
12840           facr=-3.0d0*rrmij
12841           a22der=a22*facr
12842           a23der=a23*facr
12843           a32der=a32*facr
12844           a33der=a33*facr
12845           agg(1,1)=a22der*xj
12846           agg(2,1)=a22der*yj
12847           agg(3,1)=a22der*zj
12848           agg(1,2)=a23der*xj
12849           agg(2,2)=a23der*yj
12850           agg(3,2)=a23der*zj
12851           agg(1,3)=a32der*xj
12852           agg(2,3)=a32der*yj
12853           agg(3,3)=a32der*zj
12854           agg(1,4)=a33der*xj
12855           agg(2,4)=a33der*yj
12856           agg(3,4)=a33der*zj
12857 ! Add the contributions coming from er
12858           fac3=-3.0d0*fac
12859           do k=1,3
12860             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
12861             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
12862             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
12863             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
12864           enddo
12865           do k=1,3
12866 ! Derivatives in DC(i)
12867 !grad            ghalf1=0.5d0*agg(k,1)
12868 !grad            ghalf2=0.5d0*agg(k,2)
12869 !grad            ghalf3=0.5d0*agg(k,3)
12870 !grad            ghalf4=0.5d0*agg(k,4)
12871             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
12872             -3.0d0*uryg(k,2)*vry)!+ghalf1
12873             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
12874             -3.0d0*uryg(k,2)*vrz)!+ghalf2
12875             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
12876             -3.0d0*urzg(k,2)*vry)!+ghalf3
12877             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
12878             -3.0d0*urzg(k,2)*vrz)!+ghalf4
12879 ! Derivatives in DC(i+1)
12880             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
12881             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
12882             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
12883             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
12884             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
12885             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
12886             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
12887             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
12888 ! Derivatives in DC(j)
12889             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
12890             -3.0d0*vryg(k,2)*ury)!+ghalf1
12891             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
12892             -3.0d0*vrzg(k,2)*ury)!+ghalf2
12893             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
12894             -3.0d0*vryg(k,2)*urz)!+ghalf3
12895             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
12896             -3.0d0*vrzg(k,2)*urz)!+ghalf4
12897 ! Derivatives in DC(j+1) or DC(nres-1)
12898             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
12899             -3.0d0*vryg(k,3)*ury)
12900             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
12901             -3.0d0*vrzg(k,3)*ury)
12902             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
12903             -3.0d0*vryg(k,3)*urz)
12904             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
12905             -3.0d0*vrzg(k,3)*urz)
12906 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
12907 !grad              do l=1,4
12908 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
12909 !grad              enddo
12910 !grad            endif
12911           enddo
12912           acipa(1,1)=a22
12913           acipa(1,2)=a23
12914           acipa(2,1)=a32
12915           acipa(2,2)=a33
12916           a22=-a22
12917           a23=-a23
12918           do l=1,2
12919             do k=1,3
12920               agg(k,l)=-agg(k,l)
12921               aggi(k,l)=-aggi(k,l)
12922               aggi1(k,l)=-aggi1(k,l)
12923               aggj(k,l)=-aggj(k,l)
12924               aggj1(k,l)=-aggj1(k,l)
12925             enddo
12926           enddo
12927           if (j.lt.nres-1) then
12928             a22=-a22
12929             a32=-a32
12930             do l=1,3,2
12931               do k=1,3
12932                 agg(k,l)=-agg(k,l)
12933                 aggi(k,l)=-aggi(k,l)
12934                 aggi1(k,l)=-aggi1(k,l)
12935                 aggj(k,l)=-aggj(k,l)
12936                 aggj1(k,l)=-aggj1(k,l)
12937               enddo
12938             enddo
12939           else
12940             a22=-a22
12941             a23=-a23
12942             a32=-a32
12943             a33=-a33
12944             do l=1,4
12945               do k=1,3
12946                 agg(k,l)=-agg(k,l)
12947                 aggi(k,l)=-aggi(k,l)
12948                 aggi1(k,l)=-aggi1(k,l)
12949                 aggj(k,l)=-aggj(k,l)
12950                 aggj1(k,l)=-aggj1(k,l)
12951               enddo
12952             enddo
12953           endif
12954           ENDIF ! WCORR
12955           IF (wel_loc.gt.0.0d0) THEN
12956 ! Contribution to the local-electrostatic energy coming from the i-j pair
12957           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
12958            +a33*muij(4)
12959 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
12960
12961           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12962                   'eelloc',i,j,eel_loc_ij
12963 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
12964
12965           eel_loc=eel_loc+eel_loc_ij
12966 ! Partial derivatives in virtual-bond dihedral angles gamma
12967           if (i.gt.1) &
12968           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
12969                   a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
12970                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
12971           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
12972                   a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
12973                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
12974 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
12975           do l=1,3
12976             ggg(l)=agg(l,1)*muij(1)+ &
12977                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
12978             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
12979             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
12980 !grad            ghalf=0.5d0*ggg(l)
12981 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
12982 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
12983           enddo
12984 !grad          do k=i+1,j2
12985 !grad            do l=1,3
12986 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
12987 !grad            enddo
12988 !grad          enddo
12989 ! Remaining derivatives of eello
12990           do l=1,3
12991             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ &
12992                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
12993             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ &
12994                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
12995             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ &
12996                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
12997             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ &
12998                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
12999           enddo
13000           ENDIF
13001 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
13002 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
13003           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
13004              .and. num_conti.le.maxconts) then
13005 !            write (iout,*) i,j," entered corr"
13006 !
13007 ! Calculate the contact function. The ith column of the array JCONT will
13008 ! contain the numbers of atoms that make contacts with the atom I (of numbers
13009 ! greater than I). The arrays FACONT and GACONT will contain the values of
13010 ! the contact function and its derivative.
13011 !           r0ij=1.02D0*rpp(iteli,itelj)
13012 !           r0ij=1.11D0*rpp(iteli,itelj)
13013             r0ij=2.20D0*rpp(iteli,itelj)
13014 !           r0ij=1.55D0*rpp(iteli,itelj)
13015             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
13016 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13017             if (fcont.gt.0.0D0) then
13018               num_conti=num_conti+1
13019               if (num_conti.gt.maxconts) then
13020 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
13021                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
13022                                ' will skip next contacts for this conf.',num_conti
13023               else
13024                 jcont_hb(num_conti,i)=j
13025 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
13026 !d     &           " jcont_hb",jcont_hb(num_conti,i)
13027                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
13028                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13029 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
13030 !  terms.
13031                 d_cont(num_conti,i)=rij
13032 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
13033 !     --- Electrostatic-interaction matrix ---
13034                 a_chuj(1,1,num_conti,i)=a22
13035                 a_chuj(1,2,num_conti,i)=a23
13036                 a_chuj(2,1,num_conti,i)=a32
13037                 a_chuj(2,2,num_conti,i)=a33
13038 !     --- Gradient of rij
13039                 do kkk=1,3
13040                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
13041                 enddo
13042                 kkll=0
13043                 do k=1,2
13044                   do l=1,2
13045                     kkll=kkll+1
13046                     do m=1,3
13047                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
13048                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
13049                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
13050                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
13051                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
13052                     enddo
13053                   enddo
13054                 enddo
13055                 ENDIF
13056                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
13057 ! Calculate contact energies
13058                 cosa4=4.0D0*cosa
13059                 wij=cosa-3.0D0*cosb*cosg
13060                 cosbg1=cosb+cosg
13061                 cosbg2=cosb-cosg
13062 !               fac3=dsqrt(-ael6i)/r0ij**3
13063                 fac3=dsqrt(-ael6i)*r3ij
13064 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
13065                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
13066                 if (ees0tmp.gt.0) then
13067                   ees0pij=dsqrt(ees0tmp)
13068                 else
13069                   ees0pij=0
13070                 endif
13071 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
13072                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
13073                 if (ees0tmp.gt.0) then
13074                   ees0mij=dsqrt(ees0tmp)
13075                 else
13076                   ees0mij=0
13077                 endif
13078 !               ees0mij=0.0D0
13079                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
13080                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
13081 ! Diagnostics. Comment out or remove after debugging!
13082 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
13083 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
13084 !               ees0m(num_conti,i)=0.0D0
13085 ! End diagnostics.
13086 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
13087 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
13088 ! Angular derivatives of the contact function
13089                 ees0pij1=fac3/ees0pij
13090                 ees0mij1=fac3/ees0mij
13091                 fac3p=-3.0D0*fac3*rrmij
13092                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
13093                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
13094 !               ees0mij1=0.0D0
13095                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
13096                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
13097                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
13098                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
13099                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
13100                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
13101                 ecosap=ecosa1+ecosa2
13102                 ecosbp=ecosb1+ecosb2
13103                 ecosgp=ecosg1+ecosg2
13104                 ecosam=ecosa1-ecosa2
13105                 ecosbm=ecosb1-ecosb2
13106                 ecosgm=ecosg1-ecosg2
13107 ! Diagnostics
13108 !               ecosap=ecosa1
13109 !               ecosbp=ecosb1
13110 !               ecosgp=ecosg1
13111 !               ecosam=0.0D0
13112 !               ecosbm=0.0D0
13113 !               ecosgm=0.0D0
13114 ! End diagnostics
13115                 facont_hb(num_conti,i)=fcont
13116                 fprimcont=fprimcont/rij
13117 !d              facont_hb(num_conti,i)=1.0D0
13118 ! Following line is for diagnostics.
13119 !d              fprimcont=0.0D0
13120                 do k=1,3
13121                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13122                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13123                 enddo
13124                 do k=1,3
13125                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
13126                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
13127                 enddo
13128                 gggp(1)=gggp(1)+ees0pijp*xj
13129                 gggp(2)=gggp(2)+ees0pijp*yj
13130                 gggp(3)=gggp(3)+ees0pijp*zj
13131                 gggm(1)=gggm(1)+ees0mijp*xj
13132                 gggm(2)=gggm(2)+ees0mijp*yj
13133                 gggm(3)=gggm(3)+ees0mijp*zj
13134 ! Derivatives due to the contact function
13135                 gacont_hbr(1,num_conti,i)=fprimcont*xj
13136                 gacont_hbr(2,num_conti,i)=fprimcont*yj
13137                 gacont_hbr(3,num_conti,i)=fprimcont*zj
13138                 do k=1,3
13139 !
13140 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
13141 !          following the change of gradient-summation algorithm.
13142 !
13143 !grad                  ghalfp=0.5D0*gggp(k)
13144 !grad                  ghalfm=0.5D0*gggm(k)
13145                   gacontp_hb1(k,num_conti,i)= & !ghalfp
13146                     +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13147                     + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13148                   gacontp_hb2(k,num_conti,i)= & !ghalfp
13149                     +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13150                     + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13151                   gacontp_hb3(k,num_conti,i)=gggp(k)
13152                   gacontm_hb1(k,num_conti,i)=  &!ghalfm
13153                     +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13154                     + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13155                   gacontm_hb2(k,num_conti,i)= & !ghalfm
13156                     +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13157                     + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13158                   gacontm_hb3(k,num_conti,i)=gggm(k)
13159                 enddo
13160               ENDIF ! wcorr
13161               endif  ! num_conti.le.maxconts
13162             endif  ! fcont.gt.0
13163           endif    ! j.gt.i+1
13164           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
13165             do k=1,4
13166               do l=1,3
13167                 ghalf=0.5d0*agg(l,k)
13168                 aggi(l,k)=aggi(l,k)+ghalf
13169                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
13170                 aggj(l,k)=aggj(l,k)+ghalf
13171               enddo
13172             enddo
13173             if (j.eq.nres-1 .and. i.lt.j-2) then
13174               do k=1,4
13175                 do l=1,3
13176                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
13177                 enddo
13178               enddo
13179             endif
13180           endif
13181 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
13182       return
13183       end subroutine eelecij_scale
13184 !-----------------------------------------------------------------------------
13185       subroutine evdwpp_short(evdw1)
13186 !
13187 ! Compute Evdwpp
13188 !
13189 !      implicit real*8 (a-h,o-z)
13190 !      include 'DIMENSIONS'
13191 !      include 'COMMON.CONTROL'
13192 !      include 'COMMON.IOUNITS'
13193 !      include 'COMMON.GEO'
13194 !      include 'COMMON.VAR'
13195 !      include 'COMMON.LOCAL'
13196 !      include 'COMMON.CHAIN'
13197 !      include 'COMMON.DERIV'
13198 !      include 'COMMON.INTERACT'
13199 !      include 'COMMON.CONTACTS'
13200 !      include 'COMMON.TORSION'
13201 !      include 'COMMON.VECTORS'
13202 !      include 'COMMON.FFIELD'
13203       real(kind=8),dimension(3) :: ggg
13204 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13205 #ifdef MOMENT
13206       real(kind=8) :: scal_el=1.0d0
13207 #else
13208       real(kind=8) :: scal_el=0.5d0
13209 #endif
13210 !el local variables
13211       integer :: i,j,k,iteli,itelj,num_conti
13212       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
13213       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
13214                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13215                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
13216
13217       evdw1=0.0D0
13218 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
13219 !     & " iatel_e_vdw",iatel_e_vdw
13220       call flush(iout)
13221       do i=iatel_s_vdw,iatel_e_vdw
13222         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
13223         dxi=dc(1,i)
13224         dyi=dc(2,i)
13225         dzi=dc(3,i)
13226         dx_normi=dc_norm(1,i)
13227         dy_normi=dc_norm(2,i)
13228         dz_normi=dc_norm(3,i)
13229         xmedi=c(1,i)+0.5d0*dxi
13230         ymedi=c(2,i)+0.5d0*dyi
13231         zmedi=c(3,i)+0.5d0*dzi
13232         num_conti=0
13233 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
13234 !     &   ' ielend',ielend_vdw(i)
13235         call flush(iout)
13236         do j=ielstart_vdw(i),ielend_vdw(i)
13237           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13238 !el          ind=ind+1
13239           iteli=itel(i)
13240           itelj=itel(j)
13241           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13242           aaa=app(iteli,itelj)
13243           bbb=bpp(iteli,itelj)
13244           dxj=dc(1,j)
13245           dyj=dc(2,j)
13246           dzj=dc(3,j)
13247           dx_normj=dc_norm(1,j)
13248           dy_normj=dc_norm(2,j)
13249           dz_normj=dc_norm(3,j)
13250           xj=c(1,j)+0.5D0*dxj-xmedi
13251           yj=c(2,j)+0.5D0*dyj-ymedi
13252           zj=c(3,j)+0.5D0*dzj-zmedi
13253           rij=xj*xj+yj*yj+zj*zj
13254           rrmij=1.0D0/rij
13255           rij=dsqrt(rij)
13256           sss=sscale(rij/rpp(iteli,itelj))
13257           if (sss.gt.0.0d0) then
13258             rmij=1.0D0/rij
13259             r3ij=rrmij*rmij
13260             r6ij=r3ij*r3ij
13261             ev1=aaa*r6ij*r6ij
13262 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13263             if (j.eq.i+2) ev1=scal_el*ev1
13264             ev2=bbb*r6ij
13265             evdwij=ev1+ev2
13266             if (energy_dec) then
13267               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13268             endif
13269             evdw1=evdw1+evdwij*sss
13270 !
13271 ! Calculate contributions to the Cartesian gradient.
13272 !
13273             facvdw=-6*rrmij*(ev1+evdwij)*sss
13274             ggg(1)=facvdw*xj
13275             ggg(2)=facvdw*yj
13276             ggg(3)=facvdw*zj
13277             do k=1,3
13278               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13279               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13280             enddo
13281           endif
13282         enddo ! j
13283       enddo   ! i
13284       return
13285       end subroutine evdwpp_short
13286 !-----------------------------------------------------------------------------
13287       subroutine escp_long(evdw2,evdw2_14)
13288 !
13289 ! This subroutine calculates the excluded-volume interaction energy between
13290 ! peptide-group centers and side chains and its gradient in virtual-bond and
13291 ! side-chain vectors.
13292 !
13293 !      implicit real*8 (a-h,o-z)
13294 !      include 'DIMENSIONS'
13295 !      include 'COMMON.GEO'
13296 !      include 'COMMON.VAR'
13297 !      include 'COMMON.LOCAL'
13298 !      include 'COMMON.CHAIN'
13299 !      include 'COMMON.DERIV'
13300 !      include 'COMMON.INTERACT'
13301 !      include 'COMMON.FFIELD'
13302 !      include 'COMMON.IOUNITS'
13303 !      include 'COMMON.CONTROL'
13304       real(kind=8),dimension(3) :: ggg
13305 !el local variables
13306       integer :: i,iint,j,k,iteli,itypj
13307       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13308       real(kind=8) :: evdw2,evdw2_14,evdwij
13309       evdw2=0.0D0
13310       evdw2_14=0.0d0
13311 !d    print '(a)','Enter ESCP'
13312 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13313       do i=iatscp_s,iatscp_e
13314         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13315         iteli=itel(i)
13316         xi=0.5D0*(c(1,i)+c(1,i+1))
13317         yi=0.5D0*(c(2,i)+c(2,i+1))
13318         zi=0.5D0*(c(3,i)+c(3,i+1))
13319
13320         do iint=1,nscp_gr(i)
13321
13322         do j=iscpstart(i,iint),iscpend(i,iint)
13323           itypj=itype(j)
13324           if (itypj.eq.ntyp1) cycle
13325 ! Uncomment following three lines for SC-p interactions
13326 !         xj=c(1,nres+j)-xi
13327 !         yj=c(2,nres+j)-yi
13328 !         zj=c(3,nres+j)-zi
13329 ! Uncomment following three lines for Ca-p interactions
13330           xj=c(1,j)-xi
13331           yj=c(2,j)-yi
13332           zj=c(3,j)-zi
13333           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13334
13335           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13336
13337           if (sss.lt.1.0d0) then
13338
13339             fac=rrij**expon2
13340             e1=fac*fac*aad(itypj,iteli)
13341             e2=fac*bad(itypj,iteli)
13342             if (iabs(j-i) .le. 2) then
13343               e1=scal14*e1
13344               e2=scal14*e2
13345               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
13346             endif
13347             evdwij=e1+e2
13348             evdw2=evdw2+evdwij*(1.0d0-sss)
13349             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13350                 'evdw2',i,j,sss,evdwij
13351 !
13352 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13353 !
13354             fac=-(evdwij+e1)*rrij*(1.0d0-sss)
13355             ggg(1)=xj*fac
13356             ggg(2)=yj*fac
13357             ggg(3)=zj*fac
13358 ! Uncomment following three lines for SC-p interactions
13359 !           do k=1,3
13360 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13361 !           enddo
13362 ! Uncomment following line for SC-p interactions
13363 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13364             do k=1,3
13365               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13366               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13367             enddo
13368           endif
13369         enddo
13370
13371         enddo ! iint
13372       enddo ! i
13373       do i=1,nct
13374         do j=1,3
13375           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13376           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13377           gradx_scp(j,i)=expon*gradx_scp(j,i)
13378         enddo
13379       enddo
13380 !******************************************************************************
13381 !
13382 !                              N O T E !!!
13383 !
13384 ! To save time the factor EXPON has been extracted from ALL components
13385 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13386 ! use!
13387 !
13388 !******************************************************************************
13389       return
13390       end subroutine escp_long
13391 !-----------------------------------------------------------------------------
13392       subroutine escp_short(evdw2,evdw2_14)
13393 !
13394 ! This subroutine calculates the excluded-volume interaction energy between
13395 ! peptide-group centers and side chains and its gradient in virtual-bond and
13396 ! side-chain vectors.
13397 !
13398 !      implicit real*8 (a-h,o-z)
13399 !      include 'DIMENSIONS'
13400 !      include 'COMMON.GEO'
13401 !      include 'COMMON.VAR'
13402 !      include 'COMMON.LOCAL'
13403 !      include 'COMMON.CHAIN'
13404 !      include 'COMMON.DERIV'
13405 !      include 'COMMON.INTERACT'
13406 !      include 'COMMON.FFIELD'
13407 !      include 'COMMON.IOUNITS'
13408 !      include 'COMMON.CONTROL'
13409       real(kind=8),dimension(3) :: ggg
13410 !el local variables
13411       integer :: i,iint,j,k,iteli,itypj
13412       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2
13413       real(kind=8) :: evdw2,evdw2_14,evdwij
13414       evdw2=0.0D0
13415       evdw2_14=0.0d0
13416 !d    print '(a)','Enter ESCP'
13417 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
13418       do i=iatscp_s,iatscp_e
13419         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13420         iteli=itel(i)
13421         xi=0.5D0*(c(1,i)+c(1,i+1))
13422         yi=0.5D0*(c(2,i)+c(2,i+1))
13423         zi=0.5D0*(c(3,i)+c(3,i+1))
13424
13425         do iint=1,nscp_gr(i)
13426
13427         do j=iscpstart(i,iint),iscpend(i,iint)
13428           itypj=itype(j)
13429           if (itypj.eq.ntyp1) cycle
13430 ! Uncomment following three lines for SC-p interactions
13431 !         xj=c(1,nres+j)-xi
13432 !         yj=c(2,nres+j)-yi
13433 !         zj=c(3,nres+j)-zi
13434 ! Uncomment following three lines for Ca-p interactions
13435           xj=c(1,j)-xi
13436           yj=c(2,j)-yi
13437           zj=c(3,j)-zi
13438           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13439
13440           sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
13441
13442           if (sss.gt.0.0d0) then
13443
13444             fac=rrij**expon2
13445             e1=fac*fac*aad(itypj,iteli)
13446             e2=fac*bad(itypj,iteli)
13447             if (iabs(j-i) .le. 2) then
13448               e1=scal14*e1
13449               e2=scal14*e2
13450               evdw2_14=evdw2_14+(e1+e2)*sss
13451             endif
13452             evdwij=e1+e2
13453             evdw2=evdw2+evdwij*sss
13454             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
13455                 'evdw2',i,j,sss,evdwij
13456 !
13457 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
13458 !
13459             fac=-(evdwij+e1)*rrij*sss
13460             ggg(1)=xj*fac
13461             ggg(2)=yj*fac
13462             ggg(3)=zj*fac
13463 ! Uncomment following three lines for SC-p interactions
13464 !           do k=1,3
13465 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13466 !           enddo
13467 ! Uncomment following line for SC-p interactions
13468 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
13469             do k=1,3
13470               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
13471               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
13472             enddo
13473           endif
13474         enddo
13475
13476         enddo ! iint
13477       enddo ! i
13478       do i=1,nct
13479         do j=1,3
13480           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
13481           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
13482           gradx_scp(j,i)=expon*gradx_scp(j,i)
13483         enddo
13484       enddo
13485 !******************************************************************************
13486 !
13487 !                              N O T E !!!
13488 !
13489 ! To save time the factor EXPON has been extracted from ALL components
13490 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13491 ! use!
13492 !
13493 !******************************************************************************
13494       return
13495       end subroutine escp_short
13496 !-----------------------------------------------------------------------------
13497 ! energy_p_new-sep_barrier.F
13498 !-----------------------------------------------------------------------------
13499       subroutine sc_grad_scale(scalfac)
13500 !      implicit real*8 (a-h,o-z)
13501       use calc_data
13502 !      include 'DIMENSIONS'
13503 !      include 'COMMON.CHAIN'
13504 !      include 'COMMON.DERIV'
13505 !      include 'COMMON.CALC'
13506 !      include 'COMMON.IOUNITS'
13507       real(kind=8),dimension(3) :: dcosom1,dcosom2
13508       real(kind=8) :: scalfac
13509 !el local variables
13510 !      integer :: i,j,k,l
13511
13512       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
13513       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
13514       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
13515            -2.0D0*alf12*eps3der+sigder*sigsq_om12
13516 ! diagnostics only
13517 !      eom1=0.0d0
13518 !      eom2=0.0d0
13519 !      eom12=evdwij*eps1_om12
13520 ! end diagnostics
13521 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
13522 !     &  " sigder",sigder
13523 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
13524 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
13525       do k=1,3
13526         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
13527         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
13528       enddo
13529       do k=1,3
13530         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
13531          *sss_ele_cut
13532       enddo
13533 !      write (iout,*) "gg",(gg(k),k=1,3)
13534       do k=1,3
13535         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
13536                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
13537                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
13538                  *sss_ele_cut
13539         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
13540                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
13541                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
13542          *sss_ele_cut
13543 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
13544 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
13545 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
13546 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
13547       enddo
13548 !
13549 ! Calculate the components of the gradient in DC and X
13550 !
13551       do l=1,3
13552         gvdwc(l,i)=gvdwc(l,i)-gg(l)
13553         gvdwc(l,j)=gvdwc(l,j)+gg(l)
13554       enddo
13555       return
13556       end subroutine sc_grad_scale
13557 !-----------------------------------------------------------------------------
13558 ! energy_split-sep.F
13559 !-----------------------------------------------------------------------------
13560       subroutine etotal_long(energia)
13561 !
13562 ! Compute the long-range slow-varying contributions to the energy
13563 !
13564 !      implicit real*8 (a-h,o-z)
13565 !      include 'DIMENSIONS'
13566       use MD_data, only: totT,usampl,eq_time
13567 #ifndef ISNAN
13568       external proc_proc
13569 #ifdef WINPGI
13570 !MS$ATTRIBUTES C ::  proc_proc
13571 #endif
13572 #endif
13573 #ifdef MPI
13574       include "mpif.h"
13575       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
13576 #endif
13577 !      include 'COMMON.SETUP'
13578 !      include 'COMMON.IOUNITS'
13579 !      include 'COMMON.FFIELD'
13580 !      include 'COMMON.DERIV'
13581 !      include 'COMMON.INTERACT'
13582 !      include 'COMMON.SBRIDGE'
13583 !      include 'COMMON.CHAIN'
13584 !      include 'COMMON.VAR'
13585 !      include 'COMMON.LOCAL'
13586 !      include 'COMMON.MD'
13587       real(kind=8),dimension(0:n_ene) :: energia
13588 !el local variables
13589       integer :: i,n_corr,n_corr1,ierror,ierr
13590       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
13591                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
13592                   ecorr,ecorr5,ecorr6,eturn6,time00
13593 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
13594 !elwrite(iout,*)"in etotal long"
13595
13596       if (modecalc.eq.12.or.modecalc.eq.14) then
13597 #ifdef MPI
13598 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
13599 #else
13600         call int_from_cart1(.false.)
13601 #endif
13602       endif
13603 !elwrite(iout,*)"in etotal long"
13604
13605 #ifdef MPI
13606 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
13607 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13608       call flush(iout)
13609       if (nfgtasks.gt.1) then
13610         time00=MPI_Wtime()
13611 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13612         if (fg_rank.eq.0) then
13613           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
13614 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13615 !          call flush(iout)
13616 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13617 ! FG slaves as WEIGHTS array.
13618           weights_(1)=wsc
13619           weights_(2)=wscp
13620           weights_(3)=welec
13621           weights_(4)=wcorr
13622           weights_(5)=wcorr5
13623           weights_(6)=wcorr6
13624           weights_(7)=wel_loc
13625           weights_(8)=wturn3
13626           weights_(9)=wturn4
13627           weights_(10)=wturn6
13628           weights_(11)=wang
13629           weights_(12)=wscloc
13630           weights_(13)=wtor
13631           weights_(14)=wtor_d
13632           weights_(15)=wstrain
13633           weights_(16)=wvdwpp
13634           weights_(17)=wbond
13635           weights_(18)=scal14
13636           weights_(21)=wsccor
13637 ! FG Master broadcasts the WEIGHTS_ array
13638           call MPI_Bcast(weights_(1),n_ene,&
13639               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13640         else
13641 ! FG slaves receive the WEIGHTS array
13642           call MPI_Bcast(weights(1),n_ene,&
13643               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13644           wsc=weights(1)
13645           wscp=weights(2)
13646           welec=weights(3)
13647           wcorr=weights(4)
13648           wcorr5=weights(5)
13649           wcorr6=weights(6)
13650           wel_loc=weights(7)
13651           wturn3=weights(8)
13652           wturn4=weights(9)
13653           wturn6=weights(10)
13654           wang=weights(11)
13655           wscloc=weights(12)
13656           wtor=weights(13)
13657           wtor_d=weights(14)
13658           wstrain=weights(15)
13659           wvdwpp=weights(16)
13660           wbond=weights(17)
13661           scal14=weights(18)
13662           wsccor=weights(21)
13663         endif
13664         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
13665           king,FG_COMM,IERR)
13666          time_Bcast=time_Bcast+MPI_Wtime()-time00
13667          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
13668 !        call chainbuild_cart
13669 !        call int_from_cart1(.false.)
13670       endif
13671 !      write (iout,*) 'Processor',myrank,
13672 !     &  ' calling etotal_short ipot=',ipot
13673 !      call flush(iout)
13674 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13675 #endif
13676 !d    print *,'nnt=',nnt,' nct=',nct
13677 !
13678 !elwrite(iout,*)"in etotal long"
13679 ! Compute the side-chain and electrostatic interaction energy
13680 !
13681       goto (101,102,103,104,105,106) ipot
13682 ! Lennard-Jones potential.
13683   101 call elj_long(evdw)
13684 !d    print '(a)','Exit ELJ'
13685       goto 107
13686 ! Lennard-Jones-Kihara potential (shifted).
13687   102 call eljk_long(evdw)
13688       goto 107
13689 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13690   103 call ebp_long(evdw)
13691       goto 107
13692 ! Gay-Berne potential (shifted LJ, angular dependence).
13693   104 call egb_long(evdw)
13694       goto 107
13695 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13696   105 call egbv_long(evdw)
13697       goto 107
13698 ! Soft-sphere potential
13699   106 call e_softsphere(evdw)
13700 !
13701 ! Calculate electrostatic (H-bonding) energy of the main chain.
13702 !
13703   107 continue
13704       call vec_and_deriv
13705       if (ipot.lt.6) then
13706 #ifdef SPLITELE
13707          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
13708              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13709              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13710              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13711 #else
13712          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
13713              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
13714              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
13715              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
13716 #endif
13717            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13718          else
13719             ees=0
13720             evdw1=0
13721             eel_loc=0
13722             eello_turn3=0
13723             eello_turn4=0
13724          endif
13725       else
13726 !        write (iout,*) "Soft-spheer ELEC potential"
13727         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
13728          eello_turn4)
13729       endif
13730 !
13731 ! Calculate excluded-volume interaction energy between peptide groups
13732 ! and side chains.
13733 !
13734       if (ipot.lt.6) then
13735        if(wscp.gt.0d0) then
13736         call escp_long(evdw2,evdw2_14)
13737        else
13738         evdw2=0
13739         evdw2_14=0
13740        endif
13741       else
13742         call escp_soft_sphere(evdw2,evdw2_14)
13743       endif
13744 !
13745 ! 12/1/95 Multi-body terms
13746 !
13747       n_corr=0
13748       n_corr1=0
13749       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
13750           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
13751          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
13752 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
13753 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
13754       else
13755          ecorr=0.0d0
13756          ecorr5=0.0d0
13757          ecorr6=0.0d0
13758          eturn6=0.0d0
13759       endif
13760       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
13761          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
13762       endif
13763 !
13764 ! If performing constraint dynamics, call the constraint energy
13765 !  after the equilibration time
13766       if(usampl.and.totT.gt.eq_time) then
13767          call EconstrQ
13768          call Econstr_back
13769       else
13770          Uconst=0.0d0
13771          Uconst_back=0.0d0
13772       endif
13773 !
13774 ! Sum the energies
13775 !
13776       do i=1,n_ene
13777         energia(i)=0.0d0
13778       enddo
13779       energia(1)=evdw
13780 #ifdef SCP14
13781       energia(2)=evdw2-evdw2_14
13782       energia(18)=evdw2_14
13783 #else
13784       energia(2)=evdw2
13785       energia(18)=0.0d0
13786 #endif
13787 #ifdef SPLITELE
13788       energia(3)=ees
13789       energia(16)=evdw1
13790 #else
13791       energia(3)=ees+evdw1
13792       energia(16)=0.0d0
13793 #endif
13794       energia(4)=ecorr
13795       energia(5)=ecorr5
13796       energia(6)=ecorr6
13797       energia(7)=eel_loc
13798       energia(8)=eello_turn3
13799       energia(9)=eello_turn4
13800       energia(10)=eturn6
13801       energia(20)=Uconst+Uconst_back
13802       call sum_energy(energia,.true.)
13803 !      write (iout,*) "Exit ETOTAL_LONG"
13804       call flush(iout)
13805       return
13806       end subroutine etotal_long
13807 !-----------------------------------------------------------------------------
13808       subroutine etotal_short(energia)
13809 !
13810 ! Compute the short-range fast-varying contributions to the energy
13811 !
13812 !      implicit real*8 (a-h,o-z)
13813 !      include 'DIMENSIONS'
13814 #ifndef ISNAN
13815       external proc_proc
13816 #ifdef WINPGI
13817 !MS$ATTRIBUTES C ::  proc_proc
13818 #endif
13819 #endif
13820 #ifdef MPI
13821       include "mpif.h"
13822       integer :: ierror,ierr
13823       real(kind=8),dimension(n_ene) :: weights_
13824       real(kind=8) :: time00
13825 #endif
13826 !      include 'COMMON.SETUP'
13827 !      include 'COMMON.IOUNITS'
13828 !      include 'COMMON.FFIELD'
13829 !      include 'COMMON.DERIV'
13830 !      include 'COMMON.INTERACT'
13831 !      include 'COMMON.SBRIDGE'
13832 !      include 'COMMON.CHAIN'
13833 !      include 'COMMON.VAR'
13834 !      include 'COMMON.LOCAL'
13835       real(kind=8),dimension(0:n_ene) :: energia
13836 !el local variables
13837       integer :: i,nres6
13838       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
13839       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
13840       nres6=6*nres
13841
13842 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
13843 !      call flush(iout)
13844       if (modecalc.eq.12.or.modecalc.eq.14) then
13845 #ifdef MPI
13846         if (fg_rank.eq.0) call int_from_cart1(.false.)
13847 #else
13848         call int_from_cart1(.false.)
13849 #endif
13850       endif
13851 #ifdef MPI
13852 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
13853 !     & " absolute rank",myrank," nfgtasks",nfgtasks
13854 !      call flush(iout)
13855       if (nfgtasks.gt.1) then
13856         time00=MPI_Wtime()
13857 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
13858         if (fg_rank.eq.0) then
13859           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
13860 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
13861 !          call flush(iout)
13862 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
13863 ! FG slaves as WEIGHTS array.
13864           weights_(1)=wsc
13865           weights_(2)=wscp
13866           weights_(3)=welec
13867           weights_(4)=wcorr
13868           weights_(5)=wcorr5
13869           weights_(6)=wcorr6
13870           weights_(7)=wel_loc
13871           weights_(8)=wturn3
13872           weights_(9)=wturn4
13873           weights_(10)=wturn6
13874           weights_(11)=wang
13875           weights_(12)=wscloc
13876           weights_(13)=wtor
13877           weights_(14)=wtor_d
13878           weights_(15)=wstrain
13879           weights_(16)=wvdwpp
13880           weights_(17)=wbond
13881           weights_(18)=scal14
13882           weights_(21)=wsccor
13883 ! FG Master broadcasts the WEIGHTS_ array
13884           call MPI_Bcast(weights_(1),n_ene,&
13885               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13886         else
13887 ! FG slaves receive the WEIGHTS array
13888           call MPI_Bcast(weights(1),n_ene,&
13889               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
13890           wsc=weights(1)
13891           wscp=weights(2)
13892           welec=weights(3)
13893           wcorr=weights(4)
13894           wcorr5=weights(5)
13895           wcorr6=weights(6)
13896           wel_loc=weights(7)
13897           wturn3=weights(8)
13898           wturn4=weights(9)
13899           wturn6=weights(10)
13900           wang=weights(11)
13901           wscloc=weights(12)
13902           wtor=weights(13)
13903           wtor_d=weights(14)
13904           wstrain=weights(15)
13905           wvdwpp=weights(16)
13906           wbond=weights(17)
13907           scal14=weights(18)
13908           wsccor=weights(21)
13909         endif
13910 !        write (iout,*),"Processor",myrank," BROADCAST weights"
13911         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
13912           king,FG_COMM,IERR)
13913 !        write (iout,*) "Processor",myrank," BROADCAST c"
13914         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
13915           king,FG_COMM,IERR)
13916 !        write (iout,*) "Processor",myrank," BROADCAST dc"
13917         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
13918           king,FG_COMM,IERR)
13919 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
13920         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
13921           king,FG_COMM,IERR)
13922 !        write (iout,*) "Processor",myrank," BROADCAST theta"
13923         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
13924           king,FG_COMM,IERR)
13925 !        write (iout,*) "Processor",myrank," BROADCAST phi"
13926         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
13927           king,FG_COMM,IERR)
13928 !        write (iout,*) "Processor",myrank," BROADCAST alph"
13929         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
13930           king,FG_COMM,IERR)
13931 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
13932         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
13933           king,FG_COMM,IERR)
13934 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
13935         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
13936           king,FG_COMM,IERR)
13937          time_Bcast=time_Bcast+MPI_Wtime()-time00
13938 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
13939       endif
13940 !      write (iout,*) 'Processor',myrank,
13941 !     &  ' calling etotal_short ipot=',ipot
13942 !      call flush(iout)
13943 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
13944 #endif
13945 !      call int_from_cart1(.false.)
13946 !
13947 ! Compute the side-chain and electrostatic interaction energy
13948 !
13949       goto (101,102,103,104,105,106) ipot
13950 ! Lennard-Jones potential.
13951   101 call elj_short(evdw)
13952 !d    print '(a)','Exit ELJ'
13953       goto 107
13954 ! Lennard-Jones-Kihara potential (shifted).
13955   102 call eljk_short(evdw)
13956       goto 107
13957 ! Berne-Pechukas potential (dilated LJ, angular dependence).
13958   103 call ebp_short(evdw)
13959       goto 107
13960 ! Gay-Berne potential (shifted LJ, angular dependence).
13961   104 call egb_short(evdw)
13962       goto 107
13963 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
13964   105 call egbv_short(evdw)
13965       goto 107
13966 ! Soft-sphere potential - already dealt with in the long-range part
13967   106 evdw=0.0d0
13968 !  106 call e_softsphere_short(evdw)
13969 !
13970 ! Calculate electrostatic (H-bonding) energy of the main chain.
13971 !
13972   107 continue
13973 !
13974 ! Calculate the short-range part of Evdwpp
13975 !
13976       call evdwpp_short(evdw1)
13977 !
13978 ! Calculate the short-range part of ESCp
13979 !
13980       if (ipot.lt.6) then
13981         call escp_short(evdw2,evdw2_14)
13982       endif
13983 !
13984 ! Calculate the bond-stretching energy
13985 !
13986       call ebond(estr)
13987 !
13988 ! Calculate the disulfide-bridge and other energy and the contributions
13989 ! from other distance constraints.
13990       call edis(ehpb)
13991 !
13992 ! Calculate the virtual-bond-angle energy.
13993 !
13994       call ebend(ebe)
13995 !
13996 ! Calculate the SC local energy.
13997 !
13998       call vec_and_deriv
13999       call esc(escloc)
14000 !
14001 ! Calculate the virtual-bond torsional energy.
14002 !
14003       call etor(etors,edihcnstr)
14004 !
14005 ! 6/23/01 Calculate double-torsional energy
14006 !
14007       call etor_d(etors_d)
14008 !
14009 ! 21/5/07 Calculate local sicdechain correlation energy
14010 !
14011       if (wsccor.gt.0.0d0) then
14012         call eback_sc_corr(esccor)
14013       else
14014         esccor=0.0d0
14015       endif
14016 !
14017 ! Put energy components into an array
14018 !
14019       do i=1,n_ene
14020         energia(i)=0.0d0
14021       enddo
14022       energia(1)=evdw
14023 #ifdef SCP14
14024       energia(2)=evdw2-evdw2_14
14025       energia(18)=evdw2_14
14026 #else
14027       energia(2)=evdw2
14028       energia(18)=0.0d0
14029 #endif
14030 #ifdef SPLITELE
14031       energia(16)=evdw1
14032 #else
14033       energia(3)=evdw1
14034 #endif
14035       energia(11)=ebe
14036       energia(12)=escloc
14037       energia(13)=etors
14038       energia(14)=etors_d
14039       energia(15)=ehpb
14040       energia(17)=estr
14041       energia(19)=edihcnstr
14042       energia(21)=esccor
14043 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
14044       call flush(iout)
14045       call sum_energy(energia,.true.)
14046 !      write (iout,*) "Exit ETOTAL_SHORT"
14047       call flush(iout)
14048       return
14049       end subroutine etotal_short
14050 !-----------------------------------------------------------------------------
14051 ! gnmr1.f
14052 !-----------------------------------------------------------------------------
14053       real(kind=8) function gnmr1(y,ymin,ymax)
14054 !      implicit none
14055       real(kind=8) :: y,ymin,ymax
14056       real(kind=8) :: wykl=4.0d0
14057       if (y.lt.ymin) then
14058         gnmr1=(ymin-y)**wykl/wykl
14059       else if (y.gt.ymax) then
14060         gnmr1=(y-ymax)**wykl/wykl
14061       else
14062         gnmr1=0.0d0
14063       endif
14064       return
14065       end function gnmr1
14066 !-----------------------------------------------------------------------------
14067       real(kind=8) function gnmr1prim(y,ymin,ymax)
14068 !      implicit none
14069       real(kind=8) :: y,ymin,ymax
14070       real(kind=8) :: wykl=4.0d0
14071       if (y.lt.ymin) then
14072         gnmr1prim=-(ymin-y)**(wykl-1)
14073       else if (y.gt.ymax) then
14074         gnmr1prim=(y-ymax)**(wykl-1)
14075       else
14076         gnmr1prim=0.0d0
14077       endif
14078       return
14079       end function gnmr1prim
14080 !-----------------------------------------------------------------------------
14081       real(kind=8) function harmonic(y,ymax)
14082 !      implicit none
14083       real(kind=8) :: y,ymax
14084       real(kind=8) :: wykl=2.0d0
14085       harmonic=(y-ymax)**wykl
14086       return
14087       end function harmonic
14088 !-----------------------------------------------------------------------------
14089       real(kind=8) function harmonicprim(y,ymax)
14090       real(kind=8) :: y,ymin,ymax
14091       real(kind=8) :: wykl=2.0d0
14092       harmonicprim=(y-ymax)*wykl
14093       return
14094       end function harmonicprim
14095 !-----------------------------------------------------------------------------
14096 ! gradient_p.F
14097 !-----------------------------------------------------------------------------
14098       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
14099
14100       use io_base, only:intout,briefout
14101 !      implicit real*8 (a-h,o-z)
14102 !      include 'DIMENSIONS'
14103 !      include 'COMMON.CHAIN'
14104 !      include 'COMMON.DERIV'
14105 !      include 'COMMON.VAR'
14106 !      include 'COMMON.INTERACT'
14107 !      include 'COMMON.FFIELD'
14108 !      include 'COMMON.MD'
14109 !      include 'COMMON.IOUNITS'
14110       real(kind=8),external :: ufparm
14111       integer :: uiparm(1)
14112       real(kind=8) :: urparm(1)
14113       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
14114       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
14115       integer :: n,nf,ind,ind1,i,k,j
14116 !
14117 ! This subroutine calculates total internal coordinate gradient.
14118 ! Depending on the number of function evaluations, either whole energy
14119 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
14120 ! internal coordinates are reevaluated or only the cartesian-in-internal
14121 ! coordinate derivatives are evaluated. The subroutine was designed to work
14122 ! with SUMSL.
14123 !
14124 !
14125       icg=mod(nf,2)+1
14126
14127 !d      print *,'grad',nf,icg
14128       if (nf-nfl+1) 20,30,40
14129    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
14130 !    write (iout,*) 'grad 20'
14131       if (nf.eq.0) return
14132       goto 40
14133    30 call var_to_geom(n,x)
14134       call chainbuild
14135 !    write (iout,*) 'grad 30'
14136 !
14137 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
14138 !
14139    40 call cartder
14140 !     write (iout,*) 'grad 40'
14141 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
14142 !
14143 ! Convert the Cartesian gradient into internal-coordinate gradient.
14144 !
14145       ind=0
14146       ind1=0
14147       do i=1,nres-2
14148         gthetai=0.0D0
14149         gphii=0.0D0
14150         do j=i+1,nres-1
14151           ind=ind+1
14152 !         ind=indmat(i,j)
14153 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
14154           do k=1,3
14155             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
14156           enddo
14157           do k=1,3
14158             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
14159           enddo
14160         enddo
14161         do j=i+1,nres-1
14162           ind1=ind1+1
14163 !         ind1=indmat(i,j)
14164 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
14165           do k=1,3
14166             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
14167             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
14168           enddo
14169         enddo
14170         if (i.gt.1) g(i-1)=gphii
14171         if (n.gt.nphi) g(nphi+i)=gthetai
14172       enddo
14173       if (n.le.nphi+ntheta) goto 10
14174       do i=2,nres-1
14175         if (itype(i).ne.10) then
14176           galphai=0.0D0
14177           gomegai=0.0D0
14178           do k=1,3
14179             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
14180           enddo
14181           do k=1,3
14182             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
14183           enddo
14184           g(ialph(i,1))=galphai
14185           g(ialph(i,1)+nside)=gomegai
14186         endif
14187       enddo
14188 !
14189 ! Add the components corresponding to local energy terms.
14190 !
14191    10 continue
14192       do i=1,nvar
14193 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
14194         g(i)=g(i)+gloc(i,icg)
14195       enddo
14196 ! Uncomment following three lines for diagnostics.
14197 !d    call intout
14198 !elwrite(iout,*) "in gradient after calling intout"
14199 !d    call briefout(0,0.0d0)
14200 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
14201       return
14202       end subroutine gradient
14203 !-----------------------------------------------------------------------------
14204       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
14205
14206       use comm_chu
14207 !      implicit real*8 (a-h,o-z)
14208 !      include 'DIMENSIONS'
14209 !      include 'COMMON.DERIV'
14210 !      include 'COMMON.IOUNITS'
14211 !      include 'COMMON.GEO'
14212       integer :: n,nf
14213 !el      integer :: jjj
14214 !el      common /chuju/ jjj
14215       real(kind=8) :: energia(0:n_ene)
14216       integer :: uiparm(1)
14217       real(kind=8) :: urparm(1)
14218       real(kind=8) :: f
14219       real(kind=8),external :: ufparm
14220       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
14221 !     if (jjj.gt.0) then
14222 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14223 !     endif
14224       nfl=nf
14225       icg=mod(nf,2)+1
14226 !d      print *,'func',nf,nfl,icg
14227       call var_to_geom(n,x)
14228       call zerograd
14229       call chainbuild
14230 !d    write (iout,*) 'ETOTAL called from FUNC'
14231       call etotal(energia)
14232       call sum_gradient
14233       f=energia(0)
14234 !     if (jjj.gt.0) then
14235 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
14236 !       write (iout,*) 'f=',etot
14237 !       jjj=0
14238 !     endif
14239       return
14240       end subroutine func
14241 !-----------------------------------------------------------------------------
14242       subroutine cartgrad
14243 !      implicit real*8 (a-h,o-z)
14244 !      include 'DIMENSIONS'
14245       use energy_data
14246       use MD_data, only: totT,usampl,eq_time
14247 #ifdef MPI
14248       include 'mpif.h'
14249 #endif
14250 !      include 'COMMON.CHAIN'
14251 !      include 'COMMON.DERIV'
14252 !      include 'COMMON.VAR'
14253 !      include 'COMMON.INTERACT'
14254 !      include 'COMMON.FFIELD'
14255 !      include 'COMMON.MD'
14256 !      include 'COMMON.IOUNITS'
14257 !      include 'COMMON.TIME1'
14258 !
14259       integer :: i,j
14260
14261 ! This subrouting calculates total Cartesian coordinate gradient.
14262 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
14263 !
14264 !el#define DEBUG
14265 #ifdef TIMING
14266       time00=MPI_Wtime()
14267 #endif
14268       icg=1
14269       call sum_gradient
14270 #ifdef TIMING
14271 #endif
14272 !el      write (iout,*) "After sum_gradient"
14273 #ifdef DEBUG
14274 !el      write (iout,*) "After sum_gradient"
14275       do i=1,nres-1
14276         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
14277         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
14278       enddo
14279 #endif
14280 ! If performing constraint dynamics, add the gradients of the constraint energy
14281       if(usampl.and.totT.gt.eq_time) then
14282          do i=1,nct
14283            do j=1,3
14284              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
14285              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
14286            enddo
14287          enddo
14288          do i=1,nres-3
14289            gloc(i,icg)=gloc(i,icg)+dugamma(i)
14290          enddo
14291          do i=1,nres-2
14292            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
14293          enddo
14294       endif
14295 !elwrite (iout,*) "After sum_gradient"
14296 #ifdef TIMING
14297       time01=MPI_Wtime()
14298 #endif
14299       call intcartderiv
14300 !elwrite (iout,*) "After sum_gradient"
14301 #ifdef TIMING
14302       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
14303 #endif
14304 !     call checkintcartgrad
14305 !     write(iout,*) 'calling int_to_cart'
14306 #ifdef DEBUG
14307       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
14308 #endif
14309       do i=1,nct
14310         do j=1,3
14311           gcart(j,i)=gradc(j,i,icg)
14312           gxcart(j,i)=gradx(j,i,icg)
14313         enddo
14314 #ifdef DEBUG
14315         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
14316           (gxcart(j,i),j=1,3),gloc(i,icg)
14317 #endif
14318       enddo
14319 #ifdef TIMING
14320       time01=MPI_Wtime()
14321 #endif
14322       call int_to_cart
14323 #ifdef TIMING
14324       time_inttocart=time_inttocart+MPI_Wtime()-time01
14325 #endif
14326 #ifdef DEBUG
14327       write (iout,*) "gcart and gxcart after int_to_cart"
14328       do i=0,nres-1
14329         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
14330             (gxcart(j,i),j=1,3)
14331       enddo
14332 #endif
14333 #ifdef CARGRAD
14334 #ifdef DEBUG
14335       write (iout,*) "CARGRAD"
14336 #endif
14337       do i=nres,1,-1
14338         do j=1,3
14339           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14340 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
14341         enddo
14342 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
14343 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
14344       enddo
14345 ! Correction: dummy residues
14346         if (nnt.gt.1) then
14347           do j=1,3
14348 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
14349             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
14350           enddo
14351         endif
14352         if (nct.lt.nres) then
14353           do j=1,3
14354 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
14355             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
14356           enddo
14357         endif
14358 #endif
14359 #ifdef TIMING
14360       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
14361 #endif
14362 !el#undef DEBUG
14363       return
14364       end subroutine cartgrad
14365 !-----------------------------------------------------------------------------
14366       subroutine zerograd
14367 !      implicit real*8 (a-h,o-z)
14368 !      include 'DIMENSIONS'
14369 !      include 'COMMON.DERIV'
14370 !      include 'COMMON.CHAIN'
14371 !      include 'COMMON.VAR'
14372 !      include 'COMMON.MD'
14373 !      include 'COMMON.SCCOR'
14374 !
14375 !el local variables
14376       integer :: i,j,intertyp
14377 ! Initialize Cartesian-coordinate gradient
14378 !
14379 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
14380 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
14381
14382 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
14383 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
14384 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
14385 !      allocate(gradcorr_long(3,nres))
14386 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
14387 !      allocate(gcorr6_turn_long(3,nres))
14388 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
14389
14390 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
14391
14392 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
14393 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
14394
14395 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
14396 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
14397
14398 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
14399 !      allocate(gscloc(3,nres)) !(3,maxres)
14400 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
14401
14402
14403
14404 !      common /deriv_scloc/
14405 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
14406 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
14407 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
14408 !      common /mpgrad/
14409 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
14410
14411
14412
14413 !          gradc(j,i,icg)=0.0d0
14414 !          gradx(j,i,icg)=0.0d0
14415
14416 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
14417 !elwrite(iout,*) "icg",icg
14418       do i=1,nres
14419         do j=1,3
14420           gvdwx(j,i)=0.0D0
14421           gradx_scp(j,i)=0.0D0
14422           gvdwc(j,i)=0.0D0
14423           gvdwc_scp(j,i)=0.0D0
14424           gvdwc_scpp(j,i)=0.0d0
14425           gelc(j,i)=0.0D0
14426           gelc_long(j,i)=0.0D0
14427           gradb(j,i)=0.0d0
14428           gradbx(j,i)=0.0d0
14429           gvdwpp(j,i)=0.0d0
14430           gel_loc(j,i)=0.0d0
14431           gel_loc_long(j,i)=0.0d0
14432           ghpbc(j,i)=0.0D0
14433           ghpbx(j,i)=0.0D0
14434           gcorr3_turn(j,i)=0.0d0
14435           gcorr4_turn(j,i)=0.0d0
14436           gradcorr(j,i)=0.0d0
14437           gradcorr_long(j,i)=0.0d0
14438           gradcorr5_long(j,i)=0.0d0
14439           gradcorr6_long(j,i)=0.0d0
14440           gcorr6_turn_long(j,i)=0.0d0
14441           gradcorr5(j,i)=0.0d0
14442           gradcorr6(j,i)=0.0d0
14443           gcorr6_turn(j,i)=0.0d0
14444           gsccorc(j,i)=0.0d0
14445           gsccorx(j,i)=0.0d0
14446           gradc(j,i,icg)=0.0d0
14447           gradx(j,i,icg)=0.0d0
14448           gscloc(j,i)=0.0d0
14449           gsclocx(j,i)=0.0d0
14450           do intertyp=1,3
14451            gloc_sc(intertyp,i,icg)=0.0d0
14452           enddo
14453         enddo
14454       enddo
14455 !
14456 ! Initialize the gradient of local energy terms.
14457 !
14458 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
14459 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14460 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14461 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
14462 !      allocate(gel_loc_turn3(nres))
14463 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
14464 !      allocate(gsccor_loc(nres))       !(maxres)
14465
14466       do i=1,4*nres
14467         gloc(i,icg)=0.0D0
14468       enddo
14469       do i=1,nres
14470         gel_loc_loc(i)=0.0d0
14471         gcorr_loc(i)=0.0d0
14472         g_corr5_loc(i)=0.0d0
14473         g_corr6_loc(i)=0.0d0
14474         gel_loc_turn3(i)=0.0d0
14475         gel_loc_turn4(i)=0.0d0
14476         gel_loc_turn6(i)=0.0d0
14477         gsccor_loc(i)=0.0d0
14478       enddo
14479 ! initialize gcart and gxcart
14480 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
14481       do i=0,nres
14482         do j=1,3
14483           gcart(j,i)=0.0d0
14484           gxcart(j,i)=0.0d0
14485         enddo
14486       enddo
14487       return
14488       end subroutine zerograd
14489 !-----------------------------------------------------------------------------
14490       real(kind=8) function fdum()
14491       fdum=0.0D0
14492       return
14493       end function fdum
14494 !-----------------------------------------------------------------------------
14495 ! intcartderiv.F
14496 !-----------------------------------------------------------------------------
14497       subroutine intcartderiv
14498 !      implicit real*8 (a-h,o-z)
14499 !      include 'DIMENSIONS'
14500 #ifdef MPI
14501       include 'mpif.h'
14502 #endif
14503 !      include 'COMMON.SETUP'
14504 !      include 'COMMON.CHAIN'
14505 !      include 'COMMON.VAR'
14506 !      include 'COMMON.GEO'
14507 !      include 'COMMON.INTERACT'
14508 !      include 'COMMON.DERIV'
14509 !      include 'COMMON.IOUNITS'
14510 !      include 'COMMON.LOCAL'
14511 !      include 'COMMON.SCCOR'
14512       real(kind=8) :: pi4,pi34
14513       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
14514       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
14515                     dcosomega,dsinomega !(3,3,maxres)
14516       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
14517
14518       integer :: i,j,k
14519       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
14520                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
14521                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
14522                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
14523       integer :: nres2
14524       nres2=2*nres
14525
14526 !el from module energy-------------
14527 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
14528 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
14529 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
14530
14531 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
14532 !el      allocate(dsintau(3,3,3,0:nres2))
14533 !el      allocate(dtauangle(3,3,3,0:nres2))
14534 !el      allocate(domicron(3,2,2,0:nres2))
14535 !el      allocate(dcosomicron(3,2,2,0:nres2))
14536
14537
14538
14539 #if defined(MPI) && defined(PARINTDER)
14540       if (nfgtasks.gt.1 .and. me.eq.king) &
14541         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
14542 #endif
14543       pi4 = 0.5d0*pipol
14544       pi34 = 3*pi4
14545
14546 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
14547 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
14548
14549 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
14550       do i=1,nres
14551         do j=1,3
14552           dtheta(j,1,i)=0.0d0
14553           dtheta(j,2,i)=0.0d0
14554           dphi(j,1,i)=0.0d0
14555           dphi(j,2,i)=0.0d0
14556           dphi(j,3,i)=0.0d0
14557         enddo
14558       enddo
14559 ! Derivatives of theta's
14560 #if defined(MPI) && defined(PARINTDER)
14561 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14562       do i=max0(ithet_start-1,3),ithet_end
14563 #else
14564       do i=3,nres
14565 #endif
14566         cost=dcos(theta(i))
14567         sint=sqrt(1-cost*cost)
14568         do j=1,3
14569           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
14570           vbld(i-1)
14571           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
14572           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
14573           vbld(i)
14574           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
14575         enddo
14576       enddo
14577 #if defined(MPI) && defined(PARINTDER)
14578 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
14579       do i=max0(ithet_start-1,3),ithet_end
14580 #else
14581       do i=3,nres
14582 #endif
14583       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
14584         cost1=dcos(omicron(1,i))
14585         sint1=sqrt(1-cost1*cost1)
14586         cost2=dcos(omicron(2,i))
14587         sint2=sqrt(1-cost2*cost2)
14588        do j=1,3
14589 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
14590           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
14591           cost1*dc_norm(j,i-2))/ &
14592           vbld(i-1)
14593           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
14594           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
14595           +cost1*(dc_norm(j,i-1+nres)))/ &
14596           vbld(i-1+nres)
14597           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
14598 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
14599 !C Looks messy but better than if in loop
14600           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
14601           +cost2*dc_norm(j,i-1))/ &
14602           vbld(i)
14603           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
14604           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
14605            +cost2*(-dc_norm(j,i-1+nres)))/ &
14606           vbld(i-1+nres)
14607 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
14608           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
14609         enddo
14610        endif
14611       enddo
14612 !elwrite(iout,*) "after vbld write"
14613 ! Derivatives of phi:
14614 ! If phi is 0 or 180 degrees, then the formulas
14615 ! have to be derived by power series expansion of the
14616 ! conventional formulas around 0 and 180.
14617 #ifdef PARINTDER
14618       do i=iphi1_start,iphi1_end
14619 #else
14620       do i=4,nres
14621 #endif
14622 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
14623 ! the conventional case
14624         sint=dsin(theta(i))
14625         sint1=dsin(theta(i-1))
14626         sing=dsin(phi(i))
14627         cost=dcos(theta(i))
14628         cost1=dcos(theta(i-1))
14629         cosg=dcos(phi(i))
14630         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
14631         fac0=1.0d0/(sint1*sint)
14632         fac1=cost*fac0
14633         fac2=cost1*fac0
14634         fac3=cosg*cost1/(sint1*sint1)
14635         fac4=cosg*cost/(sint*sint)
14636 !    Obtaining the gamma derivatives from sine derivative
14637        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
14638            phi(i).gt.pi34.and.phi(i).le.pi.or. &
14639            phi(i).gt.-pi.and.phi(i).le.-pi34) then
14640          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14641          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
14642          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14643          do j=1,3
14644             ctgt=cost/sint
14645             ctgt1=cost1/sint1
14646             cosg_inv=1.0d0/cosg
14647             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14648             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14649               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
14650             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
14651             dsinphi(j,2,i)= &
14652               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
14653               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14654             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
14655             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
14656               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14657 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14658             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
14659             endif
14660 ! Bug fixed 3/24/05 (AL)
14661          enddo
14662 !   Obtaining the gamma derivatives from cosine derivative
14663         else
14664            do j=1,3
14665            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
14666            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14667            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14668            dc_norm(j,i-3))/vbld(i-2)
14669            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
14670            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14671            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14672            dcostheta(j,1,i)
14673            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
14674            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14675            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14676            dc_norm(j,i-1))/vbld(i)
14677            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
14678            endif
14679          enddo
14680         endif
14681       enddo
14682 !alculate derivative of Tauangle
14683 #ifdef PARINTDER
14684       do i=itau_start,itau_end
14685 #else
14686       do i=3,nres
14687 !elwrite(iout,*) " vecpr",i,nres
14688 #endif
14689        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14690 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
14691 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
14692 !c dtauangle(j,intertyp,dervityp,residue number)
14693 !c INTERTYP=1 SC...Ca...Ca..Ca
14694 ! the conventional case
14695         sint=dsin(theta(i))
14696         sint1=dsin(omicron(2,i-1))
14697         sing=dsin(tauangle(1,i))
14698         cost=dcos(theta(i))
14699         cost1=dcos(omicron(2,i-1))
14700         cosg=dcos(tauangle(1,i))
14701 !elwrite(iout,*) " vecpr5",i,nres
14702         do j=1,3
14703 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
14704 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
14705         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14706 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
14707         enddo
14708         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
14709         fac0=1.0d0/(sint1*sint)
14710         fac1=cost*fac0
14711         fac2=cost1*fac0
14712         fac3=cosg*cost1/(sint1*sint1)
14713         fac4=cosg*cost/(sint*sint)
14714 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
14715 !    Obtaining the gamma derivatives from sine derivative
14716        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
14717            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
14718            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
14719          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
14720          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
14721          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14722         do j=1,3
14723             ctgt=cost/sint
14724             ctgt1=cost1/sint1
14725             cosg_inv=1.0d0/cosg
14726             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14727        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
14728        *vbld_inv(i-2+nres)
14729             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
14730             dsintau(j,1,2,i)= &
14731               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
14732               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14733 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
14734             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
14735 ! Bug fixed 3/24/05 (AL)
14736             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
14737               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
14738 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14739             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
14740          enddo
14741 !   Obtaining the gamma derivatives from cosine derivative
14742         else
14743            do j=1,3
14744            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14745            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
14746            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
14747            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
14748            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14749            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14750            dcostheta(j,1,i)
14751            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
14752            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
14753            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
14754            dc_norm(j,i-1))/vbld(i)
14755            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
14756 !         write (iout,*) "else",i
14757          enddo
14758         endif
14759 !        do k=1,3
14760 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
14761 !        enddo
14762       enddo
14763 !C Second case Ca...Ca...Ca...SC
14764 #ifdef PARINTDER
14765       do i=itau_start,itau_end
14766 #else
14767       do i=4,nres
14768 #endif
14769        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14770           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
14771 ! the conventional case
14772         sint=dsin(omicron(1,i))
14773         sint1=dsin(theta(i-1))
14774         sing=dsin(tauangle(2,i))
14775         cost=dcos(omicron(1,i))
14776         cost1=dcos(theta(i-1))
14777         cosg=dcos(tauangle(2,i))
14778 !        do j=1,3
14779 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14780 !        enddo
14781         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
14782         fac0=1.0d0/(sint1*sint)
14783         fac1=cost*fac0
14784         fac2=cost1*fac0
14785         fac3=cosg*cost1/(sint1*sint1)
14786         fac4=cosg*cost/(sint*sint)
14787 !    Obtaining the gamma derivatives from sine derivative
14788        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
14789            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
14790            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
14791          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
14792          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
14793          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
14794         do j=1,3
14795             ctgt=cost/sint
14796             ctgt1=cost1/sint1
14797             cosg_inv=1.0d0/cosg
14798             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
14799               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
14800 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
14801 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
14802             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
14803             dsintau(j,2,2,i)= &
14804               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
14805               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14806 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
14807 !     & sing*ctgt*domicron(j,1,2,i),
14808 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14809             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
14810 ! Bug fixed 3/24/05 (AL)
14811             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14812              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
14813 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14814             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
14815          enddo
14816 !   Obtaining the gamma derivatives from cosine derivative
14817         else
14818            do j=1,3
14819            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
14820            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14821            dc_norm(j,i-3))/vbld(i-2)
14822            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
14823            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
14824            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
14825            dcosomicron(j,1,1,i)
14826            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
14827            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14828            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
14829            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14830            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
14831 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
14832          enddo
14833         endif
14834       enddo
14835
14836 !CC third case SC...Ca...Ca...SC
14837 #ifdef PARINTDER
14838
14839       do i=itau_start,itau_end
14840 #else
14841       do i=3,nres
14842 #endif
14843 ! the conventional case
14844       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
14845       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
14846         sint=dsin(omicron(1,i))
14847         sint1=dsin(omicron(2,i-1))
14848         sing=dsin(tauangle(3,i))
14849         cost=dcos(omicron(1,i))
14850         cost1=dcos(omicron(2,i-1))
14851         cosg=dcos(tauangle(3,i))
14852         do j=1,3
14853         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
14854 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
14855         enddo
14856         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
14857         fac0=1.0d0/(sint1*sint)
14858         fac1=cost*fac0
14859         fac2=cost1*fac0
14860         fac3=cosg*cost1/(sint1*sint1)
14861         fac4=cosg*cost/(sint*sint)
14862 !    Obtaining the gamma derivatives from sine derivative
14863        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
14864            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
14865            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
14866          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
14867          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
14868          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
14869         do j=1,3
14870             ctgt=cost/sint
14871             ctgt1=cost1/sint1
14872             cosg_inv=1.0d0/cosg
14873             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
14874               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
14875               *vbld_inv(i-2+nres)
14876             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
14877             dsintau(j,3,2,i)= &
14878               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
14879               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
14880             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
14881 ! Bug fixed 3/24/05 (AL)
14882             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
14883               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
14884               *vbld_inv(i-1+nres)
14885 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
14886             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
14887          enddo
14888 !   Obtaining the gamma derivatives from cosine derivative
14889         else
14890            do j=1,3
14891            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
14892            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
14893            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
14894            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
14895            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
14896            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
14897            dcosomicron(j,1,1,i)
14898            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
14899            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
14900            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
14901            dc_norm(j,i-1+nres))/vbld(i-1+nres)
14902            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
14903 !          write(iout,*) "else",i
14904          enddo
14905         endif
14906       enddo
14907
14908 #ifdef CRYST_SC
14909 !   Derivatives of side-chain angles alpha and omega
14910 #if defined(MPI) && defined(PARINTDER)
14911         do i=ibond_start,ibond_end
14912 #else
14913         do i=2,nres-1
14914 #endif
14915           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
14916              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
14917              fac6=fac5/vbld(i)
14918              fac7=fac5*fac5
14919              fac8=fac5/vbld(i+1)
14920              fac9=fac5/vbld(i+nres)
14921              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
14922              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
14923              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
14924              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
14925              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
14926              sina=sqrt(1-cosa*cosa)
14927              sino=dsin(omeg(i))
14928 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
14929              do j=1,3
14930                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
14931                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
14932                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
14933                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
14934                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
14935                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
14936                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
14937                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
14938                 vbld(i+nres))
14939                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
14940             enddo
14941 ! obtaining the derivatives of omega from sines
14942             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
14943                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
14944                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
14945                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
14946                dsin(theta(i+1)))
14947                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
14948                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
14949                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
14950                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
14951                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
14952                coso_inv=1.0d0/dcos(omeg(i))
14953                do j=1,3
14954                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
14955                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
14956                  (sino*dc_norm(j,i-1))/vbld(i)
14957                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
14958                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
14959                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
14960                  -sino*dc_norm(j,i)/vbld(i+1)
14961                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
14962                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
14963                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
14964                  vbld(i+nres)
14965                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
14966               enddo
14967            else
14968 !   obtaining the derivatives of omega from cosines
14969              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
14970              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
14971              fac12=fac10*sina
14972              fac13=fac12*fac12
14973              fac14=sina*sina
14974              do j=1,3
14975                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
14976                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
14977                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
14978                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
14979                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
14980                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
14981                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
14982                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
14983                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
14984                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
14985                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
14986                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
14987                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
14988                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
14989                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
14990             enddo
14991           endif
14992          else
14993            do j=1,3
14994              do k=1,3
14995                dalpha(k,j,i)=0.0d0
14996                domega(k,j,i)=0.0d0
14997              enddo
14998            enddo
14999          endif
15000        enddo
15001 #endif
15002 #if defined(MPI) && defined(PARINTDER)
15003       if (nfgtasks.gt.1) then
15004 #ifdef DEBUG
15005 !d      write (iout,*) "Gather dtheta"
15006 !d      call flush(iout)
15007       write (iout,*) "dtheta before gather"
15008       do i=1,nres
15009         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
15010       enddo
15011 #endif
15012       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
15013         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
15014         king,FG_COMM,IERROR)
15015 #ifdef DEBUG
15016 !d      write (iout,*) "Gather dphi"
15017 !d      call flush(iout)
15018       write (iout,*) "dphi before gather"
15019       do i=1,nres
15020         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
15021       enddo
15022 #endif
15023       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
15024         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
15025         king,FG_COMM,IERROR)
15026 !d      write (iout,*) "Gather dalpha"
15027 !d      call flush(iout)
15028 #ifdef CRYST_SC
15029       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
15030         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15031         king,FG_COMM,IERROR)
15032 !d      write (iout,*) "Gather domega"
15033 !d      call flush(iout)
15034       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
15035         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
15036         king,FG_COMM,IERROR)
15037 #endif
15038       endif
15039 #endif
15040 #ifdef DEBUG
15041       write (iout,*) "dtheta after gather"
15042       do i=1,nres
15043         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
15044       enddo
15045       write (iout,*) "dphi after gather"
15046       do i=1,nres
15047         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
15048       enddo
15049       write (iout,*) "dalpha after gather"
15050       do i=1,nres
15051         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
15052       enddo
15053       write (iout,*) "domega after gather"
15054       do i=1,nres
15055         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
15056       enddo
15057 #endif
15058       return
15059       end subroutine intcartderiv
15060 !-----------------------------------------------------------------------------
15061       subroutine checkintcartgrad
15062 !      implicit real*8 (a-h,o-z)
15063 !      include 'DIMENSIONS'
15064 #ifdef MPI
15065       include 'mpif.h'
15066 #endif
15067 !      include 'COMMON.CHAIN'
15068 !      include 'COMMON.VAR'
15069 !      include 'COMMON.GEO'
15070 !      include 'COMMON.INTERACT'
15071 !      include 'COMMON.DERIV'
15072 !      include 'COMMON.IOUNITS'
15073 !      include 'COMMON.SETUP'
15074       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
15075       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
15076       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
15077       real(kind=8),dimension(3) :: dc_norm_s
15078       real(kind=8) :: aincr=1.0d-5
15079       integer :: i,j
15080       real(kind=8) :: dcji
15081       do i=1,nres
15082         phi_s(i)=phi(i)
15083         theta_s(i)=theta(i)
15084         alph_s(i)=alph(i)
15085         omeg_s(i)=omeg(i)
15086       enddo
15087 ! Check theta gradient
15088       write (iout,*) &
15089        "Analytical (upper) and numerical (lower) gradient of theta"
15090       write (iout,*)
15091       do i=3,nres
15092         do j=1,3
15093           dcji=dc(j,i-2)
15094           dc(j,i-2)=dcji+aincr
15095           call chainbuild_cart
15096           call int_from_cart1(.false.)
15097           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
15098           dc(j,i-2)=dcji
15099           dcji=dc(j,i-1)
15100           dc(j,i-1)=dc(j,i-1)+aincr
15101           call chainbuild_cart
15102           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
15103           dc(j,i-1)=dcji
15104         enddo
15105 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
15106 !el          (dtheta(j,2,i),j=1,3)
15107 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
15108 !el          (dthetanum(j,2,i),j=1,3)
15109 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
15110 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
15111 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
15112 !el        write (iout,*)
15113       enddo
15114 ! Check gamma gradient
15115       write (iout,*) &
15116        "Analytical (upper) and numerical (lower) gradient of gamma"
15117       do i=4,nres
15118         do j=1,3
15119           dcji=dc(j,i-3)
15120           dc(j,i-3)=dcji+aincr
15121           call chainbuild_cart
15122           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
15123           dc(j,i-3)=dcji
15124           dcji=dc(j,i-2)
15125           dc(j,i-2)=dcji+aincr
15126           call chainbuild_cart
15127           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
15128           dc(j,i-2)=dcji
15129           dcji=dc(j,i-1)
15130           dc(j,i-1)=dc(j,i-1)+aincr
15131           call chainbuild_cart
15132           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
15133           dc(j,i-1)=dcji
15134         enddo
15135 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
15136 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
15137 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
15138 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
15139 !el        write (iout,'(5x,3(3f10.5,5x))') &
15140 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
15141 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
15142 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
15143 !el        write (iout,*)
15144       enddo
15145 ! Check alpha gradient
15146       write (iout,*) &
15147        "Analytical (upper) and numerical (lower) gradient of alpha"
15148       do i=2,nres-1
15149        if(itype(i).ne.10) then
15150             do j=1,3
15151               dcji=dc(j,i-1)
15152               dc(j,i-1)=dcji+aincr
15153               call chainbuild_cart
15154               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
15155               /aincr
15156               dc(j,i-1)=dcji
15157               dcji=dc(j,i)
15158               dc(j,i)=dcji+aincr
15159               call chainbuild_cart
15160               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
15161               /aincr
15162               dc(j,i)=dcji
15163               dcji=dc(j,i+nres)
15164               dc(j,i+nres)=dc(j,i+nres)+aincr
15165               call chainbuild_cart
15166               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
15167               /aincr
15168              dc(j,i+nres)=dcji
15169             enddo
15170           endif
15171 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
15172 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
15173 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
15174 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
15175 !el        write (iout,'(5x,3(3f10.5,5x))') &
15176 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
15177 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
15178 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
15179 !el        write (iout,*)
15180       enddo
15181 !     Check omega gradient
15182       write (iout,*) &
15183        "Analytical (upper) and numerical (lower) gradient of omega"
15184       do i=2,nres-1
15185        if(itype(i).ne.10) then
15186             do j=1,3
15187               dcji=dc(j,i-1)
15188               dc(j,i-1)=dcji+aincr
15189               call chainbuild_cart
15190               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
15191               /aincr
15192               dc(j,i-1)=dcji
15193               dcji=dc(j,i)
15194               dc(j,i)=dcji+aincr
15195               call chainbuild_cart
15196               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
15197               /aincr
15198               dc(j,i)=dcji
15199               dcji=dc(j,i+nres)
15200               dc(j,i+nres)=dc(j,i+nres)+aincr
15201               call chainbuild_cart
15202               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
15203               /aincr
15204              dc(j,i+nres)=dcji
15205             enddo
15206           endif
15207 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
15208 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
15209 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
15210 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
15211 !el        write (iout,'(5x,3(3f10.5,5x))') &
15212 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
15213 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
15214 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
15215 !el        write (iout,*)
15216       enddo
15217       return
15218       end subroutine checkintcartgrad
15219 !-----------------------------------------------------------------------------
15220 ! q_measure.F
15221 !-----------------------------------------------------------------------------
15222       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
15223 !      implicit real*8 (a-h,o-z)
15224 !      include 'DIMENSIONS'
15225 !      include 'COMMON.IOUNITS'
15226 !      include 'COMMON.CHAIN'
15227 !      include 'COMMON.INTERACT'
15228 !      include 'COMMON.VAR'
15229       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
15230       integer :: kkk,nsep=3
15231       real(kind=8) :: qm        !dist,
15232       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
15233       logical :: lprn=.false.
15234       logical :: flag
15235 !      real(kind=8) :: sigm,x
15236
15237 !el      sigm(x)=0.25d0*x     ! local function
15238       qqmax=1.0d10
15239       do kkk=1,nperm
15240       qq = 0.0d0
15241       nl=0
15242        if(flag) then
15243         do il=seg1+nsep,seg2
15244           do jl=seg1,il-nsep
15245             nl=nl+1
15246             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
15247                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
15248                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15249             dij=dist(il,jl)
15250             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15251             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15252               nl=nl+1
15253               d0ijCM=dsqrt( &
15254                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15255                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15256                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15257               dijCM=dist(il+nres,jl+nres)
15258               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15259             endif
15260             qq = qq+qqij+qqijCM
15261           enddo
15262         enddo
15263         qq = qq/nl
15264       else
15265       do il=seg1,seg2
15266         if((seg3-il).lt.3) then
15267              secseg=il+3
15268         else
15269              secseg=seg3
15270         endif
15271           do jl=secseg,seg4
15272             nl=nl+1
15273             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15274                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15275                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15276             dij=dist(il,jl)
15277             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
15278             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15279               nl=nl+1
15280               d0ijCM=dsqrt( &
15281                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15282                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15283                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15284               dijCM=dist(il+nres,jl+nres)
15285               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
15286             endif
15287             qq = qq+qqij+qqijCM
15288           enddo
15289         enddo
15290       qq = qq/nl
15291       endif
15292       if (qqmax.le.qq) qqmax=qq
15293       enddo
15294       qwolynes=1.0d0-qqmax
15295       return
15296       end function qwolynes
15297 !-----------------------------------------------------------------------------
15298       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
15299 !      implicit real*8 (a-h,o-z)
15300 !      include 'DIMENSIONS'
15301 !      include 'COMMON.IOUNITS'
15302 !      include 'COMMON.CHAIN'
15303 !      include 'COMMON.INTERACT'
15304 !      include 'COMMON.VAR'
15305 !      include 'COMMON.MD'
15306       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
15307       integer :: nsep=3, kkk
15308 !el      real(kind=8) :: dist
15309       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
15310       logical :: lprn=.false.
15311       logical :: flag
15312       real(kind=8) :: sim,dd0,fac,ddqij
15313 !el      sigm(x)=0.25d0*x            ! local function
15314       do kkk=1,nperm
15315       do i=0,nres
15316         do j=1,3
15317           dqwol(j,i)=0.0d0
15318           dxqwol(j,i)=0.0d0
15319         enddo
15320       enddo
15321       nl=0
15322        if(flag) then
15323         do il=seg1+nsep,seg2
15324           do jl=seg1,il-nsep
15325             nl=nl+1
15326             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15327                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15328                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15329             dij=dist(il,jl)
15330             sim = 1.0d0/sigm(d0ij)
15331             sim = sim*sim
15332             dd0 = dij-d0ij
15333             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15334             do k=1,3
15335               ddqij = (c(k,il)-c(k,jl))*fac
15336               dqwol(k,il)=dqwol(k,il)+ddqij
15337               dqwol(k,jl)=dqwol(k,jl)-ddqij
15338             enddo
15339
15340             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15341               nl=nl+1
15342               d0ijCM=dsqrt( &
15343                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15344                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15345                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15346               dijCM=dist(il+nres,jl+nres)
15347               sim = 1.0d0/sigm(d0ijCM)
15348               sim = sim*sim
15349               dd0=dijCM-d0ijCM
15350               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15351               do k=1,3
15352                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15353                 dxqwol(k,il)=dxqwol(k,il)+ddqij
15354                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15355               enddo
15356             endif
15357           enddo
15358         enddo
15359        else
15360         do il=seg1,seg2
15361         if((seg3-il).lt.3) then
15362              secseg=il+3
15363         else
15364              secseg=seg3
15365         endif
15366           do jl=secseg,seg4
15367             nl=nl+1
15368             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
15369                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
15370                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
15371             dij=dist(il,jl)
15372             sim = 1.0d0/sigm(d0ij)
15373             sim = sim*sim
15374             dd0 = dij-d0ij
15375             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
15376             do k=1,3
15377               ddqij = (c(k,il)-c(k,jl))*fac
15378               dqwol(k,il)=dqwol(k,il)+ddqij
15379               dqwol(k,jl)=dqwol(k,jl)-ddqij
15380             enddo
15381             if (itype(il).ne.10 .or. itype(jl).ne.10) then
15382               nl=nl+1
15383               d0ijCM=dsqrt( &
15384                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
15385                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
15386                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
15387               dijCM=dist(il+nres,jl+nres)
15388               sim = 1.0d0/sigm(d0ijCM)
15389               sim=sim*sim
15390               dd0 = dijCM-d0ijCM
15391               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
15392               do k=1,3
15393                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
15394                dxqwol(k,il)=dxqwol(k,il)+ddqij
15395                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
15396               enddo
15397             endif
15398           enddo
15399         enddo
15400       endif
15401       enddo
15402        do i=0,nres
15403          do j=1,3
15404            dqwol(j,i)=dqwol(j,i)/nl
15405            dxqwol(j,i)=dxqwol(j,i)/nl
15406          enddo
15407        enddo
15408       return
15409       end subroutine qwolynes_prim
15410 !-----------------------------------------------------------------------------
15411       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
15412 !      implicit real*8 (a-h,o-z)
15413 !      include 'DIMENSIONS'
15414 !      include 'COMMON.IOUNITS'
15415 !      include 'COMMON.CHAIN'
15416 !      include 'COMMON.INTERACT'
15417 !      include 'COMMON.VAR'
15418       integer :: seg1,seg2,seg3,seg4
15419       logical :: flag
15420       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
15421       real(kind=8),dimension(3,0:2*nres) :: cdummy
15422       real(kind=8) :: q1,q2
15423       real(kind=8) :: delta=1.0d-10
15424       integer :: i,j
15425
15426       do i=0,nres
15427         do j=1,3
15428           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15429           cdummy(j,i)=c(j,i)
15430           c(j,i)=c(j,i)+delta
15431           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15432           qwolan(j,i)=(q2-q1)/delta
15433           c(j,i)=cdummy(j,i)
15434         enddo
15435       enddo
15436       do i=0,nres
15437         do j=1,3
15438           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
15439           cdummy(j,i+nres)=c(j,i+nres)
15440           c(j,i+nres)=c(j,i+nres)+delta
15441           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
15442           qwolxan(j,i)=(q2-q1)/delta
15443           c(j,i+nres)=cdummy(j,i+nres)
15444         enddo
15445       enddo
15446 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
15447 !      do i=0,nct
15448 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
15449 !      enddo
15450 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
15451 !      do i=0,nct
15452 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
15453 !      enddo
15454       return
15455       end subroutine qwol_num
15456 !-----------------------------------------------------------------------------
15457       subroutine EconstrQ
15458 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
15459 !      implicit real*8 (a-h,o-z)
15460 !      include 'DIMENSIONS'
15461 !      include 'COMMON.CONTROL'
15462 !      include 'COMMON.VAR'
15463 !      include 'COMMON.MD'
15464       use MD_data
15465 !#ifndef LANG0
15466 !      include 'COMMON.LANGEVIN'
15467 !#else
15468 !      include 'COMMON.LANGEVIN.lang0'
15469 !#endif
15470 !      include 'COMMON.CHAIN'
15471 !      include 'COMMON.DERIV'
15472 !      include 'COMMON.GEO'
15473 !      include 'COMMON.LOCAL'
15474 !      include 'COMMON.INTERACT'
15475 !      include 'COMMON.IOUNITS'
15476 !      include 'COMMON.NAMES'
15477 !      include 'COMMON.TIME1'
15478       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
15479       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
15480                    duconst,duxconst
15481       integer :: kstart,kend,lstart,lend,idummy
15482       real(kind=8) :: delta=1.0d-7
15483       integer :: i,j,k,ii
15484       do i=0,nres
15485          do j=1,3
15486             duconst(j,i)=0.0d0
15487             dudconst(j,i)=0.0d0
15488             duxconst(j,i)=0.0d0
15489             dudxconst(j,i)=0.0d0
15490          enddo
15491       enddo
15492       Uconst=0.0d0
15493       do i=1,nfrag
15494          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15495            idummy,idummy)
15496          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
15497 ! Calculating the derivatives of Constraint energy with respect to Q
15498          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
15499            qinfrag(i,iset))
15500 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
15501 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
15502 !         hmnum=(hm2-hm1)/delta
15503 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
15504 !     &   qinfrag(i,iset))
15505 !         write(iout,*) "harmonicnum frag", hmnum
15506 ! Calculating the derivatives of Q with respect to cartesian coordinates
15507          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
15508           idummy,idummy)
15509 !         write(iout,*) "dqwol "
15510 !         do ii=1,nres
15511 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15512 !         enddo
15513 !         write(iout,*) "dxqwol "
15514 !         do ii=1,nres
15515 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15516 !         enddo
15517 ! Calculating numerical gradients of dU/dQi and dQi/dxi
15518 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
15519 !     &  ,idummy,idummy)
15520 !  The gradients of Uconst in Cs
15521          do ii=0,nres
15522             do j=1,3
15523                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
15524                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
15525             enddo
15526          enddo
15527       enddo
15528       do i=1,npair
15529          kstart=ifrag(1,ipair(1,i,iset),iset)
15530          kend=ifrag(2,ipair(1,i,iset),iset)
15531          lstart=ifrag(1,ipair(2,i,iset),iset)
15532          lend=ifrag(2,ipair(2,i,iset),iset)
15533          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
15534          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
15535 !  Calculating dU/dQ
15536          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
15537 !         hm1=harmonic(qpair(i),qinpair(i,iset))
15538 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
15539 !         hmnum=(hm2-hm1)/delta
15540 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
15541 !     &   qinpair(i,iset))
15542 !         write(iout,*) "harmonicnum pair ", hmnum
15543 ! Calculating dQ/dXi
15544          call qwolynes_prim(kstart,kend,.false.,&
15545           lstart,lend)
15546 !         write(iout,*) "dqwol "
15547 !         do ii=1,nres
15548 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
15549 !         enddo
15550 !         write(iout,*) "dxqwol "
15551 !         do ii=1,nres
15552 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
15553 !        enddo
15554 ! Calculating numerical gradients
15555 !        call qwol_num(kstart,kend,.false.
15556 !     &  ,lstart,lend)
15557 ! The gradients of Uconst in Cs
15558          do ii=0,nres
15559             do j=1,3
15560                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
15561                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
15562             enddo
15563          enddo
15564       enddo
15565 !      write(iout,*) "Uconst inside subroutine ", Uconst
15566 ! Transforming the gradients from Cs to dCs for the backbone
15567       do i=0,nres
15568          do j=i+1,nres
15569            do k=1,3
15570              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
15571            enddo
15572          enddo
15573       enddo
15574 !  Transforming the gradients from Cs to dCs for the side chains
15575       do i=1,nres
15576          do j=1,3
15577            dudxconst(j,i)=duxconst(j,i)
15578          enddo
15579       enddo
15580 !      write(iout,*) "dU/ddc backbone "
15581 !       do ii=0,nres
15582 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
15583 !      enddo
15584 !      write(iout,*) "dU/ddX side chain "
15585 !      do ii=1,nres
15586 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
15587 !      enddo
15588 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
15589 !      call dEconstrQ_num
15590       return
15591       end subroutine EconstrQ
15592 !-----------------------------------------------------------------------------
15593       subroutine dEconstrQ_num
15594 ! Calculating numerical dUconst/ddc and dUconst/ddx
15595 !      implicit real*8 (a-h,o-z)
15596 !      include 'DIMENSIONS'
15597 !      include 'COMMON.CONTROL'
15598 !      include 'COMMON.VAR'
15599 !      include 'COMMON.MD'
15600       use MD_data
15601 !#ifndef LANG0
15602 !      include 'COMMON.LANGEVIN'
15603 !#else
15604 !      include 'COMMON.LANGEVIN.lang0'
15605 !#endif
15606 !      include 'COMMON.CHAIN'
15607 !      include 'COMMON.DERIV'
15608 !      include 'COMMON.GEO'
15609 !      include 'COMMON.LOCAL'
15610 !      include 'COMMON.INTERACT'
15611 !      include 'COMMON.IOUNITS'
15612 !      include 'COMMON.NAMES'
15613 !      include 'COMMON.TIME1'
15614       real(kind=8) :: uzap1,uzap2
15615       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
15616       integer :: kstart,kend,lstart,lend,idummy
15617       real(kind=8) :: delta=1.0d-7
15618 !el local variables
15619       integer :: i,ii,j
15620 !     real(kind=8) ::
15621 !     For the backbone
15622       do i=0,nres-1
15623          do j=1,3
15624             dUcartan(j,i)=0.0d0
15625             cdummy(j,i)=dc(j,i)
15626             dc(j,i)=dc(j,i)+delta
15627             call chainbuild_cart
15628             uzap2=0.0d0
15629             do ii=1,nfrag
15630              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15631                 idummy,idummy)
15632                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15633                 qinfrag(ii,iset))
15634             enddo
15635             do ii=1,npair
15636                kstart=ifrag(1,ipair(1,ii,iset),iset)
15637                kend=ifrag(2,ipair(1,ii,iset),iset)
15638                lstart=ifrag(1,ipair(2,ii,iset),iset)
15639                lend=ifrag(2,ipair(2,ii,iset),iset)
15640                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15641                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15642                  qinpair(ii,iset))
15643             enddo
15644             dc(j,i)=cdummy(j,i)
15645             call chainbuild_cart
15646             uzap1=0.0d0
15647              do ii=1,nfrag
15648              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15649                 idummy,idummy)
15650                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15651                 qinfrag(ii,iset))
15652             enddo
15653             do ii=1,npair
15654                kstart=ifrag(1,ipair(1,ii,iset),iset)
15655                kend=ifrag(2,ipair(1,ii,iset),iset)
15656                lstart=ifrag(1,ipair(2,ii,iset),iset)
15657                lend=ifrag(2,ipair(2,ii,iset),iset)
15658                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15659                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15660                 qinpair(ii,iset))
15661             enddo
15662             ducartan(j,i)=(uzap2-uzap1)/(delta)
15663          enddo
15664       enddo
15665 ! Calculating numerical gradients for dU/ddx
15666       do i=0,nres-1
15667          duxcartan(j,i)=0.0d0
15668          do j=1,3
15669             cdummy(j,i)=dc(j,i+nres)
15670             dc(j,i+nres)=dc(j,i+nres)+delta
15671             call chainbuild_cart
15672             uzap2=0.0d0
15673             do ii=1,nfrag
15674              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
15675                 idummy,idummy)
15676                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
15677                 qinfrag(ii,iset))
15678             enddo
15679             do ii=1,npair
15680                kstart=ifrag(1,ipair(1,ii,iset),iset)
15681                kend=ifrag(2,ipair(1,ii,iset),iset)
15682                lstart=ifrag(1,ipair(2,ii,iset),iset)
15683                lend=ifrag(2,ipair(2,ii,iset),iset)
15684                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15685                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
15686                 qinpair(ii,iset))
15687             enddo
15688             dc(j,i+nres)=cdummy(j,i)
15689             call chainbuild_cart
15690             uzap1=0.0d0
15691              do ii=1,nfrag
15692                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
15693                 ifrag(2,ii,iset),.true.,idummy,idummy)
15694                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
15695                 qinfrag(ii,iset))
15696             enddo
15697             do ii=1,npair
15698                kstart=ifrag(1,ipair(1,ii,iset),iset)
15699                kend=ifrag(2,ipair(1,ii,iset),iset)
15700                lstart=ifrag(1,ipair(2,ii,iset),iset)
15701                lend=ifrag(2,ipair(2,ii,iset),iset)
15702                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
15703                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
15704                 qinpair(ii,iset))
15705             enddo
15706             duxcartan(j,i)=(uzap2-uzap1)/(delta)
15707          enddo
15708       enddo
15709       write(iout,*) "Numerical dUconst/ddc backbone "
15710       do ii=0,nres
15711         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
15712       enddo
15713 !      write(iout,*) "Numerical dUconst/ddx side-chain "
15714 !      do ii=1,nres
15715 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
15716 !      enddo
15717       return
15718       end subroutine dEconstrQ_num
15719 !-----------------------------------------------------------------------------
15720 ! ssMD.F
15721 !-----------------------------------------------------------------------------
15722       subroutine check_energies
15723
15724 !      use random, only: ran_number
15725
15726 !      implicit none
15727 !     Includes
15728 !      include 'DIMENSIONS'
15729 !      include 'COMMON.CHAIN'
15730 !      include 'COMMON.VAR'
15731 !      include 'COMMON.IOUNITS'
15732 !      include 'COMMON.SBRIDGE'
15733 !      include 'COMMON.LOCAL'
15734 !      include 'COMMON.GEO'
15735
15736 !     External functions
15737 !EL      double precision ran_number
15738 !EL      external ran_number
15739
15740 !     Local variables
15741       integer :: i,j,k,l,lmax,p,pmax
15742       real(kind=8) :: rmin,rmax
15743       real(kind=8) :: eij
15744
15745       real(kind=8) :: d
15746       real(kind=8) :: wi,rij,tj,pj
15747 !      return
15748
15749       i=5
15750       j=14
15751
15752       d=dsc(1)
15753       rmin=2.0D0
15754       rmax=12.0D0
15755
15756       lmax=10000
15757       pmax=1
15758
15759       do k=1,3
15760         c(k,i)=0.0D0
15761         c(k,j)=0.0D0
15762         c(k,nres+i)=0.0D0
15763         c(k,nres+j)=0.0D0
15764       enddo
15765
15766       do l=1,lmax
15767
15768 !t        wi=ran_number(0.0D0,pi)
15769 !        wi=ran_number(0.0D0,pi/6.0D0)
15770 !        wi=0.0D0
15771 !t        tj=ran_number(0.0D0,pi)
15772 !t        pj=ran_number(0.0D0,pi)
15773 !        pj=ran_number(0.0D0,pi/6.0D0)
15774 !        pj=0.0D0
15775
15776         do p=1,pmax
15777 !t           rij=ran_number(rmin,rmax)
15778
15779            c(1,j)=d*sin(pj)*cos(tj)
15780            c(2,j)=d*sin(pj)*sin(tj)
15781            c(3,j)=d*cos(pj)
15782
15783            c(3,nres+i)=-rij
15784
15785            c(1,i)=d*sin(wi)
15786            c(3,i)=-rij-d*cos(wi)
15787
15788            do k=1,3
15789               dc(k,nres+i)=c(k,nres+i)-c(k,i)
15790               dc_norm(k,nres+i)=dc(k,nres+i)/d
15791               dc(k,nres+j)=c(k,nres+j)-c(k,j)
15792               dc_norm(k,nres+j)=dc(k,nres+j)/d
15793            enddo
15794
15795            call dyn_ssbond_ene(i,j,eij)
15796         enddo
15797       enddo
15798       call exit(1)
15799       return
15800       end subroutine check_energies
15801 !-----------------------------------------------------------------------------
15802       subroutine dyn_ssbond_ene(resi,resj,eij)
15803 !      implicit none
15804 !      Includes
15805       use calc_data
15806       use comm_sschecks
15807 !      include 'DIMENSIONS'
15808 !      include 'COMMON.SBRIDGE'
15809 !      include 'COMMON.CHAIN'
15810 !      include 'COMMON.DERIV'
15811 !      include 'COMMON.LOCAL'
15812 !      include 'COMMON.INTERACT'
15813 !      include 'COMMON.VAR'
15814 !      include 'COMMON.IOUNITS'
15815 !      include 'COMMON.CALC'
15816 #ifndef CLUST
15817 #ifndef WHAM
15818        use MD_data
15819 !      include 'COMMON.MD'
15820 !      use MD, only: totT,t_bath
15821 #endif
15822 #endif
15823 !     External functions
15824 !EL      double precision h_base
15825 !EL      external h_base
15826
15827 !     Input arguments
15828       integer :: resi,resj
15829
15830 !     Output arguments
15831       real(kind=8) :: eij
15832
15833 !     Local variables
15834       logical :: havebond
15835       integer itypi,itypj
15836       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
15837       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
15838       real(kind=8),dimension(3) :: dcosom1,dcosom2
15839       real(kind=8) :: ed
15840       real(kind=8) :: pom1,pom2
15841       real(kind=8) :: ljA,ljB,ljXs
15842       real(kind=8),dimension(1:3) :: d_ljB
15843       real(kind=8) :: ssA,ssB,ssC,ssXs
15844       real(kind=8) :: ssxm,ljxm,ssm,ljm
15845       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
15846       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
15847       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
15848 !-------FIRST METHOD
15849       real(kind=8) :: xm
15850       real(kind=8),dimension(1:3) :: d_xm
15851 !-------END FIRST METHOD
15852 !-------SECOND METHOD
15853 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
15854 !-------END SECOND METHOD
15855
15856 !-------TESTING CODE
15857 !el      logical :: checkstop,transgrad
15858 !el      common /sschecks/ checkstop,transgrad
15859
15860       integer :: icheck,nicheck,jcheck,njcheck
15861       real(kind=8),dimension(-1:1) :: echeck
15862       real(kind=8) :: deps,ssx0,ljx0
15863 !-------END TESTING CODE
15864
15865       eij=0.0d0
15866       i=resi
15867       j=resj
15868
15869 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
15870 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
15871
15872       itypi=itype(i)
15873       dxi=dc_norm(1,nres+i)
15874       dyi=dc_norm(2,nres+i)
15875       dzi=dc_norm(3,nres+i)
15876       dsci_inv=vbld_inv(i+nres)
15877
15878       itypj=itype(j)
15879       xj=c(1,nres+j)-c(1,nres+i)
15880       yj=c(2,nres+j)-c(2,nres+i)
15881       zj=c(3,nres+j)-c(3,nres+i)
15882       dxj=dc_norm(1,nres+j)
15883       dyj=dc_norm(2,nres+j)
15884       dzj=dc_norm(3,nres+j)
15885       dscj_inv=vbld_inv(j+nres)
15886
15887       chi1=chi(itypi,itypj)
15888       chi2=chi(itypj,itypi)
15889       chi12=chi1*chi2
15890       chip1=chip(itypi)
15891       chip2=chip(itypj)
15892       chip12=chip1*chip2
15893       alf1=alp(itypi)
15894       alf2=alp(itypj)
15895       alf12=0.5D0*(alf1+alf2)
15896
15897       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15898       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
15899 !     The following are set in sc_angular
15900 !      erij(1)=xj*rij
15901 !      erij(2)=yj*rij
15902 !      erij(3)=zj*rij
15903 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
15904 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
15905 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
15906       call sc_angular
15907       rij=1.0D0/rij  ! Reset this so it makes sense
15908
15909       sig0ij=sigma(itypi,itypj)
15910       sig=sig0ij*dsqrt(1.0D0/sigsq)
15911
15912       ljXs=sig-sig0ij
15913       ljA=eps1*eps2rt**2*eps3rt**2
15914       ljB=ljA*bb(itypi,itypj)
15915       ljA=ljA*aa(itypi,itypj)
15916       ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15917
15918       ssXs=d0cm
15919       deltat1=1.0d0-om1
15920       deltat2=1.0d0+om2
15921       deltat12=om2-om1+2.0d0
15922       cosphi=om12-om1*om2
15923       ssA=akcm
15924       ssB=akct*deltat12
15925       ssC=ss_depth &
15926            +akth*(deltat1*deltat1+deltat2*deltat2) &
15927            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
15928       ssxm=ssXs-0.5D0*ssB/ssA
15929
15930 !-------TESTING CODE
15931 !$$$c     Some extra output
15932 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
15933 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15934 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
15935 !$$$      if (ssx0.gt.0.0d0) then
15936 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
15937 !$$$      else
15938 !$$$        ssx0=ssxm
15939 !$$$      endif
15940 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
15941 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
15942 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
15943 !$$$      return
15944 !-------END TESTING CODE
15945
15946 !-------TESTING CODE
15947 !     Stop and plot energy and derivative as a function of distance
15948       if (checkstop) then
15949         ssm=ssC-0.25D0*ssB*ssB/ssA
15950         ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
15951         if (ssm.lt.ljm .and. &
15952              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
15953           nicheck=1000
15954           njcheck=1
15955           deps=0.5d-7
15956         else
15957           checkstop=.false.
15958         endif
15959       endif
15960       if (.not.checkstop) then
15961         nicheck=0
15962         njcheck=-1
15963       endif
15964
15965       do icheck=0,nicheck
15966       do jcheck=-1,njcheck
15967       if (checkstop) rij=(ssxm-1.0d0)+ &
15968              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
15969 !-------END TESTING CODE
15970
15971       if (rij.gt.ljxm) then
15972         havebond=.false.
15973         ljd=rij-ljXs
15974         fac=(1.0D0/ljd)**expon
15975         e1=fac*fac*aa(itypi,itypj)
15976         e2=fac*bb(itypi,itypj)
15977         eij=eps1*eps2rt*eps3rt*(e1+e2)
15978         eps2der=eij*eps3rt
15979         eps3der=eij*eps2rt
15980         eij=eij*eps2rt*eps3rt
15981
15982         sigder=-sig/sigsq
15983         e1=e1*eps1*eps2rt**2*eps3rt**2
15984         ed=-expon*(e1+eij)/ljd
15985         sigder=ed*sigder
15986         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15987         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15988         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
15989              -2.0D0*alf12*eps3der+sigder*sigsq_om12
15990       else if (rij.lt.ssxm) then
15991         havebond=.true.
15992         ssd=rij-ssXs
15993         eij=ssA*ssd*ssd+ssB*ssd+ssC
15994
15995         ed=2*akcm*ssd+akct*deltat12
15996         pom1=akct*ssd
15997         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
15998         eom1=-2*akth*deltat1-pom1-om2*pom2
15999         eom2= 2*akth*deltat2+pom1-om1*pom2
16000         eom12=pom2
16001       else
16002         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
16003
16004         d_ssxm(1)=0.5D0*akct/ssA
16005         d_ssxm(2)=-d_ssxm(1)
16006         d_ssxm(3)=0.0D0
16007
16008         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
16009         d_ljxm(2)=d_ljxm(1)*sigsq_om2
16010         d_ljxm(3)=d_ljxm(1)*sigsq_om12
16011         d_ljxm(1)=d_ljxm(1)*sigsq_om1
16012
16013 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16014         xm=0.5d0*(ssxm+ljxm)
16015         do k=1,3
16016           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
16017         enddo
16018         if (rij.lt.xm) then
16019           havebond=.true.
16020           ssm=ssC-0.25D0*ssB*ssB/ssA
16021           d_ssm(1)=0.5D0*akct*ssB/ssA
16022           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16023           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16024           d_ssm(3)=omega
16025           f1=(rij-xm)/(ssxm-xm)
16026           f2=(rij-ssxm)/(xm-ssxm)
16027           h1=h_base(f1,hd1)
16028           h2=h_base(f2,hd2)
16029           eij=ssm*h1+Ht*h2
16030           delta_inv=1.0d0/(xm-ssxm)
16031           deltasq_inv=delta_inv*delta_inv
16032           fac=ssm*hd1-Ht*hd2
16033           fac1=deltasq_inv*fac*(xm-rij)
16034           fac2=deltasq_inv*fac*(rij-ssxm)
16035           ed=delta_inv*(Ht*hd2-ssm*hd1)
16036           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
16037           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
16038           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
16039         else
16040           havebond=.false.
16041           ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
16042           d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB
16043           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
16044           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
16045                alf12/eps3rt)
16046           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
16047           f1=(rij-ljxm)/(xm-ljxm)
16048           f2=(rij-xm)/(ljxm-xm)
16049           h1=h_base(f1,hd1)
16050           h2=h_base(f2,hd2)
16051           eij=Ht*h1+ljm*h2
16052           delta_inv=1.0d0/(ljxm-xm)
16053           deltasq_inv=delta_inv*delta_inv
16054           fac=Ht*hd1-ljm*hd2
16055           fac1=deltasq_inv*fac*(ljxm-rij)
16056           fac2=deltasq_inv*fac*(rij-xm)
16057           ed=delta_inv*(ljm*hd2-Ht*hd1)
16058           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
16059           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
16060           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
16061         endif
16062 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
16063
16064 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16065 !$$$        ssd=rij-ssXs
16066 !$$$        ljd=rij-ljXs
16067 !$$$        fac1=rij-ljxm
16068 !$$$        fac2=rij-ssxm
16069 !$$$
16070 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
16071 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
16072 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
16073 !$$$
16074 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
16075 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
16076 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
16077 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
16078 !$$$        d_ssm(3)=omega
16079 !$$$
16080 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
16081 !$$$        do k=1,3
16082 !$$$          d_ljm(k)=ljm*d_ljB(k)
16083 !$$$        enddo
16084 !$$$        ljm=ljm*ljB
16085 !$$$
16086 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
16087 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
16088 !$$$        d_ss(2)=akct*ssd
16089 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
16090 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
16091 !$$$        d_ss(3)=omega
16092 !$$$
16093 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
16094 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
16095 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
16096 !$$$        do k=1,3
16097 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
16098 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
16099 !$$$        enddo
16100 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
16101 !$$$
16102 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
16103 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
16104 !$$$        h1=h_base(f1,hd1)
16105 !$$$        h2=h_base(f2,hd2)
16106 !$$$        eij=ss*h1+ljf*h2
16107 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
16108 !$$$        deltasq_inv=delta_inv*delta_inv
16109 !$$$        fac=ljf*hd2-ss*hd1
16110 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
16111 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
16112 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
16113 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
16114 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
16115 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
16116 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
16117 !$$$
16118 !$$$        havebond=.false.
16119 !$$$        if (ed.gt.0.0d0) havebond=.true.
16120 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
16121
16122       endif
16123
16124       if (havebond) then
16125 !#ifndef CLUST
16126 !#ifndef WHAM
16127 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
16128 !          write(iout,'(a15,f12.2,f8.1,2i5)')
16129 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
16130 !        endif
16131 !#endif
16132 !#endif
16133         dyn_ssbond_ij(i,j)=eij
16134       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
16135         dyn_ssbond_ij(i,j)=1.0d300
16136 !#ifndef CLUST
16137 !#ifndef WHAM
16138 !        write(iout,'(a15,f12.2,f8.1,2i5)')
16139 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
16140 !#endif
16141 !#endif
16142       endif
16143
16144 !-------TESTING CODE
16145 !el      if (checkstop) then
16146         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
16147              "CHECKSTOP",rij,eij,ed
16148         echeck(jcheck)=eij
16149 !el      endif
16150       enddo
16151       if (checkstop) then
16152         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
16153       endif
16154       enddo
16155       if (checkstop) then
16156         transgrad=.true.
16157         checkstop=.false.
16158       endif
16159 !-------END TESTING CODE
16160
16161       do k=1,3
16162         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
16163         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
16164       enddo
16165       do k=1,3
16166         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
16167       enddo
16168       do k=1,3
16169         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16170              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16171              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16172         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16173              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16174              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16175       enddo
16176 !grad      do k=i,j-1
16177 !grad        do l=1,3
16178 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
16179 !grad        enddo
16180 !grad      enddo
16181
16182       do l=1,3
16183         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16184         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16185       enddo
16186
16187       return
16188       end subroutine dyn_ssbond_ene
16189 !-----------------------------------------------------------------------------
16190       real(kind=8) function h_base(x,deriv)
16191 !     A smooth function going 0->1 in range [0,1]
16192 !     It should NOT be called outside range [0,1], it will not work there.
16193       implicit none
16194
16195 !     Input arguments
16196       real(kind=8) :: x
16197
16198 !     Output arguments
16199       real(kind=8) :: deriv
16200
16201 !     Local variables
16202       real(kind=8) :: xsq
16203
16204
16205 !     Two parabolas put together.  First derivative zero at extrema
16206 !$$$      if (x.lt.0.5D0) then
16207 !$$$        h_base=2.0D0*x*x
16208 !$$$        deriv=4.0D0*x
16209 !$$$      else
16210 !$$$        deriv=1.0D0-x
16211 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
16212 !$$$        deriv=4.0D0*deriv
16213 !$$$      endif
16214
16215 !     Third degree polynomial.  First derivative zero at extrema
16216       h_base=x*x*(3.0d0-2.0d0*x)
16217       deriv=6.0d0*x*(1.0d0-x)
16218
16219 !     Fifth degree polynomial.  First and second derivatives zero at extrema
16220 !$$$      xsq=x*x
16221 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
16222 !$$$      deriv=x-1.0d0
16223 !$$$      deriv=deriv*deriv
16224 !$$$      deriv=30.0d0*xsq*deriv
16225
16226       return
16227       end function h_base
16228 !-----------------------------------------------------------------------------
16229       subroutine dyn_set_nss
16230 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
16231 !      implicit none
16232       use MD_data, only: totT,t_bath
16233 !     Includes
16234 !      include 'DIMENSIONS'
16235 #ifdef MPI
16236       include "mpif.h"
16237 #endif
16238 !      include 'COMMON.SBRIDGE'
16239 !      include 'COMMON.CHAIN'
16240 !      include 'COMMON.IOUNITS'
16241 !      include 'COMMON.SETUP'
16242 !      include 'COMMON.MD'
16243 !     Local variables
16244       real(kind=8) :: emin
16245       integer :: i,j,imin,ierr
16246       integer :: diff,allnss,newnss
16247       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16248                 newihpb,newjhpb
16249       logical :: found
16250       integer,dimension(0:nfgtasks) :: i_newnss
16251       integer,dimension(0:nfgtasks) :: displ
16252       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
16253       integer :: g_newnss
16254
16255       allnss=0
16256       do i=1,nres-1
16257         do j=i+1,nres
16258           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
16259             allnss=allnss+1
16260             allflag(allnss)=0
16261             allihpb(allnss)=i
16262             alljhpb(allnss)=j
16263           endif
16264         enddo
16265       enddo
16266
16267 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16268
16269  1    emin=1.0d300
16270       do i=1,allnss
16271         if (allflag(i).eq.0 .and. &
16272              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
16273           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
16274           imin=i
16275         endif
16276       enddo
16277       if (emin.lt.1.0d300) then
16278         allflag(imin)=1
16279         do i=1,allnss
16280           if (allflag(i).eq.0 .and. &
16281                (allihpb(i).eq.allihpb(imin) .or. &
16282                alljhpb(i).eq.allihpb(imin) .or. &
16283                allihpb(i).eq.alljhpb(imin) .or. &
16284                alljhpb(i).eq.alljhpb(imin))) then
16285             allflag(i)=-1
16286           endif
16287         enddo
16288         goto 1
16289       endif
16290
16291 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
16292
16293       newnss=0
16294       do i=1,allnss
16295         if (allflag(i).eq.1) then
16296           newnss=newnss+1
16297           newihpb(newnss)=allihpb(i)
16298           newjhpb(newnss)=alljhpb(i)
16299         endif
16300       enddo
16301
16302 #ifdef MPI
16303       if (nfgtasks.gt.1)then
16304
16305         call MPI_Reduce(newnss,g_newnss,1,&
16306           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
16307         call MPI_Gather(newnss,1,MPI_INTEGER,&
16308                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
16309         displ(0)=0
16310         do i=1,nfgtasks-1,1
16311           displ(i)=i_newnss(i-1)+displ(i-1)
16312         enddo
16313         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
16314                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
16315                          king,FG_COMM,IERR)
16316         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
16317                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
16318                          king,FG_COMM,IERR)
16319         if(fg_rank.eq.0) then
16320 !         print *,'g_newnss',g_newnss
16321 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
16322 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
16323          newnss=g_newnss
16324          do i=1,newnss
16325           newihpb(i)=g_newihpb(i)
16326           newjhpb(i)=g_newjhpb(i)
16327          enddo
16328         endif
16329       endif
16330 #endif
16331
16332       diff=newnss-nss
16333
16334 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
16335
16336       do i=1,nss
16337         found=.false.
16338         do j=1,newnss
16339           if (idssb(i).eq.newihpb(j) .and. &
16340                jdssb(i).eq.newjhpb(j)) found=.true.
16341         enddo
16342 #ifndef CLUST
16343 #ifndef WHAM
16344         if (.not.found.and.fg_rank.eq.0) &
16345             write(iout,'(a15,f12.2,f8.1,2i5)') &
16346              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
16347 #endif
16348 #endif
16349       enddo
16350
16351       do i=1,newnss
16352         found=.false.
16353         do j=1,nss
16354           if (newihpb(i).eq.idssb(j) .and. &
16355                newjhpb(i).eq.jdssb(j)) found=.true.
16356         enddo
16357 #ifndef CLUST
16358 #ifndef WHAM
16359         if (.not.found.and.fg_rank.eq.0) &
16360             write(iout,'(a15,f12.2,f8.1,2i5)') &
16361              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
16362 #endif
16363 #endif
16364       enddo
16365
16366       nss=newnss
16367       do i=1,nss
16368         idssb(i)=newihpb(i)
16369         jdssb(i)=newjhpb(i)
16370       enddo
16371
16372       return
16373       end subroutine dyn_set_nss
16374 !-----------------------------------------------------------------------------
16375 #ifdef WHAM
16376       subroutine read_ssHist
16377 !      implicit none
16378 !      Includes
16379 !      include 'DIMENSIONS'
16380 !      include "DIMENSIONS.FREE"
16381 !      include 'COMMON.FREE'
16382 !     Local variables
16383       integer :: i,j
16384       character(len=80) :: controlcard
16385
16386       do i=1,dyn_nssHist
16387         call card_concat(controlcard,.true.)
16388         read(controlcard,*) &
16389              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
16390       enddo
16391
16392       return
16393       end subroutine read_ssHist
16394 #endif
16395 !-----------------------------------------------------------------------------
16396       integer function indmat(i,j)
16397 !el
16398 ! get the position of the jth ijth fragment of the chain coordinate system
16399 ! in the fromto array.
16400         integer :: i,j
16401
16402         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
16403       return
16404       end function indmat
16405 !-----------------------------------------------------------------------------
16406       real(kind=8) function sigm(x)
16407 !el
16408        real(kind=8) :: x
16409         sigm=0.25d0*x
16410       return
16411       end function sigm
16412 !-----------------------------------------------------------------------------
16413 !-----------------------------------------------------------------------------
16414       subroutine alloc_ener_arrays
16415 !EL Allocation of arrays used by module energy
16416       use MD_data, only: mset
16417 !el local variables
16418       integer :: i,j
16419
16420       if(nres.lt.100) then
16421         maxconts=nres
16422       elseif(nres.lt.200) then
16423         maxconts=0.8*nres       ! Max. number of contacts per residue
16424       else
16425         maxconts=0.6*nres ! (maxconts=maxres/4)
16426       endif
16427       maxcont=12*nres   ! Max. number of SC contacts
16428       maxvar=6*nres     ! Max. number of variables
16429 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16430       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
16431 !----------------------
16432 ! arrays in subroutine init_int_table
16433 !el#ifdef MPI
16434 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
16435 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
16436 !el#endif
16437       allocate(nint_gr(nres))
16438       allocate(nscp_gr(nres))
16439       allocate(ielstart(nres))
16440       allocate(ielend(nres))
16441 !(maxres)
16442       allocate(istart(nres,maxint_gr))
16443       allocate(iend(nres,maxint_gr))
16444 !(maxres,maxint_gr)
16445       allocate(iscpstart(nres,maxint_gr))
16446       allocate(iscpend(nres,maxint_gr))
16447 !(maxres,maxint_gr)
16448       allocate(ielstart_vdw(nres))
16449       allocate(ielend_vdw(nres))
16450 !(maxres)
16451
16452       allocate(lentyp(0:nfgtasks-1))
16453 !(0:maxprocs-1)
16454 !----------------------
16455 ! commom.contacts
16456 !      common /contacts/
16457       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
16458       allocate(icont(2,maxcont))
16459 !(2,maxcont)
16460 !      common /contacts1/
16461       allocate(num_cont(0:nres+4))
16462 !(maxres)
16463       allocate(jcont(maxconts,nres))
16464 !(maxconts,maxres)
16465       allocate(facont(maxconts,nres))
16466 !(maxconts,maxres)
16467       allocate(gacont(3,maxconts,nres))
16468 !(3,maxconts,maxres)
16469 !      common /contacts_hb/
16470       allocate(gacontp_hb1(3,maxconts,nres))
16471       allocate(gacontp_hb2(3,maxconts,nres))
16472       allocate(gacontp_hb3(3,maxconts,nres))
16473       allocate(gacontm_hb1(3,maxconts,nres))
16474       allocate(gacontm_hb2(3,maxconts,nres))
16475       allocate(gacontm_hb3(3,maxconts,nres))
16476       allocate(gacont_hbr(3,maxconts,nres))
16477       allocate(grij_hb_cont(3,maxconts,nres))
16478 !(3,maxconts,maxres)
16479       allocate(facont_hb(maxconts,nres))
16480       allocate(ees0p(maxconts,nres))
16481       allocate(ees0m(maxconts,nres))
16482       allocate(d_cont(maxconts,nres))
16483 !(maxconts,maxres)
16484       allocate(num_cont_hb(nres))
16485 !(maxres)
16486       allocate(jcont_hb(maxconts,nres))
16487 !(maxconts,maxres)
16488 !      common /rotat/
16489       allocate(Ug(2,2,nres))
16490       allocate(Ugder(2,2,nres))
16491       allocate(Ug2(2,2,nres))
16492       allocate(Ug2der(2,2,nres))
16493 !(2,2,maxres)
16494       allocate(obrot(2,nres))
16495       allocate(obrot2(2,nres))
16496       allocate(obrot_der(2,nres))
16497       allocate(obrot2_der(2,nres))
16498 !(2,maxres)
16499 !      common /precomp1/
16500       allocate(mu(2,nres))
16501       allocate(muder(2,nres))
16502       allocate(Ub2(2,nres))
16503       Ub2(1,:)=0.0d0
16504       Ub2(2,:)=0.0d0
16505       allocate(Ub2der(2,nres))
16506       allocate(Ctobr(2,nres))
16507       allocate(Ctobrder(2,nres))
16508       allocate(Dtobr2(2,nres))
16509       allocate(Dtobr2der(2,nres))
16510 !(2,maxres)
16511       allocate(EUg(2,2,nres))
16512       allocate(EUgder(2,2,nres))
16513       allocate(CUg(2,2,nres))
16514       allocate(CUgder(2,2,nres))
16515       allocate(DUg(2,2,nres))
16516       allocate(Dugder(2,2,nres))
16517       allocate(DtUg2(2,2,nres))
16518       allocate(DtUg2der(2,2,nres))
16519 !(2,2,maxres)
16520 !      common /precomp2/
16521       allocate(Ug2Db1t(2,nres))
16522       allocate(Ug2Db1tder(2,nres))
16523       allocate(CUgb2(2,nres))
16524       allocate(CUgb2der(2,nres))
16525 !(2,maxres)
16526       allocate(EUgC(2,2,nres))
16527       allocate(EUgCder(2,2,nres))
16528       allocate(EUgD(2,2,nres))
16529       allocate(EUgDder(2,2,nres))
16530       allocate(DtUg2EUg(2,2,nres))
16531       allocate(Ug2DtEUg(2,2,nres))
16532 !(2,2,maxres)
16533       allocate(Ug2DtEUgder(2,2,2,nres))
16534       allocate(DtUg2EUgder(2,2,2,nres))
16535 !(2,2,2,maxres)
16536 !      common /rotat_old/
16537       allocate(costab(nres))
16538       allocate(sintab(nres))
16539       allocate(costab2(nres))
16540       allocate(sintab2(nres))
16541 !(maxres)
16542 !      common /dipmat/
16543       allocate(a_chuj(2,2,maxconts,nres))
16544 !(2,2,maxconts,maxres)(maxconts=maxres/4)
16545       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
16546 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
16547 !      common /contdistrib/
16548       allocate(ncont_sent(nres))
16549       allocate(ncont_recv(nres))
16550
16551       allocate(iat_sent(nres))
16552 !(maxres)
16553       allocate(iint_sent(4,nres,nres))
16554       allocate(iint_sent_local(4,nres,nres))
16555 !(4,maxres,maxres)
16556       allocate(iturn3_sent(4,0:nres+4))
16557       allocate(iturn4_sent(4,0:nres+4))
16558       allocate(iturn3_sent_local(4,nres))
16559       allocate(iturn4_sent_local(4,nres))
16560 !(4,maxres)
16561       allocate(itask_cont_from(0:nfgtasks-1))
16562       allocate(itask_cont_to(0:nfgtasks-1))
16563 !(0:max_fg_procs-1)
16564
16565
16566
16567 !----------------------
16568 ! commom.deriv;
16569 !      common /derivat/
16570       allocate(dcdv(6,maxdim))
16571       allocate(dxdv(6,maxdim))
16572 !(6,maxdim)
16573       allocate(dxds(6,nres))
16574 !(6,maxres)
16575       allocate(gradx(3,nres,0:2))
16576       allocate(gradc(3,nres,0:2))
16577 !(3,maxres,2)
16578       allocate(gvdwx(3,nres))
16579       allocate(gvdwc(3,nres))
16580       allocate(gelc(3,nres))
16581       allocate(gelc_long(3,nres))
16582       allocate(gvdwpp(3,nres))
16583       allocate(gvdwc_scpp(3,nres))
16584       allocate(gradx_scp(3,nres))
16585       allocate(gvdwc_scp(3,nres))
16586       allocate(ghpbx(3,nres))
16587       allocate(ghpbc(3,nres))
16588       allocate(gradcorr(3,nres))
16589       allocate(gradcorr_long(3,nres))
16590       allocate(gradcorr5_long(3,nres))
16591       allocate(gradcorr6_long(3,nres))
16592       allocate(gcorr6_turn_long(3,nres))
16593       allocate(gradxorr(3,nres))
16594       allocate(gradcorr5(3,nres))
16595       allocate(gradcorr6(3,nres))
16596 !(3,maxres)
16597       allocate(gloc(0:maxvar,0:2))
16598       allocate(gloc_x(0:maxvar,2))
16599 !(maxvar,2)
16600       allocate(gel_loc(3,nres))
16601       allocate(gel_loc_long(3,nres))
16602       allocate(gcorr3_turn(3,nres))
16603       allocate(gcorr4_turn(3,nres))
16604       allocate(gcorr6_turn(3,nres))
16605       allocate(gradb(3,nres))
16606       allocate(gradbx(3,nres))
16607 !(3,maxres)
16608       allocate(gel_loc_loc(maxvar))
16609       allocate(gel_loc_turn3(maxvar))
16610       allocate(gel_loc_turn4(maxvar))
16611       allocate(gel_loc_turn6(maxvar))
16612       allocate(gcorr_loc(maxvar))
16613       allocate(g_corr5_loc(maxvar))
16614       allocate(g_corr6_loc(maxvar))
16615 !(maxvar)
16616       allocate(gsccorc(3,nres))
16617       allocate(gsccorx(3,nres))
16618 !(3,maxres)
16619       allocate(gsccor_loc(nres))
16620 !(maxres)
16621       allocate(dtheta(3,2,nres))
16622 !(3,2,maxres)
16623       allocate(gscloc(3,nres))
16624       allocate(gsclocx(3,nres))
16625 !(3,maxres)
16626       allocate(dphi(3,3,nres))
16627       allocate(dalpha(3,3,nres))
16628       allocate(domega(3,3,nres))
16629 !(3,3,maxres)
16630 !      common /deriv_scloc/
16631       allocate(dXX_C1tab(3,nres))
16632       allocate(dYY_C1tab(3,nres))
16633       allocate(dZZ_C1tab(3,nres))
16634       allocate(dXX_Ctab(3,nres))
16635       allocate(dYY_Ctab(3,nres))
16636       allocate(dZZ_Ctab(3,nres))
16637       allocate(dXX_XYZtab(3,nres))
16638       allocate(dYY_XYZtab(3,nres))
16639       allocate(dZZ_XYZtab(3,nres))
16640 !(3,maxres)
16641 !      common /mpgrad/
16642       allocate(jgrad_start(nres))
16643       allocate(jgrad_end(nres))
16644 !(maxres)
16645 !----------------------
16646
16647 !      common /indices/
16648       allocate(ibond_displ(0:nfgtasks-1))
16649       allocate(ibond_count(0:nfgtasks-1))
16650       allocate(ithet_displ(0:nfgtasks-1))
16651       allocate(ithet_count(0:nfgtasks-1))
16652       allocate(iphi_displ(0:nfgtasks-1))
16653       allocate(iphi_count(0:nfgtasks-1))
16654       allocate(iphi1_displ(0:nfgtasks-1))
16655       allocate(iphi1_count(0:nfgtasks-1))
16656       allocate(ivec_displ(0:nfgtasks-1))
16657       allocate(ivec_count(0:nfgtasks-1))
16658       allocate(iset_displ(0:nfgtasks-1))
16659       allocate(iset_count(0:nfgtasks-1))
16660       allocate(iint_count(0:nfgtasks-1))
16661       allocate(iint_displ(0:nfgtasks-1))
16662 !(0:max_fg_procs-1)
16663 !----------------------
16664 ! common.MD
16665 !      common /mdgrad/
16666       allocate(gcart(3,0:nres))
16667       allocate(gxcart(3,0:nres))
16668 !(3,0:MAXRES)
16669       allocate(gradcag(3,nres))
16670       allocate(gradxag(3,nres))
16671 !(3,MAXRES)
16672 !      common /back_constr/
16673 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
16674       allocate(dutheta(nres))
16675       allocate(dugamma(nres))
16676 !(maxres)
16677       allocate(duscdiff(3,nres))
16678       allocate(duscdiffx(3,nres))
16679 !(3,maxres)
16680 !el i io:read_fragments
16681 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
16682 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
16683 !      common /qmeas/
16684 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
16685 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
16686       allocate(mset(0:nprocs))  !(maxprocs/20)
16687       mset(:)=0
16688 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
16689 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
16690       allocate(dUdconst(3,0:nres))
16691       allocate(dUdxconst(3,0:nres))
16692       allocate(dqwol(3,0:nres))
16693       allocate(dxqwol(3,0:nres))
16694 !(3,0:MAXRES)
16695 !----------------------
16696 ! common.sbridge
16697 !      common /sbridge/ in io_common: read_bridge
16698 !el    allocate((:),allocatable :: iss  !(maxss)
16699 !      common /links/  in io_common: read_bridge
16700 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
16701 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
16702 !      common /dyn_ssbond/
16703 ! and side-chain vectors in theta or phi.
16704       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
16705 !(maxres,maxres)
16706 !      do i=1,nres
16707 !        do j=i+1,nres
16708       dyn_ssbond_ij(:,:)=1.0d300
16709 !        enddo
16710 !      enddo
16711
16712       if (nss.gt.0) then
16713         allocate(idssb(nss),jdssb(nss))
16714 !(maxdim)
16715       endif
16716       allocate(dyn_ss_mask(nres))
16717 !(maxres)
16718       dyn_ss_mask(:)=.false.
16719 !----------------------
16720 ! common.sccor
16721 ! Parameters of the SCCOR term
16722 !      common/sccor/
16723 !el in io_conf: parmread
16724 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
16725 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
16726 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
16727 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
16728 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
16729 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
16730 !      allocate(vlor1sccor(maxterm_sccor,20,20))
16731 !      allocate(vlor2sccor(maxterm_sccor,20,20))
16732 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
16733 !----------------
16734       allocate(gloc_sc(3,0:2*nres,0:10))
16735 !(3,0:maxres2,10)maxres2=2*maxres
16736       allocate(dcostau(3,3,3,2*nres))
16737       allocate(dsintau(3,3,3,2*nres))
16738       allocate(dtauangle(3,3,3,2*nres))
16739       allocate(dcosomicron(3,3,3,2*nres))
16740       allocate(domicron(3,3,3,2*nres))
16741 !(3,3,3,maxres2)maxres2=2*maxres
16742 !----------------------
16743 ! common.var
16744 !      common /restr/
16745       allocate(varall(maxvar))
16746 !(maxvar)(maxvar=6*maxres)
16747       allocate(mask_theta(nres))
16748       allocate(mask_phi(nres))
16749       allocate(mask_side(nres))
16750 !(maxres)
16751 !----------------------
16752 ! common.vectors
16753 !      common /vectors/
16754       allocate(uy(3,nres))
16755       allocate(uz(3,nres))
16756 !(3,maxres)
16757       allocate(uygrad(3,3,2,nres))
16758       allocate(uzgrad(3,3,2,nres))
16759 !(3,3,2,maxres)
16760
16761       return
16762       end subroutine alloc_ener_arrays
16763 !-----------------------------------------------------------------------------
16764 !-----------------------------------------------------------------------------
16765       end module energy